File Coverage

blib/lib/Exporter/Extensible.pm
Criterion Covered Total %
statement 356 398 89.4
branch 189 294 64.2
condition 111 217 51.1
subroutine 47 53 88.6
pod 9 26 34.6
total 712 988 72.0


line stmt bran cond sub pod time code
1             package Exporter::Extensible;
2 12     12   10049 use v5;
  12         76  
3 12     12   63 use strict; no strict 'refs';
  12     12   24  
  12         267  
  12         53  
  12         22  
  12         346  
4 12     12   65 use warnings; no warnings 'redefine';
  12     12   24  
  12         357  
  12         61  
  12         31  
  12         6497  
5             require Exporter::Extensible::Compat if "$]" < "5.012";
6             require mro;
7              
8             # ABSTRACT: Create easy-to-extend modules which export symbols
9             our $VERSION = '0.11'; # VERSION
10              
11             our %EXPORT_FAST_SUB_CACHE;
12             our %EXPORT_PKG_CACHE;
13             our %EXPORT_TAGS_PKG_CACHE;
14              
15             our %EXPORT= (
16             -exporter_setup => [ 'exporter_setup', 1 ],
17             );
18              
19             our %sigil_to_reftype= (
20             '$' => 'SCALAR',
21             '@' => 'ARRAY',
22             '%' => 'HASH',
23             '*' => 'GLOB',
24             '&' => 'CODE',
25             '' => 'CODE',
26             '-' => 'CODE',
27             );
28             our %reftype_to_sigil= (
29             'SCALAR' => '$',
30             'ARRAY' => '@',
31             'HASH' => '%',
32             'GLOB' => '*',
33             'CODE' => '',
34             );
35             our %sigil_to_generator_prefix= (
36             '$' => [ '_generateSCALAR_', '_generateScalar_' ],
37             '@' => [ '_generateARRAY_', '_generateArray_' ],
38             '%' => [ '_generateHASH_', '_generateHash_' ],
39             '*' => [ '_generateGLOB_', '_generateGlob_' ],
40             '&' => [ '_generate_', '_generateCODE_', '_generateCode' ],
41             );
42             $sigil_to_generator_prefix{''}= $sigil_to_generator_prefix{'&'};
43             our %ord_is_sigil= ( ord '$', 1, ord '@', 1, ord '%', 1, ord '*', 1, ord '&', 1, ord '-', 1, ord ':', 1 );
44             our %ord_is_directive= ( ord '-', 1, ord ':', 1 );
45              
46             my ($carp, $croak, $weaken, $colon, $hyphen);
47             $carp= sub { require Carp; $carp= \&Carp::carp; goto $carp; };
48             $croak= sub { require Carp; $croak= \&Carp::croak; goto $croak; };
49             $weaken= sub { require Scalar::Util; $weaken= \&Scalar::Util::weaken; goto $weaken; };
50             $colon= ord ':';
51             $hyphen= ord '-';
52              
53             sub import {
54 106     106   43794 my $self= shift;
55             # Can be called as class method or instance method
56 106 100       486 $self= bless { into => scalar caller }, $self
57             unless ref $self;
58             # Optional config hash might be given as first argument
59 106 100       411 $self->exporter_apply_global_config(shift)
60             if ref $_[0] eq 'HASH';
61 106         190 my $class= ref $self;
62 106 100       358 my @todo= @_? @_ : @{ $self->exporter_get_tag('default') || [] };
  14 100       38  
63 106 100       433 return 1 unless @todo;
64             # If only installing subs without generators or unusual options, use a more direct code path.
65             # This only takes effect the second time a symbol is requested, since the cache is not pre-populated.
66             # (abuse a while loop as a if/goto construct)
67 94   100     511 fast: while (!$self->{_complex} && !grep ref, @todo) {
68 69   100     193 my $fastsub= $EXPORT_FAST_SUB_CACHE{$class} || last; # can't optimize if no cache is built
69 15         40 my $prefix= $self->{into}.'::'; # {into} can be a hashref, but not when {_complex} is false
70 15   100     47 my $replace= $self->{replace} || 'carp';
71 15 100       44 if ($replace eq 'carp') {
    100          
72             # Use perl's own warning system to detect attempts to overwrite the GLOB. Only warn if the
73             # new reference isn't the same as existing.
74 12     12   109 use warnings 'redefine';
  12         27  
  12         77099  
75 11 0   0   92 local $SIG{__WARN__}= sub { *{$prefix.$_}{CODE} == $fastsub->{$_} or $carp->($_[0]) };
  0         0  
  0         0  
76 10         54 ord == $colon || (*{$prefix.$_}= ($fastsub->{$_} || last fast))
77 11   100     90 for @todo;
      66        
78             }
79             elsif ($replace eq 1) {
80 4         23 ord == $colon || (*{$prefix.$_}= ($fastsub->{$_} || last fast))
81 2   50     8 for @todo;
      66        
82             }
83 2         4 else { last } # replace==croak and replace==skip require more logic
84             # Now apply any tags that were requested. Each will get its own determination of whether it
85             # can use the 'fast' method.
86 3         10 ord == $colon && $self->import(@{$self->exporter_get_tag(substr $_, 1)})
87 7   66     59 for @todo;
88 7         47 return 1;
89             }
90 87         250 my $install= $self->_exporter_build_install_set(\@todo);
91              
92             # Install might actually be uninstall. It also might be overridden by the user.
93             # The exporter_combine_config sets this up so we don't need to think about details.
94 87   33     348 my $method= $self->{installer} || ($self->{no}? 'exporter_uninstall' : 'exporter_install');
95             # Convert
96             # { foo => { SCALAR => \$foo, HASH => \%foo } }
97             # into
98             # [ foo => \$foo, foo => \%foo ]
99 87         258 my @flat_install= %$install;
100 87         224 for my $i (reverse 1..$#flat_install) {
101 103 100       237 if (ref $flat_install[$i] eq 'HASH') {
102 9         18 splice @flat_install, $i-1, 2, map +($flat_install[$i-1] => $_), values %{$flat_install[$i]};
  9         92  
103             }
104             }
105             # Then pass that list to the installer (or uninstaller)
106 87         411 $self->$method(\@flat_install);
107             # If scope requested, create the scope-guard object
108 85 100       212 if (my $scope= $self->{scope}) {
109 1         5 $$scope= bless [ $self, \@flat_install ], 'Exporter::Extensible::UnimportScopeGuard';
110 1         3 $weaken->($self->{scope});
111             }
112             # It's entirely likely that a generator might curry $self inside the sub it generated.
113             # So, we end up with a circular reference if we're holding onto the set of all things we
114             # exported. Clear the set.
115 85         166 %$install= ();
116 85         2928 1;
117             }
118              
119             sub _exporter_build_install_set {
120 88     88   179 my ($self, $todo)= @_;
121 88         170 $self->{todo}= $todo;
122 88   100     313 my $install= $self->{install_set} ||= {};
123 88   100     298 my $inventory= $EXPORT_PKG_CACHE{ref $self} ||= {};
124 88         202 while (@$todo) {
125 140         273 my $symbol= shift @$todo;
126              
127             # If it is a tag, then recursively call import on that list
128 140 100       316 if (ord $symbol == $colon) {
129 13         33 my $name= substr $symbol, 1;
130 13 50       43 my $tag_cache= $self->exporter_get_tag($name)
131             or $croak->("Tag ':$name' is not exported by ".ref($self));
132             # If first element of tag is a hashref, they count as nested global options.
133             # If tag was followed by hashref, those are user-supplied options.
134 13 100 66     57 if (ref $tag_cache->[0] eq 'HASH' || ref $todo->[0] eq 'HASH') {
135 1         3 $tag_cache= [ @$tag_cache ]; # don't destroy cache
136 1         2 my $self2= $self;
137 1 50       3 $self2= $self2->exporter_apply_global_config(shift @$tag_cache)
138             if ref $tag_cache->[0] eq 'HASH';
139 1 50       6 $self2= $self2->exporter_apply_inline_config(shift @$todo)
140             if ref $todo->[0] eq 'HASH';
141 1 50       9 if ($self != $self2) {
142 1         14 $self2->_exporter_build_install_set($tag_cache);
143 1         4 next;
144             }
145             }
146 12         46 unshift @$todo, @$tag_cache;
147 12         38 next;
148             }
149             # Else, it is an option or plain symbol to be exported
150             # Check current package cache first, else do the full lookup.
151 127 100       412 my $ref= (exists $inventory->{$symbol}? $inventory->{$symbol} : $self->exporter_get_inherited($symbol))
    50          
152             or $croak->("'$symbol' is not exported by ".ref($self));
153              
154             # If it starts with '-', it is an option, and might consume additional args
155 127 100       244 if (ord $symbol == $hyphen) {
156             # back-compat for when opt was arrayref
157 40 50       103 if (ref $ref eq 'ARRAY') {
158 40         87 my ($method, $count)= @$ref;
159 40         95 $ref= $self->_exporter_wrap_option_handler($method, $count);
160             }
161 40         150 $self->$ref;
162             }
163             else {
164 87 100       282 my ($sigil, $name)= $ord_is_sigil{ord $symbol}? ( substr($symbol,0,1), substr($symbol,1) ) : ( '', $symbol );
165 87         137 my $self2= $self;
166             # If followed by a hashref, add those options to the current ones.
167 87 100       230 $self2= $self->exporter_apply_inline_config(shift @$todo)
168             if ref $todo->[0] eq 'HASH';
169 87 100       212 if ($self2->{_name_mangle}) {
170 33 100 100     85 next if defined $self2->{not} and $self2->_exporter_is_excluded($symbol);
171 23   66     136 $name= delete $self2->{as} || ($self2->{prefix}||'') . $name . ($self2->{suffix}||'');
172             # If 'as' was the only reason for _name_mangle, then disable it to return to fast-path
173 23 100 100     92 delete $self2->{_name_mangle} unless defined $self2->{prefix} || defined $self2->{suffix} || defined $self2->{not};
      100        
174             }
175             # If $ref is a generator (method name or coderef or coderefref in the case of exported subs) then run it,
176             # unless it was already run for the current symbol exporting to the current dest.
177 77 100 100     320 if (!ref $ref || ref $ref eq ($sigil? 'CODE':'REF')) {
    100          
178 5   33     23 $ref= ($self2->{_generator_cache}{$symbol.";".$name} ||= do {
179             # Run the generator.
180 5 100       10 my $method= ref $ref eq 'REF'? $$ref : $ref;
181 5 100       11 $method= $$method if ref $method eq 'SCALAR'; # back-compat for \\$method_name
182 5         100 $self2->$method($symbol, $self2->{generator_arg});
183             });
184             # Verify generator output matches sigil
185             ref $ref eq $sigil_to_reftype{$sigil} or (ref $ref eq 'REF' && $sigil eq '$')
186             or $croak->("Trying to export '$symbol', but generator returned "
187 5 0 0     825 .ref($ref).' (need '.$sigil_to_reftype{$sigil}.')');
      33        
188             }
189             # Check for collisions. Unlikely scenario in typical usage, but could occur if two
190             # tags include the same symbol, or if user adds a prefix or suffix that collides
191             # with another exported name.
192 77 50       220 if ($install->{$name}) {
    100          
193 0 0       0 if ($install->{$name} != $ref) { # most common case of duplicate export, ignore it.
194 0 0 0     0 if (ref $ref eq 'GLOB' || ref $install->{$name} eq 'GLOB') {
195             # globrefs will never be equal - compare the glob itself.
196 0         0 ref $ref eq 'GLOB' && ref $install->{dest} eq 'GLOB' && *{$install->{$name}} eq *$ref
197             # can't install an entire glob at the same time as a piece of a glob.
198 0 0 0     0 or $croak->("Can't install ".ref($ref)." and ".$install->{dest}." into the same symbol '".$name."'");
      0        
199             }
200             # Upgrade this item to a hashref of reftype if it wasn't already (hashrefs are always stored this way)
201             $install->{$name}= { ref($install->{$name}) => $install->{$name} }
202 0 0       0 unless ref $install->{$name} eq 'HASH';
203             # Assign this new ref into a slot of that hash, unless something different was already there
204 0 0 0     0 ($install->{$name}{ref $ref} ||= $ref) == $ref
205             or $croak->("Trying to import conflicting ".ref($ref)." values for '".$name."'");
206             }
207             }
208             # Only make install->{$name} a hashref if we really have to, for performance.
209             elsif (ref $ref eq 'HASH') {
210 9         39 $install->{$name}{HASH}= $ref;
211             }
212             else {
213 68         220 $install->{$name}= $ref;
214             }
215             }
216             }
217 88         307 return $install;
218             }
219              
220             sub Exporter::Extensible::UnimportScopeGuard::clean {
221 1     1 0 3 my $self= shift;
222 1 50       8 $self->[0]->exporter_uninstall($self->[1]) if $self->[1];
223 1         11 $self->[1]= undef; # Ignore subsequent calls
224             }
225              
226             sub Exporter::Extensible::UnimportScopeGuard::DESTROY {
227 1     1   810 shift->clean;
228             }
229              
230             sub exporter_install {
231 80     80 0 157 my $self= shift;
232 80 50       192 my $into= $self->{into} or $croak->("'into' must be defined before exporter_install");
233 80 100       166 return $self->_exporter_install_to_ref(@_) if ref $into;
234 78   100     231 my $replace= $self->{replace} || 'warn';
235 78         113 my $stash= \%{$into.'::'};
  78         265  
236 78 50 33     397 my $list= @_ == 1 && ref $_[0] eq 'ARRAY'? $_[0] : \@_;
237 78         230 for (my $i= 0; $i < @$list; $i+= 2) {
238 65         145 my ($name, $ref)= @{$list}[$i..1+$i];
  65         148  
239 65         139 my $pkg_dest= $into.'::'.$name;
240             # Each value is either a hashref with keys matching the parts of a typeglob,
241             # or it is a single ref that can be assigned directly to the typeglob.
242 65 100 100     256 if (defined $stash->{$name} and $replace ne 1) {
243             # there is actually no way I know of to test existence of *foo{SCALAR}.
244             # It auto-vivifies when accessed.
245             my $conflict= (ref $ref eq 'GLOB')? $stash->{$name} ne *$ref
246             : (ref $ref eq 'SCALAR')? 0 # TODO: How to test existence of *foo{SCALAR} ? It auto-vivifies
247 19 100 100     127 : (*$pkg_dest{ref $ref} && *$pkg_dest{ref $ref} != $ref);
    50          
248 19 100       57 if ($conflict) {
249 4 100       11 next if $replace eq 'skip';
250 3         7 $name= $reftype_to_sigil{ref $ref} . $name; # include sigil for user's benefit
251 3 100       140 $replace eq 'warn'? $carp->("Overwriting '$name' with $ref from ".ref($self))
252             : $croak->("Refusing to overwrite '$name' with $ref from ".ref($self));
253             }
254             }
255 62         338 *$pkg_dest= $ref;
256             }
257             }
258              
259             sub exporter_uninstall {
260 8     8 0 11 my $self= shift;
261 8 50       33 my $into= $self->{into} or $croak->("'into' must be defined before exporter_uninstall");
262 8 100       36 return $self->_exporter_install_to_ref(@_) if ref $into;
263 7         14 my $stash= \%{$into.'::'};
  7         22  
264 7 50 33     37 my $list= @_ == 1 && ref $_[0] eq 'ARRAY'? $_[0] : \@_;
265 7         21 for (my $i= 0; $i < @$list; $i+= 2) {
266 9         20 my ($name, $ref)= @{$list}[$i..1+$i];
  9         21  
267             # Each value is either a hashref with keys matching the parts of a typeglob,
268             # or it is a single ref that can be assigned directly to the typeglob.
269 9 100       26 if (ref $ref eq 'GLOB') {
270             # If the value we installed is no longer there, do nothing
271 1 50 50     8 next unless *$ref eq ($stash->{$name}||'');
272 1         6 delete $stash->{$name};
273             }
274             else {
275 8         20 my $pkg_dest= $into.'::'.$name;
276             # If the value we installed is no longer there, do nothing
277 8 50 50     11 next unless $ref == (*{$pkg_dest}{ref $ref}||0);
278             # Remove old typeglob, then copy all slots except reftype back to that typeglob name
279 8         38 my $old= delete $stash->{$name};
280 32         149 ($_ ne ref $ref) && *{$old}{$_} && (*$pkg_dest= *{$old}{$_})
  12         76  
281 8   100     51 for qw( SCALAR HASH ARRAY CODE IO );
      100        
282             }
283             }
284             }
285              
286             sub _exporter_install_to_ref {
287 3     3   4 my $self= shift;
288 3         6 my $into= $self->{into};
289 3 50       7 ref $into eq 'HASH' or $croak->("'into' must be a hashref");
290 3   50     11 my $replace= $self->{replace} || 'warn';
291 3 50 33     12 my $list= @_ == 1 && ref $_[0] eq 'ARRAY'? $_[0] : \@_;
292 3         10 for (my $i= 0; $i < @$list; $i+= 2) {
293 6         12 my ($name, $ref)= @{$list}[$i..1+$i];
  6         15  
294 6         16 $name= $reftype_to_sigil{ref $ref} . $name; # include sigil when installing to hashref
295 6 100       13 if ($self->{no}) {
296 1         5 delete $into->{$name};
297             }
298             else {
299 5 50 33     13 if (defined $into->{$name} && $into->{name} != $ref) {
300 0 0       0 $replace eq 'skip' and next;
301 0 0       0 $replace eq 'warn' and $carp->("Overwriting '$name' with $ref from ".ref($self));
302 0 0       0 $replace eq 'die' and $croak->("Refusing to overwrite '$name' with $ref from ".ref($self));
303             }
304 5         37 $into->{$name}= $ref;
305             }
306             }
307             }
308              
309 4 50   4 0 16 sub exporter_config_prefix { $_[0]->_exporter_set_attr(prefix => $_[1]) if @_ > 1; $_[0]{prefix} }
  4         8  
