lib/Exporter.pm

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