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     local $SIG{__DIE__} = sub {
  68         Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
  69             if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
  70     };
  71
  72     my $pkg = shift;
  73     my $callpkg = shift;
  74     my @imports = @_;
  75     my($type, $sym);
  76     *exports = \@{"${pkg}::EXPORT"};
  77     if (@imports) {
  78         my $oops;
  79         *exports = \%{"${pkg}::EXPORT"};
  80         if (!%exports) {
  81             grep(s/^&//, @exports);
  82             @exports{@exports} = (1) x  @exports;
  83             foreach $extra (@{"${pkg}::EXPORT_OK"}) {
  84                 $exports{$extra} = 1;
  85             }
  86         }
  87
  88         if ($imports[0] =~ m#^[/!:]#){
  89             my(@allexports) = keys %exports;
  90             my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
  91             my $tagdata;
  92             my %imports;
  93             # negated first item implies starting with default set:
  94             unshift(@imports, ':DEFAULT') if $imports[0] =~ m/^!/;
  95             foreach (@imports){
  96                 my(@names);
  97                 my($mode,$spec) = m/^(!)?(.*)/;
  98                 $mode = '+' unless defined $mode;
  99
 100                 @names = ($spec); # default, maybe overridden below
 101
 102                 if ($spec =~ m:^/(.*)/$:){
 103                     my $patn = $1;
 104                     @names = grep(/$patn/, @allexports); # XXX anchor by default?
 105                 }
 106                 elsif ($spec =~ m#^:(.*)# and $tagsref){
 107                     if ($1 eq 'DEFAULT'){
 108                         @names = @exports;
 109                     }
 110                     elsif ($tagsref and $tagdata = $tagsref->{$1}) {
 111                         @names = @$tagdata;
 112                     }
 113                 }
 114
 115                 warn "Import Mode $mode, Spec $spec, Names @names\n" if $Verbose;
 116                 if ($mode eq '!') {
 117                    map {delete $imports{$_}} @names; # delete @imports{@names} would be handy :-)
 118                 }
 119                 else {
 120                    @imports{@names} = (1) x @names;
 121                 }
 122             }
 123             @imports = keys %imports;
 124         }
 125
 126         foreach $sym (@imports) {
 127             if (!$exports{$sym}) {
 128                 if ($sym =~ m/^\d/) {
 129                     $pkg->require_version($sym);
 130                     # If the version number was the only thing specified
 131                     # then we should act as if nothing was specified:
 132                     if (@imports == 1) {
 133                         @imports = @exports;
 134                         last;
 135                     }
 136                 } elsif ($sym !~ s/^&// || !$exports{$sym}) {
 137                     warn qq["$sym" is not exported by the $pkg module ],
 138                             "at $callfile line $callline\n";
 139                     $oops++;
 140                     next;
 141                 }
 142             }
 143         }
 144         Carp::croak("Can't continue with import errors.\n") if $oops;
 145     }
 146     else {
 147         @imports = @exports;
 148     }
 149     warn "Importing from $pkg into $callpkg: ",
 150                 join(", ",@imports),"\n" if ($Verbose && @imports);
 151     foreach $sym (@imports) {
 152         $type = '&';
 153         $type = $1 if $sym =~ s/^(\W)//;
 154         *{"${callpkg}::$sym"} =
 155             $type eq '&' ? \&{"${pkg}::$sym"} :
 156             $type eq '$' ? \${"${pkg}::$sym"} :
 157             $type eq '@' ? \@{"${pkg}::$sym"} :
 158             $type eq '%' ? \%{"${pkg}::$sym"} :
 159             $type eq '*' ?  *{"${pkg}::$sym"} :
 160                     warn "Can't export symbol: $type$sym\n";
 161     }
 162 };
 163
 164 sub import {
 165     local ($callpkg, $callfile, $callline) = caller($ExportLevel);
 166     my $pkg = shift;
 167     export $pkg, $callpkg, @_;
 168 }
 169
 170 sub export_tags {
 171     my ($pkg) = caller;
 172     *tags = \%{"${pkg}::EXPORT_TAGS"};
 173     push(@{"${pkg}::EXPORT"},
 174         map {$tags{$_} ? @{$tags{$_}} : $_} @_ ? @_ : keys %tags);
 175 }
 176
 177 sub require_version {
 178     my($self, $wanted) = @_;
 179     my $pkg = ref $self || $self;
 180     my $version = ${"${pkg}::VERSION"} || "(undef)";
 181     Carp::croak("$pkg $wanted required--this is only version $version")
 182                 if $version < $wanted;
 183     $version;
 184 }
 185
 186 1;