package Exporter;
-require 5.001;
+require 5.006;
-$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.565';
+$Carp::Internal{Exporter} = 1;
-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;
- }
- } 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);
+
+ # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
+ my($exports, $export_cache, $fail)
+ = (\@{"$pkg\::EXPORT"}, \%{"$pkg\::EXPORT"}, \@{"$pkg\::EXPORT_FAIL"});
+ return export $pkg, $callpkg, @_
+ if $Verbose or $Debug or @$fail > 1;
+ 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 @_;
+}
# Default methods
sub export_fail {
+ my $self = shift;
@_;
}
+
sub require_version {
- my($self, $wanted) = @_;
- my $pkg = ref $self || $self;
- my $version = ${"${pkg}::VERSION"} || "(undef)";
- Carp::croak("$pkg $wanted required--this is only version $version")
- if $version < $wanted;
- $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('',<DATA>)) 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;
+__END__
=head1 NAME
=head1 DESCRIPTION
The Exporter module implements a default C<import> 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<import> method when processing a
C<use> statement for a module. Modules and C<use> are documented
modules and how the C<use> 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<not> export method names!
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-E<gt>method)
syntax. By convention you can use a leading underscore on names to
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
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-E<gt>require_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.
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:
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 C<AUTOLOAD>ed Constants
+
+Many modules make use of C<AUTOLOAD>ing for constant subroutines to
+avoid having to compile and waste memory on rarely used values (see
+L<perlsub> 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 C<AUTOLOAD>ed 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<BEGIN> 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<AUTOLOAD> for C<SO_LINGER> to take place before
+SO_LINGER is encountered later in C<My> package.
+
+If you are writing a package that C<AUTOLOAD>s, consider forcing
+an C<AUTOLOAD> for any constants explicitly imported by other packages
+or which are usually used when your package is C<use>d.
+
=cut