lib/Exporter.pm

   1 package Exporter;
   2
   3 require 5.001;
   4
   5 $ExportLevel = 0;
   6 $Verbose = 0 unless $Verbose;
   7
   8 require Carp;
   9
  10 sub export {
  11
  12     # First make import warnings look like they're coming from the "use".
  13     local $SIG{__WARN__} = sub {
  14         my $text = shift;
  15         $text =~ s/ at \S*Exporter.pm line \d+.*\n//;
  16         local $Carp::CarpLevel = 1;     # ignore package calling us too.
  17         Carp::carp($text);
  18     };
  19     local $SIG{__DIE__} = sub {
  20         Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
  21             if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
  22     };
  23
  24     my($pkg, $callpkg, @imports) = @_;
  25     my($type, $sym, $oops);
  26     *exports = *{"${pkg}::EXPORT"};
  27
  28     if (@imports) {
  29         if (!%exports) {
  30             grep(s/^&//, @exports);
  31             @exports{@exports} = (1) x @exports;
  32             my $ok = \@{"${pkg}::EXPORT_OK"};
  33             if (@$ok) {
  34                 grep(s/^&//, @$ok);
  35                 @exports{@$ok} = (1) x @$ok;
  36             }
  37         }
  38
  39         if ($imports[0] =~ m#^[/!:]#){
  40             my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
  41             my $tagdata;
  42             my %imports;
  43             my($remove, $spec, @names, @allexports);
  44             # negated first item implies starting with default set:
  45             unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
  46             foreach $spec (@imports){
  47                 $remove = $spec =~ s/^!//;
  48
  49                 if ($spec =~ s/^://){
  50                     if ($spec eq 'DEFAULT'){
  51                         @names = @exports;
  52                     }
  53                     elsif ($tagdata = $tagsref->{$spec}) {
  54                         @names = @$tagdata;
  55                     }
  56                     else {
  57                         warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
  58                         ++$oops;
  59                         next;
  60                     }
  61                 }
  62                 elsif ($spec =~ m:^/(.*)/$:){
  63                     my $patn = $1;
  64                     @allexports = keys %exports unless @allexports; # only do keys once
  65                     @names = grep(/$patn/, @allexports); # not anchored by default
  66                 }
  67                 else {
  68                     @names = ($spec); # is a normal symbol name
  69                 }
  70
  71                 warn "Import ".($remove ? "del":"add").": @names "
  72                     if $Verbose;
  73
  74                 if ($remove) {
  75                    foreach $sym (@names) { delete $imports{$sym} }
  76                 }
  77                 else {
  78                     @imports{@names} = (1) x @names;
  79                 }
  80             }
  81             @imports = keys %imports;
  82         }
  83
  84         foreach $sym (@imports) {
  85             if (!$exports{$sym}) {
  86                 if ($sym =~ m/^\d/) {
  87                     $pkg->require_version($sym);
  88                     # If the version number was the only thing specified
  89                     # then we should act as if nothing was specified:
  90                     if (@imports == 1) {
  91                         @imports = @exports;
  92                         last;
  93                     }
  94                 } elsif ($sym !~ s/^&// || !$exports{$sym}) {
  95                     warn qq["$sym" is not exported by the $pkg module];
  96                     $oops++;
  97                 }
  98             }
  99         }
 100         Carp::croak("Can't continue after import errors") if $oops;
 101     }
 102     else {
 103         @imports = @exports;
 104     }
 105
 106     *fail = *{"${pkg}::EXPORT_FAIL"};
 107     if (@fail) {
 108         if (!%fail) {
 109             # Build cache of symbols. Optimise the lookup by adding
 110             # barewords twice... both with and without a leading &.
 111             # (Technique could be applied to %exports cache at cost of memory)
 112             my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @fail;
 113             warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Verbose;
 114             @fail{@expanded} = (1) x @expanded;
 115         }
 116         my @failed;
 117         foreach $sym (@imports) { push(@failed, $sym) if $fail{$sym} }
 118         if (@failed) {
 119             @failed = $pkg->export_fail(@failed);
 120             foreach $sym (@failed) {
 121                 warn qq["$sym" is not implemented by the $pkg module ],
 122                         "on this architecture";
 123             }
 124             Carp::croak("Can't continue after import errors") if @failed;
 125         }
 126     }
 127
 128     warn "Importing into $callpkg from $pkg: ",
 129                 join(", ",sort @imports) if $Verbose;
 130
 131     foreach $sym (@imports) {
 132         # shortcut for the common case of no type character
 133         (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
 134             unless $sym =~ s/^(\W)//;
 135         $type = $1;
 136         *{"${callpkg}::$sym"} =
 137             $type eq '&' ? \&{"${pkg}::$sym"} :
 138             $type eq '$' ? \${"${pkg}::$sym"} :
 139             $type eq '@' ? \@{"${pkg}::$sym"} :
 140             $type eq '%' ? \%{"${pkg}::$sym"} :
 141             $type eq '*' ?  *{"${pkg}::$sym"} :
 142                 Carp::croak("Can't export symbol: $type$sym");
 143     }
 144 }
 145
 146 sub import {
 147     my $pkg = shift;
 148     my $callpkg = caller($ExportLevel);
 149     export $pkg, $callpkg, @_;
 150 }
 151
 152
 153 # Utility functions
 154
 155 sub _push_tags {
 156     my($pkg, $var, $syms) = @_;
 157     my $nontag;
 158     *export_tags = \%{"${pkg}::EXPORT_TAGS"};
 159     push(@{"${pkg}::$var"},
 160         map { $export_tags{$_} ? @{$export_tags{$_}} : scalar(++$nontag,$_) }
 161                 (@$syms) ? @$syms : keys %export_tags);
 162     # This may change to a die one day
 163     Carp::carp("Some names are not tags") if $nontag and $^W;
 164 }
 165
 166 sub export_tags    { _push_tags((caller)[0], "EXPORT",    \@_) }
 167 sub export_ok_tags { _push_tags((caller)[0], "EXPORT_OK", \@_) }
 168
 169
 170 # Default methods
 171
 172 sub export_fail {
 173     @_;
 174 }
 175
 176 sub require_version {
 177     my($self, $wanted) = @_;
 178     my $pkg = ref $self || $self;
 179     my $version = ${"${pkg}::VERSION"} || "(undef)";
 180     Carp::croak("$pkg $wanted required--this is only version $version")
 181                 if $version < $wanted;
 182     $version;
 183 }
 184
 185 1;
 186
 187 # A simple self test harness. Change 'require Carp' to 'use Carp ()' for testing.
 188 # package main; eval(join('',<DATA>)) or die $@ unless caller;
 189 __END__
 190 package Test;
 191 $INC{'Exporter.pm'} = 1;
 192 @ISA = qw(Exporter);
 193 @EXPORT      = qw(A1 A2 A3 A4 A5);
 194 @EXPORT_OK   = qw(B1 B2 B3 B4 B5);
 195 %EXPORT_TAGS = (T1=>[qw(A1 A2 B1 B2)], T2=>[qw(A1 A2 B3 B4)], T3=>[qw(X3)]);
 196 @EXPORT_FAIL = qw(B4);
 197 Exporter::export_ok_tags('T3', 'unknown_tag');
 198 sub export_fail {
 199     map { "Test::$_" } @_       # edit symbols just as an example
 200 }
 201
 202 package main;
 203 $Exporter::Verbose = 1;
 204 #import Test;
 205 #import Test qw(X3);            # export ok via export_ok_tags()
 206 #import Test qw(:T1 !A2 /5/ !/3/ B5);
 207 import Test qw(:T2 !B4);
 208 import Test qw(:T2);            # should fail
 209 1;
 210
 211 =head1 NAME
 212
 213 Exporter - Implements default import method for modules
 214
 215 =head1 SYNOPSIS
 216
 217 In module ModuleName.pm:
 218
 219   package ModuleName;
 220   require Exporter;
 221   @ISA = qw(Exporter);
 222
 223   @EXPORT = qw(...);            # symbols to export by default
 224   @EXPORT_OK = qw(...);         # symbols to export on request
 225   %EXPORT_TAGS = tag => [...];  # define names for sets of symbols
 226
 227 In other files which wish to use ModuleName:
 228
 229   use ModuleName;               # import default symbols into my package
 230
 231   use ModuleName qw(...);       # import listed symbols into my package
 232
 233   use ModuleName ();            # do not import any symbols
 234
 235 =head1 DESCRIPTION
 236
 237 The Exporter module implements a default C<import> method which
 238 many modules choose inherit rather than implement their own.
 239
 240 Perl automatically calls the C<import> method when processing a
 241 C<use> statement for a module. Modules and C<use> are documented
 242 in L<perlfunc> and L<perlmod>. Understanding the concept of
 243 modules and how the C<use> statement operates is important to
 244 understanding the Exporter.
 245
 246 =head2 Selecting What To Export
 247
 248 Do B<not> export method names!
 249
 250 Do B<not> export anything else by default without a good reason!
 251
 252 Exports pollute the namespace of the module user.  If you must export
 253 try to use @EXPORT_OK in preference to @EXPORT and avoid short or
 254 common symbol names to reduce the risk of name clashes.
 255
 256 Generally anything not exported is still accessible from outside the
 257 module using the ModuleName::item_name (or $blessed_ref->method)
 258 syntax.  By convention you can use a leading underscore on names to
 259 informally indicate that they are 'internal' and not for public use.
 260
 261 (It is actually possible to get private functions by saying:
 262
 263   my $subref = sub { ... };
 264   &$subref;
 265
 266 But there's no way to call that directly as a method, since a method
 267 must have a name in the symbol table.)
 268
 269 As a general rule, if the module is trying to be object oriented
 270 then export nothing. If it's just a collection of functions then
 271 @EXPORT_OK anything but use @EXPORT with caution.
 272
 273 Other module design guidelines can be found in L<perlmod>.
 274
 275 =head2 Specialised Import Lists
 276
 277 If the first entry in an import list begins with !, : or / then the
 278 list is treated as a series of specifications which either add to or
 279 delete from the list of names to import. They are processed left to
 280 right. Specifications are in the form:
 281
 282     [!]name         This name only
 283     [!]:DEFAULT     All names in @EXPORT
 284     [!]:tag         All names in $EXPORT_TAGS{tag} anonymous list
 285     [!]/pattern/    All names in @EXPORT and @EXPORT_OK which match
 286
 287 A leading ! indicates that matching names should be deleted from the
 288 list of names to import.  If the first specification is a deletion it
 289 is treated as though preceded by :DEFAULT. If you just want to import
 290 extra names in addition to the default set you will still need to
 291 include :DEFAULT explicitly.
 292
 293 e.g., Module.pm defines:
 294
 295     @EXPORT      = qw(A1 A2 A3 A4 A5);
 296     @EXPORT_OK   = qw(B1 B2 B3 B4 B5);
 297     %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
 298
 299     Note that you cannot use tags in @EXPORT or @EXPORT_OK.
 300     Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
 301
 302 An application using Module can say something like:
 303
 304     use Module qw(:DEFAULT :T2 !B3 A3);
 305
 306 Other examples include:
 307
 308     use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
 309     use POSIX  qw(:errno_h :termios_h !TCSADRAIN !/^EXIT/);
 310
 311 Remember that most patterns (using //) will need to be anchored
 312 with a leading ^, e.g., C</^EXIT/> rather than C</EXIT/>.
 313
 314 You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the
 315 specifications are being processed and what is actually being imported
 316 into modules.
 317
 318 =head2 Module Version Checking
 319
 320 The Exporter module will convert an attempt to import a number from a
 321 module into a call to $module_name->require_version($value). This can
 322 be used to validate that the version of the module being used is
 323 greater than or equal to the required version.
 324
 325 The Exporter module supplies a default require_version method which
 326 checks the value of $VERSION in the exporting module.
 327
 328 Since the default require_version method treats the $VERSION number as
 329 a simple numeric value it will regard version 1.10 as lower than
 330 1.9. For this reason it is strongly recommended that you use numbers
 331 with at least two decimal places, e.g., 1.09.
 332
 333 =head2 Managing Unknown Symbols
 334
 335 In some situations you may want to prevent certain symbols from being
 336 exported. Typically this applies to extensions which have functions
 337 or constants that may not exist on some systems.
 338
 339 The names of any symbols that cannot be exported should be listed
 340 in the C<@EXPORT_FAIL> array.
 341
 342 If a module attempts to import any of these symbols the Exporter will
 343 will give the module an opportunity to handle the situation before
 344 generating an error. The Exporter will call an export_fail method
 345 with a list of the failed symbols:
 346
 347   @failed_symbols = $module_name->export_fail(@failed_symbols);
 348
 349 If the export_fail method returns an empty list then no error is
 350 recorded and all the requested symbols are exported. If the returned
 351 list is not empty then an error is generated for each symbol and the
 352 export fails. The Exporter provides a default export_fail method which
 353 simply returns the list unchanged.
 354
 355 Uses for the export_fail method include giving better error messages
 356 for some symbols and performing lazy architectural checks (put more
 357 symbols into @EXPORT_FAIL by default and then take them out if someone
 358 actually tries to use them and an expensive check shows that they are
 359 usable on that platform).
 360
 361 =head2 Tag Handling Utility Functions
 362
 363 Since the symbols listed within %EXPORT_TAGS must also appear in either
 364 @EXPORT or @EXPORT_OK, two utility functions are provided which allow
 365 you to easily add tagged sets of symbols to @EXPORT or @EXPORT_OK:
 366
 367   %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
 368
 369   Exporter::export_tags('foo');     # add aa, bb and cc to @EXPORT
 370   Exporter::export_ok_tags('bar');  # add aa, cc and dd to @EXPORT_OK
 371
 372 Any names which are not tags are added to @EXPORT or @EXPORT_OK
 373 unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags
 374 names being silently added to @EXPORT or @EXPORT_OK. Future versions
 375 may make this a fatal error.
 376
 377 =cut