Symbol::Util - Additional utils for Perl symbols manipulation

  use Symbol::Util ':all';

  my $caller = caller;
  *{ fetch_glob("${caller}::foo") } = sub { "this is foo" };
  my $coderef = fetch_glob("${caller}::bar", "CODE");
  sub baz { 42; }
  export_glob($caller, "baz");

  print join "\n", keys %{ stash("main") };

  delete_glob("${caller}::foo", "CODE");

  use constant PI => 3.14159265;
  delete_sub "PI";   # remove constant from public API

  require YAML;
  export_package(__PACKAGE__, "YAML", "Dump");   # import YAML::Dump
  unexport_package(__PACKAGE, "YAML");   # remove imported symbols

  no Symbol::Util;   # clean all symbols imported from Symbol::Util

#!/usr/bin/perl -c

package Symbol::Util;

use 5.006;

use strict;
use warnings;

our $VERSION = '0.0202';


# Exported symbols $EXPORTED{$target}{$package}{$name}{$slot} = 1
my %EXPORTED;


## no critic qw(ProhibitSubroutinePrototypes)
## no critic qw(RequireArgUnpacking)

sub import {
    my ($package, @names) = @_;

    my $caller = caller();

    my @EXPORT_OK = grep { /^[a-z]/ && !/^(?:import|unimport)$/ } keys %{ stash(__PACKAGE__) };
    my %EXPORT_TAGS = ( all => [ @EXPORT_OK ] );

    return export_package($caller, $package, {
        OK => [ @EXPORT_OK ],
        TAGS => { %EXPORT_TAGS },
    }, @names);
};

sub unimport {
    my ($package) = @_;

    my $caller = caller();

    return unexport_package($caller, $package);
};

sub stash ($) {
    no strict 'refs';
    return \%{ *{ $_[0] . '::' } };
};

sub fetch_glob ($;$) {
    my ($name, $slot) = @_;

    $name = caller() . "::$name" unless $name =~ /::/;

    no strict 'refs';

    if (defined $slot) {
        return if $slot eq 'SCALAR' and not defined ${ *{ $name }{SCALAR} };
        return *{ $name }{$slot};
    };

    return \*{ $name };
};

sub list_glob_slots ($) {
    my ($name) = @_;

    $name = caller() . "::$name" unless $name =~ /::/;

    no strict 'refs';

    return if not defined *{ $name };

    my @slots;

    push @slots, 'SCALAR'
        if defined *{ $name }{SCALAR} and defined ${ *{ $name }{SCALAR} };

    foreach my $slot (qw( ARRAY HASH CODE IO )) {
        push @slots, $slot if defined *{ $name }{$slot};
    };

    return @slots;
};

sub export_glob ($$;@) {
    my ($target, $name, @slots) = @_;

    $name = caller() . "::$name" unless $name =~ /::/;
    (my $subname = $name) =~ s/^(.*):://;

    @slots = qw( SCALAR ARRAY HASH CODE IO ) unless @slots;

    no strict 'refs';

    return if not defined *{ $name };

    my $targetname = "${target}::$subname";

    my $defined;
    foreach my $slot (@slots) {
        next if $slot eq 'SCALAR' and not defined ${ *{ $name }{$slot} };
        next if not defined *{ $name }{$slot};
        *{ $targetname } = *{ $name }{$slot};
        $defined = 1;
    };

    return $defined ? \*{ $targetname } : undef;
};

sub delete_glob ($;@) {
    my ($name, @slots) = @_;

    $name = caller() . "::$name" unless $name =~ /::/;
    $name =~ /^(.*)::([^:]*)/;
    my ($package, $subname) = ($1, $2);  ## no critic qw(ProhibitCaptureWithoutTest)

    my $stash = stash($package);

    if (@slots) {
        my %delete = map { $_ => 1 } @slots;
        my %backup;

        foreach my $slot (list_glob_slots($name)) {
            $backup{$slot} = fetch_glob($name, $slot)
                if not $delete{$slot};
        };

        undef $stash->{$subname};

        foreach my $slot (keys %backup) {
            *{ fetch_glob($name) } = $backup{$slot};
        };

        return fetch_glob($name);
    }
    else {
        # delete all slots
        undef $stash->{$subname};
    };

    return;
};

