This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl5.001 patch.1f
[perl5.git] / lib / Exporter.pm
CommitLineData
8990e307
LW
1package Exporter;
2
748a9306
LW
3=head1 Comments
4
5If the first entry in an import list begins with /, ! or : then
6treat the list as a series of specifications which either add to
7or delete from the list of names to import. They are processed
8left to right. Specifications are in the form:
9
10 [!]/pattern/ All names in @EXPORT and @EXPORT_OK which match
11 [!]name This name only
12 [!]:tag All names in $EXPORT_TAGS{":tag"}
13 [!]:DEFAULT All names in @EXPORT
14
15e.g., Foo.pm defines:
16
17 @EXPORT = qw(A1 A2 A3 A4 A5);
18 @EXPORT_OK = qw(B1 B2 B3 B4 B5);
19 %EXPORT_TAGS = (':T1' => [qw(A1 A2 B1 B2)], ':T2' => [qw(A1 A2 B3 B4)]);
20
21 Note that you cannot use tags in @EXPORT or @EXPORT_OK.
22 Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
23
24Application says:
25
26 use Module qw(:T2 !B3 A3);
27 use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
28 use POSIX qw(/^S_/ acos asin atan /^E/ !/^EXIT/);
29
30=cut
31
32require 5.001;
8990e307 33
a0d0e21e 34$ExportLevel = 0;
748a9306
LW
35$Verbose = 0;
36
37require Carp;
a0d0e21e
LW
38
39sub export {
748a9306
LW
40
41 # First make import warnings look like they're coming from the "use".
42 local $SIG{__WARN__} = sub {
43 my $text = shift;
44 $text =~ s/ at \S*Exporter.pm line \d+.\n//;
45 local $Carp::CarpLevel = 1; # ignore package calling us too.
46 Carp::carp($text);
47 };
48
49 my $pkg = shift;
50 my $callpkg = shift;
8990e307 51 my @imports = @_;
748a9306
LW
52 my($type, $sym);
53 *exports = \@{"${pkg}::EXPORT"};
8990e307
LW
54 if (@imports) {
55 my $oops;
748a9306 56 *exports = \%{"${pkg}::EXPORT"};
8990e307
LW
57 if (!%exports) {
58 grep(s/^&//, @exports);
59 @exports{@exports} = (1) x @exports;
748a9306 60 foreach $extra (@{"${pkg}::EXPORT_OK"}) {
a0d0e21e
LW
61 $exports{$extra} = 1;
62 }
8990e307 63 }
748a9306
LW
64
65 if ($imports[0] =~ m#^[/!:]#){
66 my(@allexports) = keys %exports;
67 my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
68 my $tagdata;
69 my %imports;
70 # negated first item implies starting with default set:
71 unshift(@imports, ':DEFAULT') if $imports[0] =~ m/^!/;
72 foreach (@imports){
73 my(@names);
74 my($mode,$spec) = m/^(!)?(.*)/;
75 $mode = '+' unless defined $mode;
76
77 @names = ($spec); # default, maybe overridden below
78
79 if ($spec =~ m:^/(.*)/$:){
80 my $patn = $1;
81 @names = grep(/$patn/, @allexports); # XXX anchor by default?
82 }
83 elsif ($spec =~ m#^:(.*)# and $tagsref){
84 if ($1 eq 'DEFAULT'){
85 @names = @exports;
86 }
87 elsif ($tagsref and $tagdata = $tagsref->{$1}) {
88 @names = @$tagdata;
89 }
90 }
91
92 warn "Import Mode $mode, Spec $spec, Names @names\n" if $Verbose;
93 if ($mode eq '!') {
94 map {delete $imports{$_}} @names; # delete @imports{@names} would be handy :-)
95 }
96 else {
97 @imports{@names} = (1) x @names;
98 }
99 }
100 @imports = keys %imports;
101 }
102
8990e307
LW
103 foreach $sym (@imports) {
104 if (!$exports{$sym}) {
105 if ($sym !~ s/^&// || !$exports{$sym}) {
748a9306 106 warn qq["$sym" is not exported by the $pkg module ],
8990e307
LW
107 "at $callfile line $callline\n";
108 $oops++;
109 next;
110 }
111 }
112 }
113 die "Can't continue with import errors.\n" if $oops;
114 }
115 else {
116 @imports = @exports;
117 }
748a9306
LW
118 warn "Importing from $pkg into $callpkg: ",
119 join(", ",@imports),"\n" if ($Verbose && @imports);
8990e307
LW
120 foreach $sym (@imports) {
121 $type = '&';
122 $type = $1 if $sym =~ s/^(\W)//;
748a9306
LW
123 *{"${callpkg}::$sym"} =
124 $type eq '&' ? \&{"${pkg}::$sym"} :
125 $type eq '$' ? \${"${pkg}::$sym"} :
126 $type eq '@' ? \@{"${pkg}::$sym"} :
127 $type eq '%' ? \%{"${pkg}::$sym"} :
128 $type eq '*' ? *{"${pkg}::$sym"} :
8990e307
LW
129 warn "Can't export symbol: $type$sym\n";
130 }
131};
132
a0d0e21e 133sub import {
748a9306
LW
134 local ($callpkg, $callfile, $callline) = caller($ExportLevel);
135 my $pkg = shift;
136 export $pkg, $callpkg, @_;
137}
138
139sub export_tags {
140 my ($pkg) = caller;
141 *tags = \%{"${pkg}::EXPORT_TAGS"};
142 push(@{"${pkg}::EXPORT"},
143 map {$tags{$_} ? @{$tags{$_}} : $_} @_ ? @_ : keys %tags);
a0d0e21e
LW
144}
145
8990e307 1461;