home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / lib / Exporter / Heavy.pm
Text File  |  2000-03-03  |  6KB  |  226 lines
  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.       (undef) = shift;            # XXX redundant arg
  183.       my $callpkg = caller($level);
  184.       $pkg->export($callpkg, @_);
  185. }
  186.  
  187. # Utility functions
  188.  
  189. sub _push_tags {
  190.     my($pkg, $var, $syms) = @_;
  191.     my $nontag;
  192.     *export_tags = \%{"${pkg}::EXPORT_TAGS"};
  193.     push(@{"${pkg}::$var"},
  194.     map { $export_tags{$_} ? @{$export_tags{$_}} : scalar(++$nontag,$_) }
  195.         (@$syms) ? @$syms : keys %export_tags);
  196.     if ($nontag and $^W) {
  197.     # This may change to a die one day
  198.     require Carp;
  199.     Carp::carp("Some names are not tags");
  200.     }
  201. }
  202.  
  203. # Default methods
  204.  
  205. sub export_fail {
  206.     my $self = shift;
  207.     @_;
  208. }
  209.  
  210. sub require_version {
  211.     my($self, $wanted) = @_;
  212.     my $pkg = ref $self || $self;
  213.     my $version = ${"${pkg}::VERSION"};
  214.     if (!$version or $version < $wanted) {
  215.     $version ||= "(undef)";
  216.         # %INC contains slashes, but $pkg contains double-colons.
  217.     my $file = (map {s,::,/,g; $INC{$_}} "$pkg.pm")[0];
  218.     $file &&= " ($file)";
  219.     require Carp;
  220.     Carp::croak("$pkg $wanted required--this is only version $version$file")
  221.     }
  222.     $version;
  223. }
  224.  
  225. 1;
  226.