X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FExporter.pm;h=585109e7d03c93dc65272ba5034076e21faef5c2;hb=341bd822d2aa170d6da924b2ac1ec314d007122b;hp=abdb1e788b244b1d5cf61487aace9d93f0910c61;hpb=a45ab7f640a570b9f6a73e51a29e6396f5854421;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Exporter.pm b/lib/Exporter.pm index abdb1e7..585109e 100644 --- a/lib/Exporter.pm +++ b/lib/Exporter.pm @@ -3,194 +3,59 @@ package Exporter; require 5.001; $ExportLevel = 0; -$Verbose = 0 unless $Verbose; +$Verbose ||= 0; +$VERSION = '5.562'; -require Carp; - -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 &heavy_export_to_level; } -sub import { - my $pkg = shift; - my $callpkg = caller($ExportLevel); - export $pkg, $callpkg, @_; +sub export { + require Exporter::Heavy; + goto &heavy_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_tags { + require Exporter::Heavy; + _push_tags((caller)[0], "EXPORT", \@_); } -sub export_tags { _push_tags((caller)[0], "EXPORT", \@_) } -sub export_ok_tags { _push_tags((caller)[0], "EXPORT_OK", \@_) } - - -# Default methods - -sub export_fail { - my $self = shift; - @_; +sub export_ok_tags { + require Exporter::Heavy; + _push_tags((caller)[0], "EXPORT_OK", \@_); } -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") +sub import { + my $pkg = shift; + my $callpkg = caller($ExportLevel); + *exports = *{"$pkg\::EXPORT"}; + # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-( + *fail = *{"$pkg\::EXPORT_FAIL"}; + return export $pkg, $callpkg, @_ + if $Verbose or $Debug or @fail > 1; + my $args = @_ or @_ = @exports; + + if ($args and not %exports) { + foreach my $sym (@exports, @{"$pkg\::EXPORT_OK"}) { + $sym =~ s/^&//; + $exports{$sym} = 1; } - $version; + } + if ($Verbose or $Debug + or grep {/\W/ or $args and not exists $exports{$_} + 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; goto &Carp::carp}; + local $SIG{__WARN__} = + sub {require Carp; local $Carp::CarpLevel = 1; &Carp::carp}; + foreach $sym (@_) { + # shortcut for the common case of no type character + *{"$callpkg\::$sym"} = \&{"$pkg\::$sym"}; + } } 1; @@ -246,7 +111,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 @@ -254,6 +119,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! @@ -326,6 +203,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 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 @@ -350,7 +275,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: