X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FExporter.pm;h=753ea6aab271185a2bde18adb55d10ba2174d05b;hb=cb1ce60838923277ddef8cb8d26370507470dbd7;hp=abdb1e788b244b1d5cf61487aace9d93f0910c61;hpb=a45ab7f640a570b9f6a73e51a29e6396f5854421;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Exporter.pm b/lib/Exporter.pm index abdb1e7..753ea6a 100644 --- a/lib/Exporter.pm +++ b/lib/Exporter.pm @@ -1,178 +1,65 @@ package Exporter; -require 5.001; - -$ExportLevel = 0; -$Verbose = 0 unless $Verbose; - -require Carp; +require 5.006; + +# Be lean. +#use strict; +#no strict 'refs'; + +our $Debug = 0; +our $ExportLevel = 0; +our $Verbose ||= 0; +our $VERSION = '5.567'; +our (%Cache); +$Carp::Internal{Exporter} = 1; + +sub as_heavy { + require Exporter::Heavy; + # Unfortunately, this does not work if the caller is aliased as *name = \&foo + # Thus the need to create a lot of identical subroutines + my $c = (caller(1))[3]; + $c =~ s/.*:://; + \&{"Exporter::Heavy::heavy_$c"}; +} sub export { - - # First make import warnings look like they're coming from the "use". - local $SIG{__WARN__} = sub { - my $text = shift; - $text =~ s/ at \S*Exporter.pm line \d+.*\n//; - local $Carp::CarpLevel = 1; # ignore package calling us too. - Carp::carp($text); - }; - local $SIG{__DIE__} = sub { - Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT") - if $_[0] =~ /^Unable to create sub named "(.*?)::"/; - }; - - my($pkg, $callpkg, @imports) = @_; - my($type, $sym, $oops); - *exports = *{"${pkg}::EXPORT"}; - - if (@imports) { - if (!%exports) { - grep(s/^&//, @exports); - @exports{@exports} = (1) x @exports; - my $ok = \@{"${pkg}::EXPORT_OK"}; - if (@$ok) { - grep(s/^&//, @$ok); - @exports{@$ok} = (1) x @$ok; - } - } - - if ($imports[0] =~ m#^[/!:]#){ - my $tagsref = \%{"${pkg}::EXPORT_TAGS"}; - my $tagdata; - my %imports; - my($remove, $spec, @names, @allexports); - # negated first item implies starting with default set: - unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/; - foreach $spec (@imports){ - $remove = $spec =~ s/^!//; - - if ($spec =~ s/^://){ - if ($spec eq 'DEFAULT'){ - @names = @exports; - } - elsif ($tagdata = $tagsref->{$spec}) { - @names = @$tagdata; - } - else { - warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS]; - ++$oops; - next; - } - } - elsif ($spec =~ m:^/(.*)/$:){ - my $patn = $1; - @allexports = keys %exports unless @allexports; # only do keys once - @names = grep(/$patn/, @allexports); # not anchored by default - } - else { - @names = ($spec); # is a normal symbol name - } - - warn "Import ".($remove ? "del":"add").": @names " - if $Verbose; - - if ($remove) { - foreach $sym (@names) { delete $imports{$sym} } - } - else { - @imports{@names} = (1) x @names; - } - } - @imports = keys %imports; - } - - foreach $sym (@imports) { - if (!$exports{$sym}) { - if ($sym =~ m/^\d/) { - $pkg->require_version($sym); - # If the version number was the only thing specified - # then we should act as if nothing was specified: - if (@imports == 1) { - @imports = @exports; - last; - } - # We need a way to emulate 'use Foo ()' but still - # allow an easy version check: "use Foo 1.23, ''"; - if (@imports == 2 and !$imports[1]) { - @imports = (); - last; - } - } elsif ($sym !~ s/^&// || !$exports{$sym}) { - warn qq["$sym" is not exported by the $pkg module]; - $oops++; - } - } - } - Carp::croak("Can't continue after import errors") if $oops; - } - else { - @imports = @exports; - } - - *fail = *{"${pkg}::EXPORT_FAIL"}; - if (@fail) { - if (!%fail) { - # Build cache of symbols. Optimise the lookup by adding - # barewords twice... both with and without a leading &. - # (Technique could be applied to %exports cache at cost of memory) - my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @fail; - warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Verbose; - @fail{@expanded} = (1) x @expanded; - } - my @failed; - foreach $sym (@imports) { push(@failed, $sym) if $fail{$sym} } - if (@failed) { - @failed = $pkg->export_fail(@failed); - foreach $sym (@failed) { - warn qq["$sym" is not implemented by the $pkg module ], - "on this architecture"; - } - Carp::croak("Can't continue after import errors") if @failed; - } - } - - warn "Importing into $callpkg from $pkg: ", - join(", ",sort @imports) if $Verbose; - - foreach $sym (@imports) { - # shortcut for the common case of no type character - (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next) - unless $sym =~ s/^(\W)//; - $type = $1; - *{"${callpkg}::$sym"} = - $type eq '&' ? \&{"${pkg}::$sym"} : - $type eq '$' ? \${"${pkg}::$sym"} : - $type eq '@' ? \@{"${pkg}::$sym"} : - $type eq '%' ? \%{"${pkg}::$sym"} : - $type eq '*' ? *{"${pkg}::$sym"} : - Carp::croak("Can't export symbol: $type$sym"); - } + goto &{as_heavy()}; } sub import { - my $pkg = shift; - my $callpkg = caller($ExportLevel); - export $pkg, $callpkg, @_; + my $pkg = shift; + my $callpkg = caller($ExportLevel); + + # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-( + my($exports, $fail) = (\@{"$pkg\::EXPORT"}, \@{"$pkg\::EXPORT_FAIL"}); + return export $pkg, $callpkg, @_ + if $Verbose or $Debug or @$fail > 1; + my $export_cache = ($Cache{$pkg} ||= {}); + my $args = @_ or @_ = @$exports; + + local $_; + if ($args and not %$export_cache) { + s/^&//, $export_cache->{$_} = 1 + foreach (@$exports, @{"$pkg\::EXPORT_OK"}); + } + my $heavy; + # Try very hard not to use {} and hence have to enter scope on the foreach + # We bomb out of the loop with last as soon as heavy is set. + if ($args or $fail) { + ($heavy = (/\W/ or $args and not exists $export_cache->{$_} + or @$fail and $_ eq $fail->[0])) and last + foreach (@_); + } else { + ($heavy = /\W/) and last + foreach (@_); + } + return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy; + local $SIG{__WARN__} = + sub {require Carp; &Carp::carp}; + # shortcut for the common case of no type character + *{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_; } - -# Utility functions - -sub _push_tags { - my($pkg, $var, $syms) = @_; - my $nontag; - *export_tags = \%{"${pkg}::EXPORT_TAGS"}; - push(@{"${pkg}::$var"}, - map { $export_tags{$_} ? @{$export_tags{$_}} : scalar(++$nontag,$_) } - (@$syms) ? @$syms : keys %export_tags); - # This may change to a die one day - Carp::carp("Some names are not tags") if $nontag and $^W; -} - -sub export_tags { _push_tags((caller)[0], "EXPORT", \@_) } -sub export_ok_tags { _push_tags((caller)[0], "EXPORT_OK", \@_) } - - # Default methods sub export_fail { @@ -180,44 +67,28 @@ sub export_fail { @_; } -sub require_version { - my($self, $wanted) = @_; - my $pkg = ref $self || $self; - my $version = ${"${pkg}::VERSION"}; - if (!$version or $version < $wanted) { - $version ||= "(undef)"; - my $file = $INC{"$pkg.pm"}; - $file &&= " ($file)"; - Carp::croak("$pkg $wanted required--this is only version $version$file") - } - $version; +# Unfortunately, caller(1)[3] "does not work" if the caller is aliased as +# *name = \&foo. Thus the need to create a lot of identical subroutines +# Otherwise we could have aliased them to export(). + +sub export_to_level { + goto &{as_heavy()}; } -1; +sub export_tags { + goto &{as_heavy()}; +} -# A simple self test harness. Change 'require Carp' to 'use Carp ()' for testing. -# package main; eval(join('',)) or die $@ unless caller; -__END__ -package Test; -$INC{'Exporter.pm'} = 1; -@ISA = qw(Exporter); -@EXPORT = qw(A1 A2 A3 A4 A5); -@EXPORT_OK = qw(B1 B2 B3 B4 B5); -%EXPORT_TAGS = (T1=>[qw(A1 A2 B1 B2)], T2=>[qw(A1 A2 B3 B4)], T3=>[qw(X3)]); -@EXPORT_FAIL = qw(B4); -Exporter::export_ok_tags('T3', 'unknown_tag'); -sub export_fail { - map { "Test::$_" } @_ # edit symbols just as an example +sub export_ok_tags { + goto &{as_heavy()}; +} + +sub require_version { + goto &{as_heavy()}; } -package main; -$Exporter::Verbose = 1; -#import Test; -#import Test qw(X3); # export ok via export_ok_tags() -#import Test qw(:T1 !A2 /5/ !/3/ B5); -import Test qw(:T2 !B4); -import Test qw(:T2); # should fail 1; +__END__ =head1 NAME @@ -225,28 +96,25 @@ Exporter - Implements default import method for modules =head1 SYNOPSIS -In module ModuleName.pm: +In module YourModule.pm: - package ModuleName; + package YourModule; require Exporter; @ISA = qw(Exporter); + @EXPORT_OK = qw(munge frobnicate); # symbols to export on request - @EXPORT = qw(...); # symbols to export by default - @EXPORT_OK = qw(...); # symbols to export on request - %EXPORT_TAGS = tag => [...]; # define names for sets of symbols - -In other files which wish to use ModuleName: - - use ModuleName; # import default symbols into my package +In other files which wish to use YourModule: - use ModuleName qw(...); # import listed symbols into my package - - use ModuleName (); # do not import any symbols + use ModuleName qw(frobnicate); # import listed symbols + frobnicate ($left, $right) # calls YourModule::frobnicate =head1 DESCRIPTION -The Exporter module implements a default C method which -many modules choose inherit rather than implement their own. +The Exporter module implements an C method which allows a module +to export functions and variables to its users' namespaces. Many modules +use Exporter rather than implementing their own C method because +Exporter provides a highly flexible interface, with an implementation optimised +for the common case. Perl automatically calls the C method when processing a C statement for a module. Modules and C are documented @@ -254,6 +122,21 @@ in L and L. Understanding the concept of modules and how the C statement operates is important to understanding the Exporter. +=head2 How to Export + +The arrays C<@EXPORT> and C<@EXPORT_OK> in a module hold lists of +symbols that are going to be exported into the users name space by +default, or which they can request to be exported, respectively. The +symbols can represent functions, scalars, arrays, hashes, or typeglobs. +The symbols must be given by full name with the exception that the +ampersand in front of a function is optional, e.g. + + @EXPORT = qw(afunc $scalar @array); # afunc is a function + @EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc + +If you are only exporting function names it is recommended to omit the +ampersand, as the implementation is faster this way. + =head2 Selecting What To Export Do B export method names! @@ -272,17 +155,50 @@ informally indicate that they are 'internal' and not for public use. (It is actually possible to get private functions by saying: my $subref = sub { ... }; - &$subref; + $subref->(@args); # Call it as a function + $obj->$subref(@args); # Use it as a method -But there's no way to call that directly as a method, since a method -must have a name in the symbol table.) +However if you use them for methods it is up to you to figure out +how to make inheritance work.) As a general rule, if the module is trying to be object oriented then export nothing. If it's just a collection of functions then -@EXPORT_OK anything but use @EXPORT with caution. +@EXPORT_OK anything but use @EXPORT with caution. For function and +method names use barewords in preference to names prefixed with +ampersands for the export lists. Other module design guidelines can be found in L. +=head2 How to Import + +In other files which wish to use your module there are three basic ways for +them to load your module and import its symbols: + +=over 4 + +=item C + +This imports all the symbols from ModuleName's @EXPORT into the namespace +of the C statement. + +=item C + +This causes perl to load your module but does not import any symbols. + +=item C + +This imports only the symbols listed by the caller into their namespace. +All listed symbols must be in your @EXPORT or @EXPORT_OK, else an error +occurs. The advanced export features of Exporter are accessed like this, +but with list entries that are syntactically distinct from symbol names. + +=back + +Unless you want to use its advanced features, this is probably all you +need to know to use Exporter. + +=head1 Advanced features + =head2 Specialised Import Lists If the first entry in an import list begins with !, : or / then the @@ -326,6 +242,54 @@ You can say C to see how the specifications are being processed and what is actually being imported into modules. +=head2 Exporting without using Exporter's import method + +Exporter has a special method, 'export_to_level' which is used in situations +where you can't directly call Exporter's import method. The export_to_level +method looks like: + + MyPackage->export_to_level($where_to_export, $package, @what_to_export); + +where $where_to_export is an integer telling how far up the calling stack +to export your symbols, and @what_to_export is an array telling what +symbols *to* export (usually this is @_). The $package argument is +currently unused. + +For example, suppose that you have a module, A, which already has an +import function: + + package A; + + @ISA = qw(Exporter); + @EXPORT_OK = qw ($b); + + sub import + { + $A::b = 1; # not a very useful import method + } + +and you want to Export symbol $A::b back to the module that called +package A. Since Exporter relies on the import method to work, via +inheritance, as it stands Exporter::import() will never get called. +Instead, say the following: + + package A; + @ISA = qw(Exporter); + @EXPORT_OK = qw ($b); + + sub import + { + $A::b = 1; + A->export_to_level(1, @_); + } + +This will export the symbols one level 'above' the current package - ie: to +the program or module that used package A. + +Note: Be careful not to modify '@_' at all before you call export_to_level +- or people using your package will get very unexplained results! + + =head2 Module Version Checking The Exporter module will convert an attempt to import a number from a @@ -350,7 +314,7 @@ or constants that may not exist on some systems. The names of any symbols that cannot be exported should be listed in the C<@EXPORT_FAIL> array. -If a module attempts to import any of these symbols the Exporter will +If a module attempts to import any of these symbols the Exporter will give the module an opportunity to handle the situation before generating an error. The Exporter will call an export_fail method with a list of the failed symbols: @@ -385,4 +349,69 @@ unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags names being silently added to @EXPORT or @EXPORT_OK. Future versions may make this a fatal error. +=head2 Generating combined tags + +If several symbol categories exist in %EXPORT_TAGS, it's usually +useful to create the utility ":all" to simplify "use" statements. + +The simplest way to do this is: + + %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]); + + # add all the other ":class" tags to the ":all" class, + # deleting duplicates + { + my %seen; + + push @{$EXPORT_TAGS{all}}, + grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS; + } + +CGI.pm creates an ":all" tag which contains some (but not really +all) of its categories. That could be done with one small +change: + + # add some of the other ":class" tags to the ":all" class, + # deleting duplicates + { + my %seen; + + push @{$EXPORT_TAGS{all}}, + grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} + foreach qw/html2 html3 netscape form cgi internal/; + } + +Note that the tag names in %EXPORT_TAGS don't have the leading ':'. + +=head2 Ced Constants + +Many modules make use of Cing for constant subroutines to +avoid having to compile and waste memory on rarely used values (see +L for details on constant subroutines). Calls to such +constant subroutines are not optimized away at compile time because +they can't be checked at compile time for constancy. + +Even if a prototype is available at compile time, the body of the +subroutine is not (it hasn't been Ced yet). perl needs to +examine both the C<()> prototype and the body of a subroutine at +compile time to detect that it can safely replace calls to that +subroutine with the constant value. + +A workaround for this is to call the constants once in a C block: + + package My ; + + use Socket ; + + foo( SO_LINGER ); ## SO_LINGER NOT optimized away; called at runtime + BEGIN { SO_LINGER } + foo( SO_LINGER ); ## SO_LINGER optimized away at compile time. + +This forces the C for C to take place before +SO_LINGER is encountered later in C package. + +If you are writing a package that Cs, consider forcing +an C for any constants explicitly imported by other packages +or which are usually used when your package is Cd. + =cut