sub delete_sub ($) {
    my ($name) = @_;

    $name = caller() . "::$name" unless $name =~ /::/;
    $name =~ /^(.*)::([^:]*)/;
    my ($package, $subname) = ($1, $2);  ## no critic qw(ProhibitCaptureWithoutTest)

    return if not defined fetch_glob($name, 'CODE');

    my $stash = stash($package);

    my %backup;

    foreach my $slot (list_glob_slots($name)) {
        $backup{$slot} = fetch_glob($name, $slot);
    };

    *{ fetch_glob($name) } = $backup{CODE};
    delete $backup{CODE};

    delete $stash->{$subname};

    foreach my $slot (keys %backup) {
        *{ fetch_glob($name) } = $backup{$slot};
    };

    return %backup ? fetch_glob($name) : undef;
};

sub export_package ($$@) {
    my $target = shift;
    my $package = shift;
    my $spec = ref $_[0] eq 'HASH' ? shift : {
        EXPORT => fetch_glob("${package}::EXPORT", "ARRAY"),
        OK     => fetch_glob("${package}::EXPORT_OK", "ARRAY"),
        TAGS   => fetch_glob("${package}::EXPORT_TAGS", "HASH"),
    };

    my @names = @_;

    # support: use Package 3.14 qw();
    return 1 if @names == 1 and $names[0] eq '';

    # default exports on empty list or if first element is negation
    unshift @names, ":DEFAULT" if not @names or @names and $names[0] =~ /^!/;

    my @export = ref ($spec->{EXPORT} || '') eq 'ARRAY' ? @{ $spec->{EXPORT} } : ();
    my @export_ok = ref ($spec->{OK} || '') eq 'ARRAY' ? @{ $spec->{OK} } : ();
    my %export_tags = ref ($spec->{TAGS} || '') eq 'HASH' ? %{ $spec->{TAGS} } : ();

    my %export = map { $_ => 1 } @export;
    my %export_ok = map { $_ => 1 } @export_ok;

    my %names;

    while (my $name = shift @names) {
        if ($name =~ m{^/(.*)/$}) {
            my $pattern = $1;
            $names{$_} = 1 foreach grep { /$pattern/ } (@export, @export_ok);
        }
        elsif ($name =~ m{^!/(.*)/$}) {
            my $pattern = $1;
            %names = map { $_ => 1 } grep { ! /$pattern/ } keys %names;
        }
        elsif ($name =~ /^(!?):DEFAULT$/) {
            my $neg = $1;
            unshift @names, map { "${neg}$_" } @export;
        }
        elsif ($name =~ /^(!?):(.*)$/) {
            my ($neg, $tag) = ($1, $2);
            if (defined $export_tags{$tag}) {
                unshift @names, map { "${neg}$_" } @{ $export_tags{$tag} };
            }
            else {
                require Carp;
                Carp::croak("$name is not a tag of the $package module");
            };
        }
        elsif ($name =~ /^!(.*)$/) {
            $name = $1;
            delete $names{$name};
        }
        elsif (defined $export_ok{$name} or defined $export{$name}) {
            $names{$name} = 1;
        }
        else {
            require Carp;
            Carp::croak("$name is not exported by the $package module");
        };
    };

    foreach my $name (keys %names) {
        my $type = '';
        if ($name =~ s/^(\W)//) {
            $type = $1;
        };

        my @slots;
        if ($type eq '&' or $type eq '') {
            push @slots, 'CODE';
        }
        elsif ($type eq '$') {
            push @slots, 'SCALAR';
        }
        elsif ($type eq '@') {
            push @slots, 'ARRAY';
        }
        elsif ($type eq '%') {
            push @slots, 'HASH';
        }
        elsif ($type eq '*') {
            push @slots, 'IO';
        }
        else {
            require Carp;
            Carp::croak("Can't export symbol $type$name");
        };
        foreach my $slot (@slots) {
            if (defined export_glob($target, "${package}::$name", $slot)) {
                $EXPORTED{$target}{$package}{$name}{$slot} = 1;
            };
        };
    };

    return 1;
};

sub unexport_package ($$) {
    my ($target, $package) = @_;

    if (defined $EXPORTED{$target}{$package}) {
        foreach my $name (keys %{ $EXPORTED{$target}{$package} }) {
            # CODE slot have to be the last one
            foreach my $slot ( qw( SCALAR ARRAY HASH IO CODE ) ) {
                next unless exists $EXPORTED{$target}{$package}{$name}{$slot};
                if ($slot eq 'CODE') {
                    delete_sub("${target}::$name");
                }
                else {
                    delete_glob("${target}::$name", $slot);
                };
            };
        };
        delete $EXPORTED{$target}{$package};
    };

    return 1;
};


1;