lib/Exporter.pm

   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;