1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
package Exporter;
=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 {
# 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 = @_;
my($type, $sym);
*exports = \@{"${pkg}::EXPORT"};
if (@imports) {
my $oops;
*exports = \%{"${pkg}::EXPORT"};
if (!%exports) {
grep(s/^&//, @exports);
@exports{@exports} = (1) x @exports;
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 $pkg module ],
"at $callfile line $callline\n";
$oops++;
next;
}
}
}
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)//;
*{"${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 ($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;
|
