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