lib/Exporter/Heavy.pm

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