310 3 50   3 0 17 sub exporter_config_suffix { $_[0]->_exporter_set_attr(suffix => $_[1]) if @_ > 1; $_[0]{suffix} }
  3         6  
311 6 50   6 0 37 sub exporter_config_as { $_[0]->_exporter_set_attr(as => $_[1]) if @_ > 1; $_[0]{as} }
  6         10  
312 7 50   7 0 31 sub exporter_config_no { $_[0]->_exporter_set_attr(no => $_[1]) if @_ > 1; $_[0]{no} }
  7         14  
313 50 50   50 0 226 sub exporter_config_into { $_[0]->_exporter_set_attr(into => $_[1]) if @_ > 1; $_[0]{into} }
  50         103  
314 1 50   1 0 4 sub exporter_config_scope { $_[0]->_exporter_set_attr(scope => $_[1]) if @_ > 1; $_[0]{scope}; }
  1         2  
315 5 50   5 0 18 sub exporter_config_not { $_[0]->_exporter_set_attr(not => $_[1]) if @_ > 1; $_[0]{not}; }
  5         9  
316 0 0   0 0 0 sub exporter_config_installer { $_[0]->_exporter_set_attr(installer => $_[1]) if @_ > 1; $_[0]{installer}; }
  0         0  
317              
318             sub _exporter_set_attr {
319 76     76   154 my ($self, $name, $val)= @_;
320 76         163 $self->{$name}= $val;
321             # After changing config, update the optimization flags.
322             # _name_mangle is set if there is any deviation from normal installation of the symbol name
323             $self->{_name_mangle}= defined $self->{not}
324             || defined $self->{as}
325             || (defined $self->{prefix} && length $self->{prefix})
326 76   100     556 || (defined $self->{suffix} && length $self->{suffix});
327             # _complex is set if the required algorithm is anything more than a simple *{$into.'::'.$name}= $ref
328             # but 'replace' does not trigger _complex currently because I handled that in the fast installer.
329             $self->{_complex}= $self->{no} || $self->{_name_mangle}
330             || defined $self->{scope}
331 76   66     477 || $self->{installer} || ref $self->{into};
332             }
333              
334             our %replace_aliases= (
335             1 => 1,
336             carp => 'carp',
337             warn => 'carp',
338             croak => 'croak',
339             fatal => 'croak',
340             die => 'croak',
341             skip => 'skip',
342             );
343             sub exporter_config_replace {
344 11 50 33 11 0 48 $_[0]{replace}= $replace_aliases{$_[1]} or $croak->("Invalid 'replace' value: '$_[1]'")
345             if @_ > 1;
346 11         55 $_[0]{replace};
347             }
348              
349             sub exporter_apply_global_config {
350 55     55 0 113 my ($self, $conf)= @_;
351 55         178 for my $k (keys %$conf) {
352 76 0 0     432 my $setter= $self->can('exporter_config_'.$k)
      33        
353             or (substr($k,0,1) eq '-' && $self->can('exporter_config_'.substr($k,1)))
354             or $croak->("No such exporter configuration '$k'");
355 76         198 $self->$setter($conf->{$k});
356             }
357 55         108 $self;
358             }
359              
360             sub exporter_apply_inline_config {
361 11     11 0 24 my ($self, $conf)= @_;
362 11         44 my @for_global_config= grep ord == $hyphen, keys %$conf;
363             # In the event that only "-as" was given, we don't actually need to create a new object
364 11 100 100     121 if (@for_global_config == 1 && $for_global_config[0] eq '-as' && keys %$conf == 1) {
      100        
365 5         28 $self->exporter_config_as($conf->{-as});
366 5         15 return $self;
367             }
368             # Else clone and apply temporary settings
369 6         37 my $self2= bless { %$self, parent => $self }, ref $self;
370 6         26 for my $k (@for_global_config) {
371 6 50       49 my $setter= $self2->can('exporter_config_'.substr($k,1))
372             or $croak->("No such exporter configuration '$k'");
373 6         19 $self2->$setter($conf->{$k});
374             }
375             # If any options didn't start with '-', then the config becomes a parameter to the generator.
376             # The generator cache isn't valid for $self2 since the arg changed.
377 6 100       20 if (@for_global_config < scalar keys %$conf) {
378 2         18 $self2->{generator_arg}= $conf;
379 2         5 delete $self2->{_generator_cache};
380             }
381 6         32 $self2;
382             }
383              
384             sub unimport {
385             # If first option is a hashref (global options), merge that with { no => 1 }
386 7 100   7   8618 my %opts= ( (ref $_[1] eq 'HASH'? %{splice(@_,1,1)} : () ), no => 1 );
  2         9  
387             # Use this as the global options
388 7         57 splice @_, 1, 0, \%opts;
389 7         69 goto $_[0]->can('import'); # to preserve caller
390             }
391              
392             sub import_into {
393 39 100   39 1 44575 shift->import({ into => shift, (ref $_[0] eq 'HASH'? %{+shift} : ()) }, @_);
  15         82  
394             }
395              
396             sub exporter_register_symbol {
397 4     4 1 312 my ($class, $export_name, $ref)= @_;
398 4   33     13 $class= ref($class)||$class;
399 4 50 33     24 $ref ||= $class->_exporter_get_ref_to_package_var($export_name)
400             or $croak->("Symbol $export_name not found in package $class");
401 4         5 ${$class.'::EXPORT'}{$export_name}= $ref;
  4         60  
402             }
403              
404             sub exporter_autoload_symbol {
405 0     0 1 0 my ($class, $export_name)= @_;
406 0         0 return;
407             }
408              
409             sub exporter_get_inherited {
410 58     58 0 115 my ($self, $sym)= @_;
411 58   33     136 my $class= ref($self)||$self;
412             # Make the common case fast.
413             return $EXPORT_PKG_CACHE{$class}{$sym} ||=
414 58   33     200 do {
      33        
415             my $x;
416             # quick check of own package first
417             unless ($x= ${$class.'::EXPORT'}{$sym}) {
418             # search package hierarchy
419             ($x= ${$_.'::EXPORT'}{$sym}) && last for @{ mro::get_linear_isa($class) }
420             }
421             # If it is a plain sub, it is elligible for "fast export"
422             $EXPORT_FAST_SUB_CACHE{$class}{$sym}= $x if ref $x eq 'CODE' and !$ord_is_sigil{ord $sym};
423             #print "# ref=".ref($x)." sym=$sym\n";
424             $x;
425             }
426             # Isn't exported, but maybe autoload.
427             || $self->exporter_autoload_symbol($sym);
428             }
429              
430             sub exporter_register_option {
431 5     5 1 24 my ($class, $option_name, $method_name, $arg_count)= @_;
432 5   33     70 $class= ref($class)||$class;
433 5         25 ${$class.'::EXPORT'}{'-'.$option_name}= $class->_exporter_wrap_option_handler($method_name, $arg_count);
  5         45  
434             }
435              
436             sub _exporter_wrap_option_handler {
437 45     45   93 my ($class, $method, $count)= @_;
438 45 100       132 return $method unless $count;
439 39 100       171 if ($count eq '*') {
    100          
440             return sub {
441 4     4   7 my $consumed= $_[0]->$method(@{$_[0]{todo}});
  4         74  
442 4 50       1398 $consumed =~ /^[0-9]+$/ or $croak->("Method $method in ".ref($_[0])." must return a number of arguments consumed");
443 4         9 splice(@{$_[0]{todo}}, 0, $consumed);
  4         31  
444             }
445 5         35 }
446             elsif ($count eq '?') {
447             return sub {
448 3 100   3   9 if (ref $_[0]{todo}[0]) {
449 1         2 my $arg= shift @{$_[0]{todo}};
  1         13  
450 1 50       9 (ref $arg eq 'HASH'? $_[0]->exporter_apply_inline_config($arg) : $_[0])
451             ->$method($arg);
452             } else {
453 2         38 $_[0]->$method();
454             }
455             }
456 4         24 }
457             else {
458             return sub {
459 29     29   51 $_[0]->$method(splice(@{$_[0]{todo}}, 0, $count));
  29         160  
460             }
461 30         155 }
462             }
463              
464             sub exporter_register_generator {
465 11     11 1 68 my ($class, $export_name, $method)= @_;
466 11   33     57 $class= ref($class)||$class;
467 11 50 33     34 !ref $method or ref $method eq 'CODE'
468             or $croak->("Generator method must be method name (scalar) or coderef");
469             # Register tag generators in %EXPORT_TAGS
470 11 50       24 if (ord $export_name == $colon) {
471 0 0 0     0 (${$class.'::EXPORT_TAGS'}{substr($export_name,1)} ||= $method) eq $method
  0         0  
472             or $croak->("Cannot set generator for $export_name when that tag is already populated within this class ($class)");
473             }
474             # Register variable generators (export having a sigil) in %EXPORT
475             # Sub generators (for coderef methods) get an extra layer of ref added
476             else {
477 11 50 33     30 ${$class.'::EXPORT'}{$export_name}= (ref $method && !$ord_is_sigil{ord $export_name})? \$method : $method;
  11         85  
478             }
479             }
480              
481             sub exporter_register_tag_members {
482 8     8 1 21 my ($class, $tag_name)= (shift, shift);
483 8   33     26 $class= ref($class)||$class;
484 8         13 push @{ ${$class.'::EXPORT_TAGS'}{$tag_name} }, @_;
  8         10  
  8         63  
485             }
486              
487             sub _exporter_build_tag_cache {
488 26     26   51 my ($self, $tagname)= @_;
489 26   66     88 my $class= ref($self)||$self;
490             # Collect all members of this tag from any parent class, but stop at the first undef
491 26         47 my ($dynamic, @keep, %seen, $known);
492 26         44 for (@{ mro::get_linear_isa($class) }) {
  26         160  
493             my $add= ${$_.'::EXPORT_TAGS'}{$tagname}
494             # Special case, ':all' is built from all known keys of the %EXPORT var at each inherited package
495             # Also exclude anything exported as part of the Exporter API, but right now that is only
496             # the '-exporter_setup' option.
497             || ($tagname eq 'all' && defined *{$_.'::EXPORT'}{HASH}
498 52 100 100     77 && [ grep !$ord_is_directive{+ord}, keys %{$_.'::EXPORT'} ]
499             )
500             or next;
501 25         82 ++$known;
502 25 100       78 if (ref $add ne 'ARRAY') {
503             # Found a generator (coderef or method name ref). Call it to get the list of tags.
504 1 50       16 $add= ref $add eq 'CODE'? $add
    50          
505             : ref $add eq 'SCALAR'? $$add
506             : $croak->("Tag must expand to an array, code, or a method name ref (not $add)");
507 1         40 $add= $self->$add($self->{generator_arg});
508 1 50       12 ref $add eq 'ARRAY' or $croak->("Tag generator must return an arrayref");
509 1         2 ++$dynamic;
510             }
511             # If first element of the list is undef it means this class wanted to reset the tag.
512             # Since we're iterating *up* the hierarchy, it just means end here.
513 25 50 66     104 my $start= (@$add && !defined $add->[0])? 1 : 0;
514             # symbol might be followed by options, so need to skip over refs, but also need to allow
515             # duplicate symbols if they were followed by a ref.
516             (ref $add->[$_] || !$seen{$add->[$_]}++ || ref $add->[$_+1]) && push @keep, $add->[$_]
517 25   66     240 for $start .. $#$add;
      100        
518 25 50       83 last if $start;
519             }
520 26 100       83 my $ret= $known? \@keep : $self->exporter_autoload_tag($tagname);
521 26 100       168 $EXPORT_TAGS_PKG_CACHE{$class}{$tagname}= $ret unless $dynamic;
522 26         74 return $ret;
523             }
524              
525             sub exporter_get_tag {
526 36     36 0 5755 my ($self, $tagname)= @_;
527 36   66     106 my $class= ref($self)||$self;
528             # Make the common case fast
529 36         101 my $list= $EXPORT_TAGS_PKG_CACHE{$class}{$tagname};
530             $list= $self->_exporter_build_tag_cache($tagname)
531 36 50 66     196 unless $list or exists $EXPORT_TAGS_PKG_CACHE{$class}{$tagname};
532 36         166 return $list;
533             }
534              
535             sub _exporter_is_excluded {
536 20     20   30 my ($self, $symbol)= @_;
537 20 50 33     72 return unless ref $self && (my $not= $self->{not});
538             # N^2 exclusion iteration isn't cool, but doing something smarter requires a
539             # lot more setup that probably won't pay off for the usual tiny lists of 'not'.
540 20 100       51 for my $filter (ref $not eq 'ARRAY'? @$not : ($not)) {
541 22 100       54 if (!ref $filter) {
    100          
    50          
542 8 100       21 return 1 if $symbol eq $filter;
543             }
544             elsif (ref $filter eq 'Regexp') {
545 6 100       39 return 1 if $symbol =~ $filter;
546             }
547             elsif (ref $filter eq 'CODE') {
548 8   100     18 &$filter && return 1 for $symbol;
549             }
550 0         0 else { $croak->("Unhandled 'not' filter: $filter") }
551             }
552 10         36 return;
553             }
554              
555             sub exporter_autoload_tag {
556 12     12 1 33 my ($self, $tagname)= @_;
557 12         27 return;
558             }
559              
560             sub exporter_also_import {
561 3     3 1 47 my $self= shift;
562 3 50 33     15 ref $self && $self->{todo} or $croak->('exporter_also_import can only be called on $self during an import()');
563 3         6 push @{$self->{todo}}, @_;
  3         24  
564             }
565              
566             my %method_attrs;
567             sub FETCH_CODE_ATTRIBUTES {
568 0     0   0 my ($class, $coderef)= (shift, shift);
569 0         0 my $super= $class->next::can;
570 0 0       0 return @{$method_attrs{$class}{$coderef} || []},
  0 0       0  
571             ($super? $super->($class, $coderef, @_) : ());
572             }
573             sub MODIFY_CODE_ATTRIBUTES {
574 20     20   1011 my ($class, $coderef)= (shift, shift);
575 20         89 my @unknown= grep !$class->_exporter_process_attribute($coderef, $_), @_;
576 20         82 my $super= $class->next::can;
577 20 50       312 return $super? $super->($class, $coderef, @unknown) : @unknown;
578             }
579              
580             sub _exporter_get_coderef_name {
581             # Sub::Identify has an XS version that we take advantage of if available
582             my $impl= (eval 'require Sub::Identify;1')? sub {
583 0 0   0     &Sub::Identify::sub_name
584             or $croak->("Can't determine export name of $_[0]");
585             }
586 0 0   0     : do {
587 0           require B;
588             sub {
589 17     17   62 my $cv= &B::svref_2object;
  0            
590 17 50 33     320 $cv->isa('B::CV') && !$cv->GV->isa('B::SPECIAL') && $cv->GV->NAME
  0 0 33        
      0        
      0        
591             or $croak->("Can't determine export name of $_[0]");
592 0           };
593             };
594 0           *_exporter_get_coderef_name= $impl;
595 0           $impl->(shift);
596             }
597              
598             sub _exporter_get_ref_to_package_var {
599 9     9   20 my ($class, $sigil, $name)= @_;
600 9 50       19 unless (defined $name) {
601 0 0       0 ($sigil, $name)= ($_[1] =~ /^([\$\@\%\*\&]?)(\w+)$/)
602             or $croak->("'$_[1]' is not an allowed variable name");
603             }
604 9         20 my $reftype= $sigil_to_reftype{$sigil};
605 9 50       12 return undef unless ${$class.'::'}{$name};
  9         30  
606 9 100       18 return $reftype eq 'GLOB'? \*{$class.'::'.$name} : *{$class.'::'.$name}{$reftype};
  1         6  
  8         38  
607             }
608              
609             sub _exporter_process_attribute {
610 21     21   47 my ($class, $coderef, $attr)= @_;
611 21 50       123 if ($attr =~ /^Export(?:\(\s*(.*?)\s*\))?$/) {
612 21         39 my (%tags, $subname, @export_names);
613             # If given a list in parenthesees, split on space and proces each. Else use the name of the sub itself.
614 21 100       96 for my $token ($1? split(/\s+/, $1) : ()) {
615 24 100       128 if ($token =~ /^:(.*)$/) {
    100          
    100          
    50          
616 7         23 $tags{$1}++; # save tags until we have the export_names
617             }
618             elsif ($token =~ /^\w+$/) {
619 6         13 push @export_names, $token;
620 6         9 ${$class.'::EXPORT'}{$token}= $coderef;
  6         25  
621             }
622             elsif ($token =~ /^-(\w*)(?:\(([0-9]+|\*|\?)\))?$/) {
623 4   33     18 $subname ||= _exporter_get_coderef_name($coderef);
624 4 50       20 push @export_names, length $1? $token : "-$subname";
625 4         24 $class->exporter_register_option(substr($export_names[-1],1), $subname, $2);
626             }
627             elsif (my($sym, $name)= ($token =~ /^=([\&\$\@\%\*:]?(\w*))$/)) {
628 7   33     29 $subname ||= _exporter_get_coderef_name($coderef);
629 7 100       16 my $export_name= length $name? $sym : do {
630 4         16 (my $x= $subname) =~ s/^_generate[A-Za-z]*_//;
631 4         10 $sym . $x
632             };
633 7         14 $export_name =~ s/^[&]//;
634 7         36 $class->exporter_register_generator($export_name, $subname);
635 7         21 push @export_names, $export_name;
636             }
637             else {
638 0         0 $croak->("Invalid export notation '$token'");
639             }
640             }
641 21 100       53 if (!@export_names) { # if list was empty or only tags...
642 6         14 push @export_names, _exporter_get_coderef_name($coderef);
643 6         15 ${$class.'::EXPORT'}{$export_names[-1]}= $coderef;
  6         32  
644             }
645 21         69 $class->exporter_register_tag_members($_, @export_names) for keys %tags;
646 21         77 return 1;
647             }
648 0         0 return;
649             }
650              
651             sub exporter_setup {
652 28     28 0 56 my ($self, $version)= @_;
653 28         44 push @{$self->{into}.'::ISA'}, ref($self);
  28         295  
654 28         159 strict->import;
655 28         263 warnings->import;
656 28 100       183 if ($version == 1) {
    50          
657             # Declare 'our %EXPORT'
658 5         9 *{$self->{into}.'::EXPORT'}= \%{$self->{into}.'::EXPORT'};
  5         17  
  5         21  
659             # Make @EXPORT and $EXPORT_TAGS{default} be the same arrayref.
660             # Allow either one to have been declared already.
661 5         9 my $tags= \%{$self->{into}.'::EXPORT_TAGS'};
  5         19  
662 0         0 *{$self->{into}.'::EXPORT'}= $tags->{default}
663 5 50       17 if ref $tags->{default} eq 'ARRAY';
664 5   50     23 $tags->{default} ||= \@{$self->{into}.'::EXPORT'};
  5         24  
665             # Export the 'export' function.
666 5         7 *{$self->{into}.'::export'}= \&_exporter_export_from_caller;
  5         47  
667             }
668             elsif ($version) {
669 0         0 $croak->("Unknown export API version $version");
670             }
671             }
672              
673             sub _exporter_export_from_caller {
674 18     18   19294 unshift @_, scalar caller;
675 18         115 goto $_[0]->can('exporter_export');
676             }
677             sub exporter_export {
678 18     18 1 39 my $class= shift;
679 18         33 my ($export, $is_gen, $sigil, $name, $args, $ref);
680 18         54 arg_loop: for (my $i= 0; $i < @_;) {
681 24         46 $export= $_[$i++];
682 24 50       50 ref $export and $croak->("Expected non-ref export name at argument $i");
683             # If they provided the ref, capture it from arg list.
684 24 100       57 $ref= ref $_[$i]? $_[$i++] : undef;
685             # Common case first - ordinary functions
686 24 100       196 if ($export =~ /^\w+$/) {
    100          
    100          
    50          
687 9 50       18 if ($ref) {
688 0 0       0 ref $ref eq 'CODE' or $croak->("Expected CODEref following '$export'");
689             } else {
690 9 50       34 $ref= $class->can($export) or $croak->("Export '$export' not found in $class");
691             }
692 9         15 ${$class.'::EXPORT'}{$export}= $ref;
  9         65  
693             }
694             # Next, check for generators
695             elsif (($is_gen, $sigil, $name)= ($export =~ /^(=?)([\$\@\%\*]?)(\w+)$/)) {
696 13 100       31 if ($is_gen) {
697 4 100       10 if ($ref) {
698             # special case, remove ref on method name (since it isn't possible to pass
699             # a plain scalar as the second asrgument)
700 1 50       6 $ref= $$ref if ref $ref eq 'SCALAR';
701 1         6 $class->exporter_register_generator($sigil.$name, $ref);
702             } else {
703 3         6 for (@{ $sigil_to_generator_prefix{$sigil} }) {
  3         11  
704 5         17 my $method= $_ . $name;
705 5 100       27 if ($class->can($method)) {
706 3         18 $class->exporter_register_generator($sigil.$name, $method);
707 3         52 next arg_loop;
708             }
709             }
710 0         0 $croak->("Export '$export' not found in package $class, nor a generator $sigil_to_generator_prefix{$sigil}[0]");
711             }
712             }
713             else {
714 9   33     39 $ref ||= $class->_exporter_get_ref_to_package_var($sigil, $name);
715 9 50 33     39 ref $ref eq $sigil_to_reftype{$sigil} or (ref $ref eq 'REF' && $sigil eq '$')
      66        
716             or $croak->("'$export' should be $sigil_to_reftype{$sigil} but you supplied ".ref($ref));
717 9         15 ${$class.'::EXPORT'}{$sigil.$name}= $ref;
  9         144  
718             }
719             }
720             # Tags ":foo"
721             elsif (($is_gen, $name)= ($export =~ /^(=?):(\w+)$/)) {
722 1 50 33     5 if ($is_gen && !$ref) {
723 0         0 my $gen= $sigil_to_generator_prefix{':'}.$name;
724 0 0       0 $class->can($gen)
725             or $croak->("Can't find generator for tag $name : '$gen'");
726 0         0 $ref= $gen;
727             }
728 1 50       9 ref $ref eq 'ARRAY'? $class->exporter_register_tag_members($name, @$ref)
729             : $class->exporter_register_generator($export, $ref);
730             }
731             # Options "-foo" or "-foo(3)"
732             elsif (($name, $args)= ($export =~ /^-(\w+)(?:\(([0-9]+|\*|\?)\))?$/)) {
733 1 50       4 if ($ref) {
734 0 0 0     0 ref $ref eq 'CODE' or (ref $ref eq 'SCALAR' and $class->can($ref= $$ref))
      0        
735             or $croak->("Option '$export' must be followed by coderef or method name as scalar ref");
736             } else {
737 1 50       6 $class->can($name)
738             or $croak->("Option '$export' defaults to a method '$name' which does not exist on $class");
739 1         3 $ref= $name;
740             }
741 1         9 $class->exporter_register_option($name, $ref, $args);
742             }
743             else {
744 0           $croak->("'$export' is not a valid export syntax");
745             }
746             }
747             }
748              
749             1;
750              
751             __END__