This is my patch patch.1l for perl5.001.

[p5sagit/p5-mst-13.2.git] / lib / Exporter.pm

diff --git a/lib/Exporter.pm b/lib/Exporter.pm
index dce6909..ca1ff35 100644 (file)
--- a/lib/Exporter.pm
+++ b/lib/Exporter.pm
@@ -1,57 +1,155 @@
 package Exporter;
 
-require 5.000;
+=head1 Comments
+
+If the first entry in an import list begins with !, : or / then the
+list is treated as a series of specifications which either add to or
+delete from the list of names to import. They are processed left to
+right. Specifications are in the form:
+
+    [!]name         This name only
+    [!]:DEFAULT     All names in @EXPORT
+    [!]:tag         All names in $EXPORT_TAGS{tag} anonymous list
+    [!]/pattern/    All names in @EXPORT and @EXPORT_OK which match
+
+A leading ! indicates that matching names should be deleted from the
+list of names to import.  If the first specification is a deletion it
+is treated as though preceded by :DEFAULT. If you just want to import
+extra names in addition to the default set you will still need to
+include :DEFAULT explicitly.
+
+e.g., Module.pm defines:
+
+    @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)]);
+
+    Note that you cannot use tags in @EXPORT or @EXPORT_OK.
+    Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
+
+Application says:
+
+    use Module qw(:DEFAULT :T2 !B3 A3);
+    use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
+    use POSIX  qw(/^S_/ acos asin atan /^E/ !/^EXIT/);
+
+You can set C<$Exporter::Verbose=1;> to see how the specifications are
+being processed and what is actually being imported into modules.
+
+=cut
+
+require 5.001;
 
 $ExportLevel = 0;
+$Verbose = 0;
+
+require Carp;
 
 sub export {
-    my $pack = shift;
-    my $callpack = shift;
+
+    # 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);
+    };
+
+    my $pkg = shift;
+    my $callpkg = shift;
     my @imports = @_;
-    *exports = \@{"${pack}::EXPORT"};
+    my($type, $sym);
+    *exports = \@{"${pkg}::EXPORT"};
     if (@imports) {
        my $oops;
-       my $type;
-       *exports = \%{"${pack}::EXPORT"};
+       *exports = \%{"${pkg}::EXPORT"};
        if (!%exports) {
            grep(s/^&//, @exports);
            @exports{@exports} = (1) x  @exports;
-           foreach $extra (@{"${pack}::EXPORT_OK"}) {
+           foreach $extra (@{"${pkg}::EXPORT_OK"}) {
                $exports{$extra} = 1;
            }
        }
+
+       if ($imports[0] =~ m#^[/!:]#){
+           my(@allexports) = keys %exports;
+           my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
+           my $tagdata;
+           my %imports;
+           # negated first item implies starting with default set:
+           unshift(@imports, ':DEFAULT') if $imports[0] =~ m/^!/;
+           foreach (@imports){
+               my(@names);
+               my($mode,$spec) = m/^(!)?(.*)/;
+               $mode = '+' unless defined $mode;
+
+               @names = ($spec); # default, maybe overridden below
+
+               if ($spec =~ m:^/(.*)/$:){
+                   my $patn = $1;
+                   @names = grep(/$patn/, @allexports); # XXX anchor by default?
+               }
+               elsif ($spec =~ m#^:(.*)# and $tagsref){
+                   if ($1 eq 'DEFAULT'){
+                       @names = @exports;
+                   }
+                   elsif ($tagsref and $tagdata = $tagsref->{$1}) {
+                       @names = @$tagdata;
+                   }
+               }
+
+               warn "Import Mode $mode, Spec $spec, Names @names\n" if $Verbose;
+               if ($mode eq '!') {
+                  map {delete $imports{$_}} @names; # delete @imports{@names} would be handy :-)
+               }
+               else {
+                  @imports{@names} = (1) x @names;
+               }
+           }
+           @imports = keys %imports;
+       }
+
        foreach $sym (@imports) {
            if (!$exports{$sym}) {
                if ($sym !~ s/^&// || !$exports{$sym}) {
-                   warn qq["$sym" is not exported by the $pack module ],
+                   warn qq["$sym" is not exported by the $pkg module ],
                            "at $callfile line $callline\n";
                    $oops++;
                    next;
                }
            }
        }
-       die "Can't continue with import errors.\n" if $oops;
+       Carp::croak("Can't continue with import errors.\n") if $oops;
     }
     else {
        @imports = @exports;
     }
+    warn "Importing from $pkg into $callpkg: ",
+               join(", ",@imports),"\n" if ($Verbose && @imports);
     foreach $sym (@imports) {
        $type = '&';
        $type = $1 if $sym =~ s/^(\W)//;
-       *{"${callpack}::$sym"} =
-           $type eq '&' ? \&{"${pack}::$sym"} :
-           $type eq '$' ? \${"${pack}::$sym"} :
-           $type eq '@' ? \@{"${pack}::$sym"} :
-           $type eq '%' ? \%{"${pack}::$sym"} :
-           $type eq '*' ?  *{"${pack}::$sym"} :
+       *{"${callpkg}::$sym"} =
+           $type eq '&' ? \&{"${pkg}::$sym"} :
+           $type eq '$' ? \${"${pkg}::$sym"} :
+           $type eq '@' ? \@{"${pkg}::$sym"} :
+           $type eq '%' ? \%{"${pkg}::$sym"} :
+           $type eq '*' ?  *{"${pkg}::$sym"} :
                    warn "Can't export symbol: $type$sym\n";
     }
 };
 
 sub import {
-    local ($callpack, $callfile, $callline) = caller($ExportLevel);
-    my $pack = shift;
-    export $pack, $callpack, @_;
+    local ($callpkg, $callfile, $callline) = caller($ExportLevel);
+    my $pkg = shift;
+    export $pkg, $callpkg, @_;
+}
+
+sub export_tags {
+    my ($pkg) = caller;
+    *tags = \%{"${pkg}::EXPORT_TAGS"};
+    push(@{"${pkg}::EXPORT"},
+       map {$tags{$_} ? @{$tags{$_}} : $_} @_ ? @_ : keys %tags);
 }
 
 1;