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 =head2 Module Version Checking
  40
  41 The Exporter module will convert an attempt to import a number from a
  42 module into a call to $module_name->require_version($value). This can
  43 be used to validate that the version of the module being used is
  44 greater than or equal to the required version.
  45
  46 The Exporter module supplies a default require_version method which
  47 checks the value of $VERSION in the exporting module.
  48
  49 =cut
  50
  51 require 5.001;
  52
  53 $ExportLevel = 0;
  54 $Verbose = 0;
  55
  56 require Carp;
  57
  58 sub export {
  59
  60     # First make import warnings look like they're coming from the "use".
  61     local $SIG{__WARN__} = sub {
  62         my $text = shift;
  63         $text =~ s/ at \S*Exporter.pm line \d+.\n//;
  64         local $Carp::CarpLevel = 1;     # ignore package calling us too.
  65         Carp::carp($text);
  66     };
  67
  68     my $pkg = shift;
  69     my $callpkg = shift;
  70     my @imports = @_;
  71     my($type, $sym);
  72     *exports = \@{"${pkg}::EXPORT"};
  73     if (@imports) {
  74         my $oops;
  75         *exports = \%{"${pkg}::EXPORT"};
  76         if (!%exports) {
  77             grep(s/^&//, @exports);
  78             @exports{@exports} = (1) x  @exports;
  79             foreach $extra (@{"${pkg}::EXPORT_OK"}) {
  80                 $exports{$extra} = 1;
  81             }
  82         }
  83
  84         if ($imports[0] =~ m#^[/!:]#){
  85             my(@allexports) = keys %exports;
  86             my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
  87             my $tagdata;
  88             my %imports;
  89             # negated first item implies starting with default set:
  90             unshift(@imports, ':DEFAULT') if $imports[0] =~ m/^!/;
  91             foreach (@imports){
  92                 my(@names);
  93                 my($mode,$spec) = m/^(!)?(.*)/;
  94                 $mode = '+' unless defined $mode;
  95
  96                 @names = ($spec); # default, maybe overridden below
  97
  98                 if ($spec =~ m:^/(.*)/$:){
  99                     my $patn = $1;
 100                     @names = grep(/$patn/, @allexports); # XXX anchor by default?
 101                 }
 102                 elsif ($spec =~ m#^:(.*)# and $tagsref){
 103                     if ($1 eq 'DEFAULT'){
 104                         @names = @exports;
 105                     }
 106                     elsif ($tagsref and $tagdata = $tagsref->{$1}) {
 107                         @names = @$tagdata;
 108                     }
 109                 }
 110
 111                 warn "Import Mode $mode, Spec $spec, Names @names\n" if $Verbose;
 112                 if ($mode eq '!') {
 113                    map {delete $imports{$_}} @names; # delete @imports{@names} would be handy :-)
 114                 }
 115                 else {
 116                    @imports{@names} = (1) x @names;
 117                 }
 118             }
 119             @imports = keys %imports;
 120         }
 121
 122         foreach $sym (@imports) {
 123             if (!$exports{$sym}) {
 124                 if ($sym =~ m/^\d/) {
 125                     $pkg->require_version($sym);
 126                     # If the version number was the only thing specified
 127                     # then we should act as if nothing was specified:
 128                     if (@imports == 1) {
 129                         @imports = @exports;
 130                         last;
 131                     }
 132                 } elsif ($sym !~ s/^&// || !$exports{$sym}) {
 133                     warn qq["$sym" is not exported by the $pkg module ],
 134                             "at $callfile line $callline\n";
 135                     $oops++;
 136                     next;
 137                 }
 138             }
 139         }
 140         Carp::croak("Can't continue with import errors.\n") if $oops;
 141     }
 142     else {
 143         @imports = @exports;
 144     }
 145     warn "Importing from $pkg into $callpkg: ",
 146                 join(", ",@imports),"\n" if ($Verbose && @imports);
 147     foreach $sym (@imports) {
 148         $type = '&';
 149         $type = $1 if $sym =~ s/^(\W)//;
 150         *{"${callpkg}::$sym"} =
 151             $type eq '&' ? \&{"${pkg}::$sym"} :
 152             $type eq '$' ? \${"${pkg}::$sym"} :
 153             $type eq '@' ? \@{"${pkg}::$sym"} :
 154             $type eq '%' ? \%{"${pkg}::$sym"} :
 155             $type eq '*' ?  *{"${pkg}::$sym"} :
 156                     warn "Can't export symbol: $type$sym\n";
 157     }
 158 };
 159
 160 sub import {
 161     local ($callpkg, $callfile, $callline) = caller($ExportLevel);
 162     my $pkg = shift;
 163     export $pkg, $callpkg, @_;
 164 }
 165
 166 sub export_tags {
 167     my ($pkg) = caller;
 168     *tags = \%{"${pkg}::EXPORT_TAGS"};
 169     push(@{"${pkg}::EXPORT"},
 170         map {$tags{$_} ? @{$tags{$_}} : $_} @_ ? @_ : keys %tags);
 171 }
 172
 173 sub require_version {
 174     my($self, $wanted) = @_;
 175     my $pkg = ref $self || $self;
 176     my $version = ${"${pkg}::VERSION"} || "(undef)";
 177     Carp::croak("$pkg $wanted required--this is only version $version")
 178                 if $version < $wanted;
 179     $version;
 180 }
 181
 182 1;