1N/Apackage Exporter::Heavy;

1N/A

1N/Ause strict;

1N/Ano strict 'refs';

1N/A

1N/Arequire Exporter; our $VERSION = $Exporter::VERSION;

1N/A$Carp::Internal{"Exporter::Heavy"} = 1;

1N/A

1N/A

1N/A

1N/Asub _rebuild_cache {

1N/A my ($pkg, $exports, $cache) = @_;

1N/A s/^&// foreach @$exports;

1N/A @{$cache}{@$exports} = (1) x @$exports;

1N/A my $ok = \@{"${pkg}::EXPORT_OK"};

1N/A if (@$ok) {

1N/A s/^&// foreach @$ok;

1N/A @{$cache}{@$ok} = (1) x @$ok;

1N/A }

1N/A}

1N/A

1N/Asub heavy_export {

1N/A

1N/A # First make import warnings look like they're coming from the "use".

1N/A local $SIG{__WARN__} = sub {

1N/A my $text = shift;

1N/A if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {

1N/A require Carp;

1N/A local $Carp::CarpLevel = 1; # ignore package calling us too.

1N/A Carp::carp($text);

1N/A }

1N/A else {

1N/A warn $text;

1N/A }

1N/A };

1N/A local $SIG{__DIE__} = sub {

1N/A require Carp;

1N/A local $Carp::CarpLevel = 1; # ignore package calling us too.

1N/A Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")

1N/A if $_[0] =~ /^Unable to create sub named "(.*?)::"/;

1N/A };

1N/A

1N/A my($pkg, $callpkg, @imports) = @_;

1N/A my($type, $sym, $cache_is_current, $oops);

1N/A my($exports, $export_cache) = (\@{"${pkg}::EXPORT"},

1N/A $Exporter::Cache{$pkg} ||= {});

1N/A

1N/A if (@imports) {

1N/A if (!%$export_cache) {

1N/A _rebuild_cache ($pkg, $exports, $export_cache);

1N/A $cache_is_current = 1;

1N/A }

1N/A

1N/A if (grep m{^[/!:]}, @imports) {

1N/A my $tagsref = \%{"${pkg}::EXPORT_TAGS"};

1N/A my $tagdata;

1N/A my %imports;

1N/A my($remove, $spec, @names, @allexports);

1N/A # negated first item implies starting with default set:

1N/A unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;

1N/A foreach $spec (@imports){

1N/A $remove = $spec =~ s/^!//;

1N/A

1N/A if ($spec =~ s/^://){

1N/A if ($spec eq 'DEFAULT'){

1N/A @names = @$exports;

1N/A }

1N/A elsif ($tagdata = $tagsref->{$spec}) {

1N/A @names = @$tagdata;

1N/A }

1N/A else {

1N/A warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];

1N/A ++$oops;

1N/A next;

1N/A }

1N/A }

1N/A elsif ($spec =~ m:^/(.*)/$:){

1N/A my $patn = $1;

1N/A @allexports = keys %$export_cache unless @allexports; # only do keys once

1N/A @names = grep(/$patn/, @allexports); # not anchored by default

1N/A }

1N/A else {

1N/A @names = ($spec); # is a normal symbol name

1N/A }

1N/A

1N/A warn "Import ".($remove ? "del":"add").": @names "

1N/A if $Exporter::Verbose;

1N/A

1N/A if ($remove) {

1N/A foreach $sym (@names) { delete $imports{$sym} }

1N/A }

1N/A else {

1N/A @imports{@names} = (1) x @names;

1N/A }

1N/A }

1N/A @imports = keys %imports;

1N/A }

1N/A

1N/A my @carp;

1N/A foreach $sym (@imports) {

1N/A if (!$export_cache->{$sym}) {

1N/A if ($sym =~ m/^\d/) {

1N/A $pkg->VERSION($sym); # inherit from UNIVERSAL

1N/A # If the version number was the only thing specified

1N/A # then we should act as if nothing was specified:

1N/A if (@imports == 1) {

1N/A @imports = @$exports;

1N/A last;

1N/A }

1N/A # We need a way to emulate 'use Foo ()' but still

1N/A # allow an easy version check: "use Foo 1.23, ''";

1N/A if (@imports == 2 and !$imports[1]) {

1N/A @imports = ();

1N/A last;

1N/A }

1N/A } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) {

1N/A # Last chance - see if they've updated EXPORT_OK since we

1N/A # cached it.

1N/A

1N/A unless ($cache_is_current) {

1N/A %$export_cache = ();

1N/A _rebuild_cache ($pkg, $exports, $export_cache);

1N/A $cache_is_current = 1;

1N/A }

1N/A

1N/A if (!$export_cache->{$sym}) {

1N/A # accumulate the non-exports

1N/A push @carp,

1N/A qq["$sym" is not exported by the $pkg module\n];

1N/A $oops++;

1N/A }

1N/A }

1N/A }

1N/A }

