lib/Exporter.pm

   1 package Exporter;
   2
   3 =head1 NAME
   4
   5 Exporter - provide inport/export controls for Perl modules
   6
   7 =head1 SYNOPSIS
   8
   9 use Module;
  10 use Module qw(name1 name2 :tag /pattern/ !name);
  11
  12 =head1 DESCRIPTION
  13
  14 If the first entry in an import list begins with !, : or / then the
  15 list is treated as a series of specifications which either add to or
  16 delete from the list of names to import. They are processed left to
  17 right. Specifications are in the form:
  18
  19     [!]name         This name only
  20     [!]:DEFAULT     All names in @EXPORT
  21     [!]:tag         All names in $EXPORT_TAGS{tag} anonymous list
  22     [!]/pattern/    All names in @EXPORT and @EXPORT_OK which match
  23
  24 A leading ! indicates that matching names should be deleted from the
  25 list of names to import.  If the first specification is a deletion it
  26 is treated as though preceded by :DEFAULT. If you just want to import
  27 extra names in addition to the default set you will still need to
  28 include :DEFAULT explicitly.
  29
  30 e.g., Module.pm defines:
  31
  32     @EXPORT      = qw(A1 A2 A3 A4 A5);
  33     @EXPORT_OK   = qw(B1 B2 B3 B4 B5);
  34     %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
  35
  36     Note that you cannot use tags in @EXPORT or @EXPORT_OK.
  37     Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
  38
  39 Application says:
  40
  41     use Module qw(:DEFAULT :T2 !B3 A3);
  42     use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
  43     use POSIX  qw(/^S_/ acos asin atan /^E/ !/^EXIT/);
  44
  45 You can set C<$Exporter::Verbose=1;> to see how the specifications are
  46 being processed and what is actually being imported into modules.
  47
  48 =head2 Module Version Checking
  49
  50 The Exporter module will convert an attempt to import a number from a
  51 module into a call to $module_name->require_version($value). This can
  52 be used to validate that the version of the module being used is
  53 greater than or equal to the required version.
  54
  55 The Exporter module supplies a default require_version method which
  56 checks the value of $VERSION in the exporting module.
  57
  58 =cut
  59
  60 require 5.001;
  61
  62 $ExportLevel = 0;
  63 $Verbose = 0;
  64
  65 require Carp;
  66
  67 sub export {
  68
  69     # First make import warnings look like they're coming from the "use".
  70     local $SIG{__WARN__} = sub {
  71         my $text = shift;
  72         $text =~ s/ at \S*Exporter.pm line \d+.\n//;
  73         local $Carp::CarpLevel = 1;     # ignore package calling us too.
  74         Carp::carp($text);
  75     };
  76     local $SIG{__DIE__} = sub {
  77         Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
  78             if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
  79     };
  80
  81     my $pkg = shift;
  82     my $callpkg = shift;
  83     my @imports = @_;
  84     my($type, $sym);
  85     *exports = \@{"${pkg}::EXPORT"};
  86     if (@imports) {
  87         my $oops;
  88         *exports = \%{"${pkg}::EXPORT"};
  89         if (!%exports) {
  90             grep(s/^&//, @exports);
  91             @exports{@exports} = (1) x  @exports;
  92             foreach $extra (@{"${pkg}::EXPORT_OK"}) {
  93                 $exports{$extra} = 1;
  94             }
  95         }
  96
  97         if ($imports[0] =~ m#^[/!:]#){
  98             my(@allexports) = keys %exports;
  99             my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
 100             my $tagdata;
 101             my %imports;
 102             # negated first item implies starting with default set:
 103             unshift(@imports, ':DEFAULT') if $imports[0] =~ m/^!/;
 104             foreach (@imports){
 105                 my(@names);
 106                 my($mode,$spec) = m/^(!)?(.*)/;
 107                 $mode = '+' unless defined $mode;
 108
 109                 @names = ($spec); # default, maybe overridden below
 110
 111                 if ($spec =~ m:^/(.*)/$:){
 112                     my $patn = $1;
 113                     @names = grep(/$patn/, @allexports); # XXX anchor by default?
 114                 }
 115                 elsif ($spec =~ m#^:(.*)# and $tagsref){
 116                     if ($1 eq 'DEFAULT'){
 117                         @names = @exports;
 118                     }
 119                     elsif ($tagsref and $tagdata = $tagsref->{$1}) {
 120                         @names = @$tagdata;
 121                     }
 122                 }
 123
 124                 warn "Import Mode $mode, Spec $spec, Names @names\n" if $Verbose;
 125                 if ($mode eq '!') {
 126                    map {delete $imports{$_}} @names; # delete @imports{@names} would be handy :-)
 127                 }
 128                 else {
 129                    @imports{@names} = (1) x @names;
 130                 }
 131             }
 132             @imports = keys %imports;
 133         }
 134
 135         foreach $sym (@imports) {
 136             if (!$exports{$sym}) {
 137                 if ($sym =~ m/^\d/) {
 138                     $pkg->require_version($sym);
 139                     # If the version number was the only thing specified
 140                     # then we should act as if nothing was specified:
 141                     if (@imports == 1) {
 142                         @imports = @exports;
 143                         last;
 144                     }
 145                 } elsif ($sym !~ s/^&// || !$exports{$sym}) {
 146                     warn qq["$sym" is not exported by the $pkg module ],
 147                             "at $callfile line $callline\n";
 148                     $oops++;
 149                     next;
 150                 }
 151             }
 152         }
 153         Carp::croak("Can't continue with import errors.\n") if $oops;
 154     }
 155     else {
 156         @imports = @exports;
 157     }
 158     warn "Importing from $pkg into $callpkg: ",
 159                 join(", ",@imports),"\n" if ($Verbose && @imports);
 160     foreach $sym (@imports) {
 161         $type = '&';
 162         $type = $1 if $sym =~ s/^(\W)//;
 163         *{"${callpkg}::$sym"} =
 164             $type eq '&' ? \&{"${pkg}::$sym"} :
 165             $type eq '$' ? \${"${pkg}::$sym"} :
 166             $type eq '@' ? \@{"${pkg}::$sym"} :
 167             $type eq '%' ? \%{"${pkg}::$sym"} :
 168             $type eq '*' ?  *{"${pkg}::$sym"} :
 169                     warn "Can't export symbol: $type$sym\n";
 170     }
 171 };
 172
 173 sub import {
 174     local ($callpkg, $callfile, $callline) = caller($ExportLevel);
 175     my $pkg = shift;
 176     export $pkg, $callpkg, @_;
 177 }
 178
 179 sub export_tags {
 180     my ($pkg) = caller;
 181     *tags = \%{"${pkg}::EXPORT_TAGS"};
 182     push(@{"${pkg}::EXPORT"},
 183         map {$tags{$_} ? @{$tags{$_}} : $_} @_ ? @_ : keys %tags);
 184 }
 185
 186 sub require_version {
 187     my($self, $wanted) = @_;
 188     my $pkg = ref $self || $self;
 189     my $version = ${"${pkg}::VERSION"} || "(undef)";
 190     Carp::croak("$pkg $wanted required--this is only version $version")
 191                 if $version < $wanted;
 192     $version;
 193 }
 194
 195 1;