lib/Exporter/Heavy.pm

   1 package Exporter;
   2
   3 =head1 NAME
   4
   5 Exporter::Heavy - Exporter guts
   6
   7 =head1 SYNOPIS
   8
   9 (internal use only)
  10
  11 =head1 DESCRIPTION
  12
  13 No user-serviceable parts inside.
  14
  15 =cut
  16 #
  17 # We go to a lot of trouble not to 'require Carp' at file scope,
  18 #  because Carp requires Exporter, and something has to give.
  19 #
  20
  21 sub heavy_export {
  22
  23     # First make import warnings look like they're coming from the "use".
  24     local $SIG{__WARN__} = sub {
  25         my $text = shift;
  26         if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {
  27             require Carp;
  28             local $Carp::CarpLevel = 1; # ignore package calling us too.
  29             Carp::carp($text);
  30         }
  31         else {
  32             warn $text;
  33         }
  34     };
  35     local $SIG{__DIE__} = sub {
  36         require Carp;
  37         local $Carp::CarpLevel = 1;     # ignore package calling us too.
  38         Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
  39             if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
  40     };
  41
  42     my($pkg, $callpkg, @imports) = @_;
  43     my($type, $sym, $oops);
  44     *exports = *{"${pkg}::EXPORT"};
  45
  46     if (@imports) {
  47         if (!%exports) {
  48             grep(s/^&//, @exports);
  49             @exports{@exports} = (1) x @exports;
  50             my $ok = \@{"${pkg}::EXPORT_OK"};
  51             if (@$ok) {
  52                 grep(s/^&//, @$ok);
  53                 @exports{@$ok} = (1) x @$ok;
  54             }
  55         }
  56
  57         if ($imports[0] =~ m#^[/!:]#){
  58             my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
  59             my $tagdata;
  60             my %imports;
  61             my($remove, $spec, @names, @allexports);
  62             # negated first item implies starting with default set:
  63             unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
  64             foreach $spec (@imports){
  65                 $remove = $spec =~ s/^!//;
  66
  67                 if ($spec =~ s/^://){
  68                     if ($spec eq 'DEFAULT'){
  69                         @names = @exports;
  70                     }
  71                     elsif ($tagdata = $tagsref->{$spec}) {
  72                         @names = @$tagdata;
  73                     }
  74                     else {
  75                         warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
  76                         ++$oops;
  77                         next;
  78                     }
  79                 }
  80                 elsif ($spec =~ m:^/(.*)/$:){
  81                     my $patn = $1;
  82                     @allexports = keys %exports unless @allexports; # only do keys once
  83                     @names = grep(/$patn/, @allexports); # not anchored by default
  84                 }
  85                 else {
  86                     @names = ($spec); # is a normal symbol name
  87                 }
  88
  89                 warn "Import ".($remove ? "del":"add").": @names "
  90                     if $Verbose;
  91
  92                 if ($remove) {
  93                    foreach $sym (@names) { delete $imports{$sym} }
  94                 }
  95                 else {
  96                     @imports{@names} = (1) x @names;
  97                 }
  98             }
  99             @imports = keys %imports;
 100         }
 101
 102         foreach $sym (@imports) {
 103             if (!$exports{$sym}) {
 104                 if ($sym =~ m/^\d/) {
 105                     $pkg->require_version($sym);
 106                     # If the version number was the only thing specified
 107                     # then we should act as if nothing was specified:
 108                     if (@imports == 1) {
 109                         @imports = @exports;
 110                         last;
 111                     }
 112                     # We need a way to emulate 'use Foo ()' but still
 113                     # allow an easy version check: "use Foo 1.23, ''";
 114                     if (@imports == 2 and !$imports[1]) {
 115                         @imports = ();
 116                         last;
 117                     }
 118                 } elsif ($sym !~ s/^&// || !$exports{$sym}) {
 119                     require Carp;
 120                     Carp::carp(qq["$sym" is not exported by the $pkg module]);
 121                     $oops++;
 122                 }
 123             }
 124         }
 125         if ($oops) {
 126             require Carp;
 127             Carp::croak("Can't continue after import errors");
 128         }
 129     }
 130     else {
 131         @imports = @exports;
 132     }
 133
 134     *fail = *{"${pkg}::EXPORT_FAIL"};
 135     if (@fail) {
 136         if (!%fail) {
 137             # Build cache of symbols. Optimise the lookup by adding
 138             # barewords twice... both with and without a leading &.
 139             # (Technique could be applied to %exports cache at cost of memory)
 140             my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @fail;
 141             warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Verbose;
 142             @fail{@expanded} = (1) x @expanded;
 143         }
 144         my @failed;
 145         foreach $sym (@imports) { push(@failed, $sym) if $fail{$sym} }
 146         if (@failed) {
 147             @failed = $pkg->export_fail(@failed);
 148             foreach $sym (@failed) {
 149                 require Carp;
 150                 Carp::carp(qq["$sym" is not implemented by the $pkg module ],
 151                         "on this architecture");
 152             }
 153             if (@failed) {
 154                 require Carp;
 155                 Carp::croak("Can't continue after import errors");
 156             }
 157         }
 158     }
 159
 160     warn "Importing into $callpkg from $pkg: ",
 161                 join(", ",sort @imports) if $Verbose;
 162
 163     foreach $sym (@imports) {
 164         # shortcut for the common case of no type character
 165         (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
 166             unless $sym =~ s/^(\W)//;
 167         $type = $1;
 168         *{"${callpkg}::$sym"} =
 169             $type eq '&' ? \&{"${pkg}::$sym"} :
 170             $type eq '$' ? \${"${pkg}::$sym"} :
 171             $type eq '@' ? \@{"${pkg}::$sym"} :
 172             $type eq '%' ? \%{"${pkg}::$sym"} :
 173             $type eq '*' ?  *{"${pkg}::$sym"} :
 174             do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
 175     }
 176 }
 177
 178 sub heavy_export_to_level
 179 {
 180       my $pkg = shift;
 181       my $level = shift;
 182       my $callpkg = caller($level);
 183       $pkg->export($callpkg, @_);
 184 }
 185
 186 # Utility functions
 187
 188 sub _push_tags {
 189     my($pkg, $var, $syms) = @_;
 190     my $nontag;
 191     *export_tags = \%{"${pkg}::EXPORT_TAGS"};
 192     push(@{"${pkg}::$var"},
 193         map { $export_tags{$_} ? @{$export_tags{$_}} : scalar(++$nontag,$_) }
 194                 (@$syms) ? @$syms : keys %export_tags);
 195     if ($nontag and $^W) {
 196         # This may change to a die one day
 197         require Carp;
 198         Carp::carp("Some names are not tags");
 199     }
 200 }
 201
 202 # Default methods
 203
 204 sub export_fail {
 205     my $self = shift;
 206     @_;
 207 }
 208
 209 sub require_version {
 210     my($self, $wanted) = @_;
 211     my $pkg = ref $self || $self;
 212     my $version = ${"${pkg}::VERSION"};
 213     if (!$version or $version < $wanted) {
 214         $version ||= "(undef)";
 215         my $file = $INC{"$pkg.pm"};
 216         $file &&= " ($file)";
 217         require Carp;
 218         Carp::croak("$pkg $wanted required--this is only version $version$file")
 219     }
 220     $version;
 221 }
 222
 223 1;