1N/A if ($oops) {

1N/A require Carp;

1N/A Carp::croak("@{carp}Can't continue after import errors");

1N/A }

1N/A }

1N/A else {

1N/A @imports = @$exports;

1N/A }

1N/A

1N/A my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"},

1N/A $Exporter::FailCache{$pkg} ||= {});

1N/A

1N/A if (@$fail) {

1N/A if (!%$fail_cache) {

1N/A # Build cache of symbols. Optimise the lookup by adding

1N/A # barewords twice... both with and without a leading &.

1N/A # (Technique could be applied to $export_cache at cost of memory)

1N/A my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail;

1N/A warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose;

1N/A @{$fail_cache}{@expanded} = (1) x @expanded;

1N/A }

1N/A my @failed;

1N/A foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} }

1N/A if (@failed) {

1N/A @failed = $pkg->export_fail(@failed);

1N/A foreach $sym (@failed) {

1N/A require Carp;

1N/A Carp::carp(qq["$sym" is not implemented by the $pkg module ],

1N/A "on this architecture");

1N/A }

1N/A if (@failed) {

1N/A require Carp;

1N/A Carp::croak("Can't continue after import errors");

1N/A }

1N/A }

1N/A }

1N/A

1N/A warn "Importing into $callpkg from $pkg: ",

1N/A join(", ",sort @imports) if $Exporter::Verbose;

1N/A

1N/A foreach $sym (@imports) {

1N/A # shortcut for the common case of no type character

1N/A (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)

1N/A unless $sym =~ s/^(\W)//;

1N/A $type = $1;

1N/A *{"${callpkg}::$sym"} =

1N/A $type eq '&' ? \&{"${pkg}::$sym"} :

1N/A $type eq '$' ? \${"${pkg}::$sym"} :

1N/A $type eq '@' ? \@{"${pkg}::$sym"} :

1N/A $type eq '%' ? \%{"${pkg}::$sym"} :

1N/A $type eq '*' ? *{"${pkg}::$sym"} :

1N/A do { require Carp; Carp::croak("Can't export symbol: $type$sym") };

1N/A }

1N/A}

1N/A

1N/Asub heavy_export_to_level

1N/A{

1N/A my $pkg = shift;

1N/A my $level = shift;

1N/A (undef) = shift; # XXX redundant arg

1N/A my $callpkg = caller($level);

1N/A $pkg->export($callpkg, @_);

1N/A}

1N/A

1N/A

1N/Asub _push_tags {

1N/A my($pkg, $var, $syms) = @_;

1N/A my @nontag = ();

1N/A my $export_tags = \%{"${pkg}::EXPORT_TAGS"};

1N/A push(@{"${pkg}::$var"},

1N/A map { $export_tags->{$_} ? @{$export_tags->{$_}}

1N/A : scalar(push(@nontag,$_),$_) }

1N/A (@$syms) ? @$syms : keys %$export_tags);

1N/A if (@nontag and $^W) {

1N/A # This may change to a die one day

1N/A require Carp;

1N/A Carp::carp(join(", ", @nontag)." are not tags of $pkg");

1N/A }

1N/A}

1N/A

1N/Asub heavy_require_version {

1N/A my($self, $wanted) = @_;

1N/A my $pkg = ref $self || $self;

1N/A return ${pkg}->VERSION($wanted);

1N/A}

1N/A

1N/Asub heavy_export_tags {

1N/A _push_tags((caller)[0], "EXPORT", \@_);

1N/A}

1N/A

1N/Asub heavy_export_ok_tags {

1N/A _push_tags((caller)[0], "EXPORT_OK", \@_);

1N/A}

1N/A

1N/A1;