home *** CD-ROM | disk | FTP | other *** search
/ Caldera Network Desktop 1.0 / caldera-network-desktop-1.0.bin / images / ramdisk2.img / usr / lib / perl5 / Exporter.pm < prev    next >
Text File  |  1995-07-19  |  4KB  |  156 lines
  1. package Exporter;
  2.  
  3. =head1 Comments
  4.  
  5. If the first entry in an import list begins with !, : or / then the
  6. list is treated as a series of specifications which either add to or
  7. delete from the list of names to import. They are processed left to
  8. right. Specifications are in the form:
  9.  
  10.     [!]name         This name only
  11.     [!]:DEFAULT     All names in @EXPORT
  12.     [!]:tag         All names in $EXPORT_TAGS{tag} anonymous list
  13.     [!]/pattern/    All names in @EXPORT and @EXPORT_OK which match
  14.  
  15. A leading ! indicates that matching names should be deleted from the
  16. list of names to import.  If the first specification is a deletion it
  17. is treated as though preceded by :DEFAULT. If you just want to import
  18. extra names in addition to the default set you will still need to
  19. include :DEFAULT explicitly.
  20.  
  21. e.g., Module.pm defines:
  22.  
  23.     @EXPORT      = qw(A1 A2 A3 A4 A5);
  24.     @EXPORT_OK   = qw(B1 B2 B3 B4 B5);
  25.     %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
  26.  
  27.     Note that you cannot use tags in @EXPORT or @EXPORT_OK.
  28.     Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
  29.  
  30. Application says:
  31.  
  32.     use Module qw(:DEFAULT :T2 !B3 A3);
  33.     use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
  34.     use POSIX  qw(/^S_/ acos asin atan /^E/ !/^EXIT/);
  35.  
  36. You can set C<$Exporter::Verbose=1;> to see how the specifications are
  37. being processed and what is actually being imported into modules.
  38.  
  39. =cut
  40.  
  41. require 5.001;
  42.  
  43. $ExportLevel = 0;
  44. $Verbose = 0;
  45.  
  46. require Carp;
  47.  
  48. sub export {
  49.  
  50.     # First make import warnings look like they're coming from the "use".
  51.     local $SIG{__WARN__} = sub {
  52.     my $text = shift;
  53.     $text =~ s/ at \S*Exporter.pm line \d+.\n//;
  54.     local $Carp::CarpLevel = 1;    # ignore package calling us too.
  55.     Carp::carp($text);
  56.     };
  57.  
  58.     my $pkg = shift;
  59.     my $callpkg = shift;
  60.     my @imports = @_;
  61.     my($type, $sym);
  62.     *exports = \@{"${pkg}::EXPORT"};
  63.     if (@imports) {
  64.     my $oops;
  65.     *exports = \%{"${pkg}::EXPORT"};
  66.     if (!%exports) {
  67.         grep(s/^&//, @exports);
  68.         @exports{@exports} = (1) x  @exports;
  69.         foreach $extra (@{"${pkg}::EXPORT_OK"}) {
  70.         $exports{$extra} = 1;
  71.         }
  72.     }
  73.  
  74.     if ($imports[0] =~ m#^[/!:]#){
  75.         my(@allexports) = keys %exports;
  76.         my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
  77.         my $tagdata;
  78.         my %imports;
  79.         # negated first item implies starting with default set:
  80.         unshift(@imports, ':DEFAULT') if $imports[0] =~ m/^!/;
  81.         foreach (@imports){
  82.         my(@names);
  83.         my($mode,$spec) = m/^(!)?(.*)/;
  84.         $mode = '+' unless defined $mode;
  85.  
  86.         @names = ($spec); # default, maybe overridden below
  87.  
  88.         if ($spec =~ m:^/(.*)/$:){
  89.             my $patn = $1;
  90.             @names = grep(/$patn/, @allexports); # XXX anchor by default?
  91.         }
  92.         elsif ($spec =~ m#^:(.*)# and $tagsref){
  93.             if ($1 eq 'DEFAULT'){
  94.             @names = @exports;
  95.             }
  96.             elsif ($tagsref and $tagdata = $tagsref->{$1}) {
  97.             @names = @$tagdata;
  98.             }
  99.         }
  100.  
  101.         warn "Import Mode $mode, Spec $spec, Names @names\n" if $Verbose;
  102.         if ($mode eq '!') {
  103.            map {delete $imports{$_}} @names; # delete @imports{@names} would be handy :-)
  104.         }
  105.         else {
  106.            @imports{@names} = (1) x @names;
  107.         }
  108.         }
  109.         @imports = keys %imports;
  110.     }
  111.  
  112.     foreach $sym (@imports) {
  113.         if (!$exports{$sym}) {
  114.         if ($sym !~ s/^&// || !$exports{$sym}) {
  115.             warn qq["$sym" is not exported by the $pkg module ],
  116.                 "at $callfile line $callline\n";
  117.             $oops++;
  118.             next;
  119.         }
  120.         }
  121.     }
  122.     Carp::croak("Can't continue with import errors.\n") if $oops;
  123.     }
  124.     else {
  125.     @imports = @exports;
  126.     }
  127.     warn "Importing from $pkg into $callpkg: ",
  128.         join(", ",@imports),"\n" if ($Verbose && @imports);
  129.     foreach $sym (@imports) {
  130.     $type = '&';
  131.     $type = $1 if $sym =~ s/^(\W)//;
  132.     *{"${callpkg}::$sym"} =
  133.         $type eq '&' ? \&{"${pkg}::$sym"} :
  134.         $type eq '$' ? \${"${pkg}::$sym"} :
  135.         $type eq '@' ? \@{"${pkg}::$sym"} :
  136.         $type eq '%' ? \%{"${pkg}::$sym"} :
  137.         $type eq '*' ?  *{"${pkg}::$sym"} :
  138.             warn "Can't export symbol: $type$sym\n";
  139.     }
  140. };
  141.  
  142. sub import {
  143.     local ($callpkg, $callfile, $callline) = caller($ExportLevel);
  144.     my $pkg = shift;
  145.     export $pkg, $callpkg, @_;
  146. }
  147.  
  148. sub export_tags {
  149.     my ($pkg) = caller;
  150.     *tags = \%{"${pkg}::EXPORT_TAGS"};
  151.     push(@{"${pkg}::EXPORT"},
  152.     map {$tags{$_} ? @{$tags{$_}} : $_} @_ ? @_ : keys %tags);
  153. }
  154.  
  155. 1;
  156.