This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make Exporter::Heavy correctly not warn when exporting a symbol only
[perl5.git] / lib / Exporter / Heavy.pm
1 package Exporter::Heavy;
2
3 use strict;
4 no strict 'refs';
5
6 # On one line so MakeMaker will see it.
7 require Exporter;  our $VERSION = $Exporter::VERSION;
8 # Carp does this now for us, so we can finally live w/o Carp
9 #$Carp::Internal{"Exporter::Heavy"} = 1;
10
11 =head1 NAME
12
13 Exporter::Heavy - Exporter guts
14
15 =head1 SYNOPSIS
16
17 (internal use only)
18
19 =head1 DESCRIPTION
20
21 No user-serviceable parts inside.
22
23 =cut
24
25 #
26 # We go to a lot of trouble not to 'require Carp' at file scope,
27 #  because Carp requires Exporter, and something has to give.
28 #
29
30 sub _rebuild_cache {
31     my ($pkg, $exports, $cache) = @_;
32     s/^&// foreach @$exports;
33     @{$cache}{@$exports} = (1) x @$exports;
34     my $ok = \@{"${pkg}::EXPORT_OK"};
35     if (@$ok) {
36         s/^&// foreach @$ok;
37         @{$cache}{@$ok} = (1) x @$ok;
38     }
39 }
40
41 sub heavy_export {
42
43     # First make import warnings look like they're coming from the "use".
44     local $SIG{__WARN__} = sub {
45         my $text = shift;
46         if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {
47             require Carp;
48             local $Carp::CarpLevel = 1; # ignore package calling us too.
49             Carp::carp($text);
50         }
51         else {
52             warn $text;
53         }
54     };
55     local $SIG{__DIE__} = sub {
56         require Carp;
57         local $Carp::CarpLevel = 1;     # ignore package calling us too.
58         Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
59             if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
60     };
61
62     my($pkg, $callpkg, @imports) = @_;
63     my($type, $sym, $cache_is_current, $oops);
64     my($exports, $export_cache) = (\@{"${pkg}::EXPORT"},
65                                    $Exporter::Cache{$pkg} ||= {});
66
67     if (@imports) {
68         if (!%$export_cache) {
69             _rebuild_cache ($pkg, $exports, $export_cache);
70             $cache_is_current = 1;
71         }
72
73         if (grep m{^[/!:]}, @imports) {
74             my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
75             my $tagdata;
76             my %imports;
77             my($remove, $spec, @names, @allexports);
78             # negated first item implies starting with default set:
79             unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
80             foreach $spec (@imports){
81                 $remove = $spec =~ s/^!//;
82
83                 if ($spec =~ s/^://){
84                     if ($spec eq 'DEFAULT'){
85                         @names = @$exports;
86                     }
87                     elsif ($tagdata = $tagsref->{$spec}) {
88                         @names = @$tagdata;
89                     }
90                     else {
91                         warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
92                         ++$oops;
93                         next;
94                     }
95                 }
96                 elsif ($spec =~ m:^/(.*)/$:){
97                     my $patn = $1;
98                     @allexports = keys %$export_cache unless @allexports; # only do keys once
99                     @names = grep(/$patn/, @allexports); # not anchored by default
100                 }
101                 else {
102                     @names = ($spec); # is a normal symbol name
103                 }
104
105                 warn "Import ".($remove ? "del":"add").": @names "
106                     if $Exporter::Verbose;
107
108                 if ($remove) {
109                    foreach $sym (@names) { delete $imports{$sym} } 
110                 }
111                 else {
112                     @imports{@names} = (1) x @names;
113                 }
114             }
115             @imports = keys %imports;
116         }
117
118         my @carp;
119         foreach $sym (@imports) {
120             if (!$export_cache->{$sym}) {
121                 if ($sym =~ m/^\d/) {
122                     $pkg->VERSION($sym); # inherit from UNIVERSAL
123                     # If the version number was the only thing specified
124                     # then we should act as if nothing was specified:
125                     if (@imports == 1) {
126                         @imports = @$exports;
127                         last;
128                     }
129                     # We need a way to emulate 'use Foo ()' but still
130                     # allow an easy version check: "use Foo 1.23, ''";
131                     if (@imports == 2 and !$imports[1]) {
132                         @imports = ();
133                         last;
134                     }
135                 } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) {
136                     # Last chance - see if they've updated EXPORT_OK since we
137                     # cached it.
138
139                     unless ($cache_is_current) {
140                         %$export_cache = ();
141                         _rebuild_cache ($pkg, $exports, $export_cache);
142                         $cache_is_current = 1;
143                     }
144
145                     if (!$export_cache->{$sym}) {
146                         # accumulate the non-exports
147                         push @carp,
148                           qq["$sym" is not exported by the $pkg module\n];
149                         $oops++;
150                     }
151                 }
152             }
153         }
154         if ($oops) {
155             require Carp;
156             Carp::croak("@{carp}Can't continue after import errors");
157         }
158     }
159     else {
160         @imports = @$exports;
161     }
162
163     my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"},
164                               $Exporter::FailCache{$pkg} ||= {});
165
166     if (@$fail) {
167         if (!%$fail_cache) {
168             # Build cache of symbols. Optimise the lookup by adding
169             # barewords twice... both with and without a leading &.
170             # (Technique could be applied to $export_cache at cost of memory)
171             my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail;
172             warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose;
173             @{$fail_cache}{@expanded} = (1) x @expanded;
174         }
175         my @failed;
176         foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} }
177         if (@failed) {
178             @failed = $pkg->export_fail(@failed);
179             foreach $sym (@failed) {
180                 require Carp;
181                 Carp::carp(qq["$sym" is not implemented by the $pkg module ],
182                         "on this architecture");
183             }
184             if (@failed) {
185                 require Carp;
186                 Carp::croak("Can't continue after import errors");
187             }
188         }
189     }
190
191     warn "Importing into $callpkg from $pkg: ",
192                 join(", ",sort @imports) if $Exporter::Verbose;
193
194     foreach $sym (@imports) {
195         # shortcut for the common case of no type character
196         (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
197             unless $sym =~ s/^(\W)//;
198         $type = $1;
199         no warnings 'once';
200         *{"${callpkg}::$sym"} =
201             $type eq '&' ? \&{"${pkg}::$sym"} :
202             $type eq '$' ? \${"${pkg}::$sym"} :
203             $type eq '@' ? \@{"${pkg}::$sym"} :
204             $type eq '%' ? \%{"${pkg}::$sym"} :
205             $type eq '*' ?  *{"${pkg}::$sym"} :
206             do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
207     }
208 }
209
210 sub heavy_export_to_level
211 {
212       my $pkg = shift;
213       my $level = shift;
214       (undef) = shift;                  # XXX redundant arg
215       my $callpkg = caller($level);
216       $pkg->export($callpkg, @_);
217 }
218
219 # Utility functions
220
221 sub _push_tags {
222     my($pkg, $var, $syms) = @_;
223     my @nontag = ();
224     my $export_tags = \%{"${pkg}::EXPORT_TAGS"};
225     push(@{"${pkg}::$var"},
226         map { $export_tags->{$_} ? @{$export_tags->{$_}} 
227                                  : scalar(push(@nontag,$_),$_) }
228                 (@$syms) ? @$syms : keys %$export_tags);
229     if (@nontag and $^W) {
230         # This may change to a die one day
231         require Carp;
232         Carp::carp(join(", ", @nontag)." are not tags of $pkg");
233     }
234 }
235
236 sub heavy_require_version {
237     my($self, $wanted) = @_;
238     my $pkg = ref $self || $self;
239     return ${pkg}->VERSION($wanted);
240 }
241
242 sub heavy_export_tags {
243   _push_tags((caller)[0], "EXPORT",    \@_);
244 }
245
246 sub heavy_export_ok_tags {
247   _push_tags((caller)[0], "EXPORT_OK", \@_);
248 }
249
250 1;