lib/Exporter.pm

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