X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FExporter.pm;h=ad6cdef87e955e80f6bef0f2bc797bc8b706c023;hb=600d99fa249bb9ea83f068d4a70954217a9361a3;hp=e3744145056e24a09241e61e32e791467ed3370d;hpb=3221d3b03bb599fb4e56ab951ff19a0d00442685;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Exporter.pm b/lib/Exporter.pm index e374414..ad6cdef 100644 --- a/lib/Exporter.pm +++ b/lib/Exporter.pm @@ -2,222 +2,85 @@ package Exporter; require 5.001; -$ExportLevel = 0; -$Verbose = 0 unless $Verbose; +use strict; +no strict 'refs'; -require Carp; +our $Debug = 0; +our $ExportLevel = 0; +our $Verbose ||= 0; +our $VERSION = '5.562'; -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"); - } +sub export_to_level { + require Exporter::Heavy; + goto &Exporter::Heavy::heavy_export_to_level; } -sub import { - my $pkg = shift; - my $callpkg = caller($ExportLevel); - export $pkg, $callpkg, @_; +sub export { + require Exporter::Heavy; + goto &Exporter::Heavy::heavy_export; } +sub export_tags { + require Exporter::Heavy; + Exporter::Heavy::_push_tags((caller)[0], "EXPORT", \@_); +} -# 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_ok_tags { + require Exporter::Heavy; + Exporter::Heavy::_push_tags((caller)[0], "EXPORT_OK", \@_); } -sub export_tags { _push_tags((caller)[0], "EXPORT", \@_) } -sub export_ok_tags { _push_tags((caller)[0], "EXPORT_OK", \@_) } +sub import { + my $pkg = shift; + my $callpkg = caller($ExportLevel); + + my($exports, $export_cache) = (\@{"$pkg\::EXPORT"}, + \%{"$pkg\::EXPORT"}); + # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-( + my($fail) = \@{"$pkg\::EXPORT_FAIL"}; + return export $pkg, $callpkg, @_ + if $Verbose or $Debug or @$fail > 1; + my $args = @_ or @_ = @$exports; + + if ($args and not %$export_cache) { + foreach my $sym (@$exports, @{"$pkg\::EXPORT_OK"}) { + $sym =~ s/^&//; + $export_cache->{$sym} = 1; + } + } + if ($Verbose or $Debug + or grep {/\W/ or $args and not exists $export_cache->{$_} + or @$fail and $_ eq $fail->[0] + or (@{"$pkg\::EXPORT_OK"} + and $_ eq ${"$pkg\::EXPORT_OK"}[0])} @_) { + return export $pkg, $callpkg, ($args ? @_ : ()); + } + local $SIG{__WARN__} = + sub {require Carp; local $Carp::CarpLevel = 1; &Carp::carp}; + foreach my $sym (@_) { + # shortcut for the common case of no type character + *{"$callpkg\::$sym"} = \&{"$pkg\::$sym"}; + } +} # Default methods sub export_fail { + my $self = shift; @_; } + 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; + require Exporter::Heavy; + goto &Exporter::Heavy::require_version; } -1; - -# 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 -} -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; + =head1 NAME Exporter - Implements default import method for modules @@ -245,7 +108,7 @@ In other files which wish to use ModuleName: =head1 DESCRIPTION The Exporter module implements a default C method which -many modules choose inherit rather than implement their own. +many modules choose to inherit rather than implement their own. Perl automatically calls the C method when processing a C statement for a module. Modules and C are documented @@ -253,6 +116,18 @@ 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 + =head2 Selecting What To Export Do B export method names! @@ -264,7 +139,7 @@ try to use @EXPORT_OK in preference to @EXPORT and avoid short or common symbol names to reduce the risk of name clashes. Generally anything not exported is still accessible from outside the -module using the ModuleName::item_name (or $blessed_ref->method) +module using the ModuleName::item_name (or $blessed_ref-Emethod) syntax. By convention you can use a leading underscore on names to informally indicate that they are 'internal' and not for public use. @@ -325,10 +200,58 @@ You can say C to see how the specifications are being processed and what is actually being imported into modules. +=head2 Exporting without using Export's import method + +Exporter has a special method, 'export_to_level' which is used in situations +where you can't directly call Export'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 -module into a call to $module_name->require_version($value). This can +module into a call to $module_name-Erequire_version($value). This can be used to validate that the version of the module being used is greater than or equal to the required version. @@ -349,7 +272,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: