File Coverage

blib/lib/Exporter/Tiny.pm
Criterion Covered Total %
statement 226 248 91.1
branch 102 146 69.8
condition 27 49 55.1
subroutine 30 36 83.3
pod 0 2 0.0
total 385 481 80.0


line stmt bran cond sub pod time code
1             package Exporter::Tiny;
2              
3 17     17   67200 use 5.006001;
  17         80  
4 17     17   103 use strict;
  17         41  
  17         362  
5 17     17   79 use warnings; no warnings qw(void once uninitialized numeric redefine);
  17     17   46  
  17         459  
  17         84  
  17         35  
  17         3178  
6              
7             our $AUTHORITY = 'cpan:TOBYINK';
8             our $VERSION = '1.006001';
9             our @EXPORT_OK = qw< mkopt mkopt_hash _croak _carp >;
10              
11             BEGIN {
12             *_HAS_NATIVE_LEXICAL_SUB = ( $] ge '5.037002' )
13             ? sub () { !!1 }
14 17 50   17   195 : sub () { !!0 };
15             *_HAS_MODULE_LEXICAL_SUB = ( $] ge '5.011002' and eval('require Lexical::Sub') )
16             ? sub () { !!1 }
17 17 50 33     1356 : sub () { !!0 };
18             };
19              
20 7     7   38 sub _croak ($;@) { require Carp; my $fmt = shift; @_ = sprintf($fmt, @_); goto \&Carp::croak }
  7         14  
  7         72  
  7         1078  
21 1     1   6 sub _carp ($;@) { require Carp; my $fmt = shift; @_ = sprintf($fmt, @_); goto \&Carp::carp }
  1         4  
  1         6  
  1         196  
22              
23             my $_process_optlist = sub
24             {
25             my $class = shift;
26             my ($global_opts, $opts, $want, $not_want) = @_;
27            
28             while (@$opts)
29             {
30             my $opt = shift @{$opts};
31             my ($name, $value) = @$opt;
32            
33             ($name =~ m{\A\!(/.+/[msixpodual]*)\z}) ?
34             do {
35             my @not = $class->_exporter_expand_regexp("$1", $value, $global_opts);
36             ++$not_want->{$_->[0]} for @not;
37             } :
38             ($name =~ m{\A\![:-](.+)\z}) ?
39             do {
40             my @not = $class->_exporter_expand_tag("$1", $value, $global_opts);
41             ++$not_want->{$_->[0]} for @not;
42             } :
43             ($name =~ m{\A\!(.+)\z}) ?
44             (++$not_want->{$1}) :
45             ($name =~ m{\A[:-](.+)\z}) ?
46             push(@$opts, $class->_exporter_expand_tag("$1", $value, $global_opts)) :
47             ($name =~ m{\A/.+/[msixpodual]*\z}) ?
48             push(@$opts, $class->_exporter_expand_regexp($name, $value, $global_opts)) :
49             # else ?
50             push(@$want, $opt);
51             }
52             };
53              
54             sub import
55             {
56 42     42   15366 my $class = shift;
57 42 100 100     305 my $global_opts = +{ @_ && ref($_[0]) eq q(HASH) ? %{+shift} : () };
  13         51  
58            
59 42 50 66     246 if ( defined $global_opts->{into} and $global_opts->{into} eq '-lexical' ) {
60 0         0 $global_opts->{lexical} = 1;
61 0         0 delete $global_opts->{into};
62             }
63 42 100       158 if ( not defined $global_opts->{into} ) {
64 31         94 $global_opts->{into} = caller;
65             }
66            
67 42         78 my @want;
68 42         119 my %not_want; $global_opts->{not} = \%not_want;
69 17 100   17   181 my @args = do { no strict qw(refs); @_ ? @_ : @{"$class\::EXPORT"} };
  17         45  
  17         11899  
  42         88  
  42         163  
  3         14  
70 42         140 my $opts = mkopt(\@args);
71 42         156 $class->$_process_optlist($global_opts, $opts, \@want, \%not_want);
72            
73             $global_opts->{installer} ||= $class->_exporter_lexical_installer( $global_opts )
74 42 50 0     126 if $global_opts->{lexical};
75            
76 42         227 my $permitted = $class->_exporter_permitted_regexp($global_opts);
77 42         212 $class->_exporter_validate_opts($global_opts);
78            
79 42         93 for my $wanted (@want) {
80 72 100       235 next if $not_want{$wanted->[0]};
81            
82 65         240 my %symbols = $class->_exporter_expand_sub(@$wanted, $global_opts, $permitted);
83             $class->_exporter_install_sub($_, $wanted->[1], $global_opts, $symbols{$_})
84 62         556 for keys %symbols;
85             }
86             }
87              
88             sub unimport
89             {
90 4     4   61 my $class = shift;
91 4 50 66     24 my $global_opts = +{ @_ && ref($_[0]) eq q(HASH) ? %{+shift} : () };
  0         0  
92 4         12 $global_opts->{is_unimport} = 1;
93            
94 4 50 33     10 if ( defined $global_opts->{into} and $global_opts->{into} eq '-lexical' ) {
95 0         0 $global_opts->{lexical} = 1;
96 0         0 delete $global_opts->{into};
97             }
98 4 50       19 if ( not defined $global_opts->{into} ) {
99 4         10 $global_opts->{into} = caller;
100             }
101            
102 4         7 my @want;
103 4         8 my %not_want; $global_opts->{not} = \%not_want;
104 4 100       7 my @args = do { our %TRACKED; @_ ? @_ : keys(%{$TRACKED{$class}{$global_opts->{into}}}) };
  4         10  
  4         13  
  2         9  
105 4         12 my $opts = mkopt(\@args);
106 4         13 $class->$_process_optlist($global_opts, $opts, \@want, \%not_want);
107            
108 4         10 my $permitted = $class->_exporter_permitted_regexp($global_opts);
109 4         16 $class->_exporter_validate_unimport_opts($global_opts);
110            
111 4         12 my $expando = $class->can('_exporter_expand_sub');
112 4 50       15 $expando = undef if $expando == \&_exporter_expand_sub;
113            
114 4         9 for my $wanted (@want)
115             {
116 4 50       12 next if $not_want{$wanted->[0]};
117            
118 4 100       8 if ($wanted->[1])
119             {
120             _carp("Passing options to unimport '%s' makes no sense", $wanted->[0])
121 1 50 33     5 unless (ref($wanted->[1]) eq 'HASH' and not keys %{$wanted->[1]});
  1         5  
122             }
123            
124             my %symbols = defined($expando)
125             ? $class->$expando(@$wanted, $global_opts, $permitted)
126 4 50   0   20 : ($wanted->[0] => sub { "dummy" });
  0         0  
127             $class->_exporter_uninstall_sub($_, $wanted->[1], $global_opts)
128 4         21 for keys %symbols;
129             }
130             }
131              
132             # Returns a coderef suitable to be used as a sub installer for lexical imports.
133             #
134             sub _exporter_lexical_installer {
135             _HAS_NATIVE_LEXICAL_SUB and return sub {
136 0     0   0 my ( $sigilname, $sym ) = @{ $_[1] };
  0         0  
137 17 50   17   147 no warnings ( $] ge '5.037002' ? 'experimental::builtin' : () );
  17         43  
  17         8142  
138 0         0 builtin::export_lexically( $sigilname, $sym );
139 0     0   0 };
140             _HAS_MODULE_LEXICAL_SUB and return sub {
141 0     0   0 my ( $sigilname, $sym ) = @{ $_[1] };
  0         0  
142 0 0       0 ( $sigilname =~ /^\w/ )
143             ? 'Lexical::Sub'->import( $sigilname, $sym )
144             : 'Lexical::Var'->import( $sigilname, $sym );
145 0         0 };
146 0         0 _croak( 'Lexical export requires Perl 5.37.2+ for native support, or Perl 5.11.2+ with the Lexical::Sub module' );
147             }
148              
149             # Called once per import/unimport, passed the "global" import options.
150             # Expected to validate the options and carp or croak if there are problems.
151             # Can also take the opportunity to do other stuff if needed.
152             #
153 42     42   64 sub _exporter_validate_opts { 1 }
154 4     4   7 sub _exporter_validate_unimport_opts { 1 }
155              
156             # Called after expanding a tag or regexp to merge the tag's options with
157             # any sub-specific options.
158             #
159             sub _exporter_merge_opts
160             {
161 26     26   82 my $class = shift;
162 26         78 my ($tag_opts, $global_opts, @stuff) = @_;
163            
164 26 100       76 $tag_opts = {} unless ref($tag_opts) eq q(HASH);
165             _croak('Cannot provide an -as option for tags')
166 26 50 33     94 if exists $tag_opts->{-as} && ref $tag_opts->{-as} ne 'CODE';
167            
168 26         65 my $optlist = mkopt(\@stuff);
169 26         60 for my $export (@$optlist)
170             {
171 52 50 66     156 next if defined($export->[1]) && ref($export->[1]) ne q(HASH);
172            
173 52 100       78 my %sub_opts = ( %{ $export->[1] or {} }, %$tag_opts );
  52         270  
174             $sub_opts{-prefix} = sprintf('%s%s', $tag_opts->{-prefix}, $export->[1]{-prefix})
175 52 50 66     175 if exists($export->[1]{-prefix}) && exists($tag_opts->{-prefix});
176             $sub_opts{-suffix} = sprintf('%s%s', $export->[1]{-suffix}, $tag_opts->{-suffix})
177 52 50 66     123 if exists($export->[1]{-suffix}) && exists($tag_opts->{-suffix});
178 52         110 $export->[1] = \%sub_opts;
179             }
180 26         162 return @$optlist;
181             }
182              
183             # Given a tag name, looks it up in %EXPORT_TAGS and returns the list of
184             # associated functions. The default implementation magically handles tags
185             # "all" and "default". The default implementation interprets any undefined
186             # tags as being global options.
187             #
188             sub _exporter_expand_tag
189             {
190 17     17   132 no strict qw(refs);
  17         50  
  17         3869  
191            
192 24     24   59 my $class = shift;
193 24         65 my ($name, $value, $globals) = @_;
194 24         36 my $tags = \%{"$class\::EXPORT_TAGS"};
  24         119  
195            
196             return $class->_exporter_merge_opts($value, $globals, $tags->{$name}->($class, @_))
197 24 50       87 if ref($tags->{$name}) eq q(CODE);
198            
199 8         25 return $class->_exporter_merge_opts($value, $globals, @{$tags->{$name}})
200 24 100       74 if exists $tags->{$name};
201            
202 16 100       94 return $class->_exporter_merge_opts($value, $globals, @{"$class\::EXPORT"}, @{"$class\::EXPORT_OK"})
  14         50  
  14         64  
203             if $name eq 'all';
204            
205 2 100       6 return $class->_exporter_merge_opts($value, $globals, @{"$class\::EXPORT"})
  1         4  
206             if $name eq 'default';
207            
208 1   50     10 $globals->{$name} = $value || 1;
209 1         6 return;
210             }
211              
212             # Given a regexp-like string, looks it up in @EXPORT_OK and returns the
213             # list of matching functions.
214             #
215             sub _exporter_expand_regexp
216             {
217 17     17   127 no strict qw(refs);
  17         32  
  17         2805  
218 3     3   6 our %TRACKED;
219            
220 3         12 my $class = shift;
221 3         7 my ($name, $value, $globals) = @_;
222 3         228 my $compiled = eval("qr$name");
223            
224             my @possible = $globals->{is_unimport}
225 1         5 ? keys( %{$TRACKED{$class}{$globals->{into}}} )
226 3 100       17 : @{"$class\::EXPORT_OK"};
  2         11  
227            
228 3         32 $class->_exporter_merge_opts($value, $globals, grep /$compiled/, @possible);
229             }
230              
231             # Helper for _exporter_expand_sub. Returns a regexp matching all subs in
232             # the exporter package which are available for export.
233             #
234             sub _exporter_permitted_regexp
235             {
236 17     17   121 no strict qw(refs);
  17         54  
  17         3085  
237 46     46   89 my $class = shift;
238             my $re = join "|", map quotemeta, sort {
239 71 50       441 length($b) <=> length($a) or $a cmp $b
240 46         82 } @{"$class\::EXPORT"}, @{"$class\::EXPORT_OK"};
  46         173  
  46         236  
241 46         732 qr{^(?:$re)$}ms;
242             }
243              
244             # Given a sub name, returns a hash of subs to install (usually just one sub).
245             # Keys are sub names, values are coderefs.
246             #
247             sub _exporter_expand_sub
248             {
249 65     65   136 my $class = shift;
250 65         138 my ($name, $value, $globals, $permitted) = @_;
251 65   33     164 $permitted ||= $class->_exporter_permitted_regexp($globals);
252            
253 17     17   125 no strict qw(refs);
  17         31  
  17         10331  
254            
255 65         104 my $sigil = "&";
256 65 100       244 if ($name =~ /\A([&\$\%\@\*])(.+)\z/) {
257 16         39 $sigil = $1;
258 16         38 $name = $2;
259 16 50       49 if ($sigil eq '*') {
260 0         0 _croak("Cannot export symbols with a * sigil");
261             }
262             }
263 65 100       188 my $sigilname = $sigil eq '&' ? $name : "$sigil$name";
264            
265 65 100       487 if ($sigilname =~ $permitted)
266             {
267             my $generatorprefix = {
268             '&' => "_generate_",
269             '$' => "_generateScalar_",
270             '@' => "_generateArray_",
271             '%' => "_generateHash_",
272 63         325 }->{$sigil};
273            
274 63         472 my $generator = $class->can("$generatorprefix$name");
275 63 100       299 return $sigilname => $class->$generator($sigilname, $value, $globals) if $generator;
276            
277 36 100       90 if ($sigil eq '&') {
278 27         103 my $sub = $class->can($name);
279 27 100       160 return $sigilname => $sub if $sub;
280             }
281             else {
282             # Could do this more cleverly, but this works.
283 9         532 my $evalled = eval "\\${sigil}${class}::${name}";
284 9 50       63 return $sigilname => $evalled if $evalled;
285             }
286             }
287            
288 3         13 $class->_exporter_fail(@_);
289             }
290              
291             # Called by _exporter_expand_sub if it is unable to generate a key-value
292             # pair for a sub.
293             #
294             sub _exporter_fail
295             {
296 3     3   6 my $class = shift;
297 3         7 my ($name, $value, $globals) = @_;
298 3 50       9 return if $globals->{is_unimport};
299 3         8 _croak("Could not find sub '%s' exported by %s", $name, $class);
300             }
301              
302             # Actually performs the installation of the sub into the target package. This
303             # also handles renaming the sub.
304             #
305             sub _exporter_install_sub
306             {
307 62     62   121 my $class = shift;
308 62         126 my ($name, $value, $globals, $sym) = @_;
309 62 100       181 my $value_hash = ( ref($value) eq 'HASH' ) ? $value : {};
310            
311 62         108 my $into = $globals->{into};
312 62   33     313 my $installer = $globals->{installer} || $globals->{exporter};
313            
314             $name =
315             ref $globals->{as} ? $globals->{as}->($name) :
316             ref $value_hash->{-as} ? $value_hash->{-as}->($name) :
317             exists $value_hash->{-as} ? $value_hash->{-as} :
318 62 100       263 $name;
    50          
    50          
319            
320 62 50       138 return unless defined $name;
321            
322 62         95 my $sigil = "&";
323 62 50       150 unless (ref($name)) {
324 62 100       274 if ($name =~ /\A([&\$\%\@\*])(.+)\z/) {
325 15         34 $sigil = $1;
326 15         30 $name = $2;
327 15 50       34 if ($sigil eq '*') {
328 0         0 _croak("Cannot export symbols with a * sigil");
329             }
330             }
331 62         236 my ($prefix) = grep defined, $value_hash->{-prefix}, $globals->{prefix}, q();
332 62         178 my ($suffix) = grep defined, $value_hash->{-suffix}, $globals->{suffix}, q();
333 62         161 $name = "$prefix$name$suffix";
334             }
335            
336 62 100       201 my $sigilname = $sigil eq '&' ? $name : ( $sigil . $name );
337            
338             # if ({qw/$ SCALAR @ ARRAY % HASH & CODE/}->{$sigil} ne ref($sym)) {
339             # warn $sym;
340             # warn $sigilname;
341             # _croak("Reference type %s does not match sigil %s", ref($sym), $sigil);
342             # }
343            
344 62 50       256 return ($$name = $sym) if ref($name) eq q(SCALAR);
345 62 100       285 return ($into->{$sigilname} = $sym) if ref($into) eq q(HASH);
346            
347 17     17   138 no strict qw(refs);
  17         33  
  17         3905  
348 48         64 our %TRACKED;
349            
350 48 50 100     172 if ( ref($sym) eq 'CODE'
    50 100        
    100          
351 39         238 and ref($into) ? exists($into->{$name}) : exists(&{"$into\::$name"})
352 5         25 and $sym != ( ref($into) ? $into->{$name} : \&{"$into\::$name"} ) )
353             {
354 4         14 my ($level) = grep defined, $value_hash->{-replace}, $globals->{replace}, q(0);
355             my $action = {
356             carp => \&_carp,
357             0 => \&_carp,
358             '' => \&_carp,
359             warn => \&_carp,
360             nonfatal => \&_carp,
361             croak => \&_croak,
362             fatal => \&_croak,
363             die => \&_croak,
364 4   50 0   51 }->{$level} || sub {};
365            
366             # Don't complain about double-installing the same sub. This isn't ideal
367             # because the same named sub might be generated in two different ways.
368 4 100   1   24 $action = sub {} if $TRACKED{$class}{$into}{$sigilname};
369            
370 4 100       26 $action->(
    50          
371             $action == \&_croak
372             ? "Refusing to overwrite existing sub '%s' with sub '%s' exported by %s"
373             : "Overwriting existing sub '%s' with sub '%s' exported by %s",
374             ref($into) ? $name : "$into\::$name",
375             $_[0],
376             $class,
377             );
378             }
379            
380 46         142 $TRACKED{$class}{$into}{$sigilname} = $sym;
381            
382 17     17   171 no warnings qw(prototype);
  17         40  
  17         3716  
383             $installer
384             ? $installer->($globals, [$sigilname, $sym])
385 46 50       114 : (*{"$into\::$name"} = $sym);
  46         16707  
386             }
387              
388             sub _exporter_uninstall_sub
389             {
390 4     4   6 our %TRACKED;
391 4         16 my $class = shift;
392 4         16 my ($name, $value, $globals, $sym) = @_;
393 4         7 my $into = $globals->{into};
394 4 50       11 ref $into and return;
395            
396 17     17   126 no strict qw(refs);
  17         42  
  17         9412  
397              
398 4         6 my $sigil = "&";
399 4 100       14 if ($name =~ /\A([&\$\%\@\*])(.+)\z/) {
400 1         3 $sigil = $1;
401 1         3 $name = $2;
402 1 50       4 if ($sigil eq '*') {
403 0         0 _croak("Cannot export symbols with a * sigil");
404             }
405             }
406 4 100       11 my $sigilname = $sigil eq '&' ? $name : "$sigil$name";
407            
408 4 100       9 if ($sigil ne '&') {
409 1         3 _croak("Unimporting non-code symbols not supported yet");
410             }
411              
412             # Cowardly refuse to uninstall a sub that differs from the one
413             # we installed!
414 3         5 my $our_coderef = $TRACKED{$class}{$into}{$name};
415 3 50       4 my $cur_coderef = exists(&{"$into\::$name"}) ? \&{"$into\::$name"} : -1;
  3         11  
  3         8  
416 3 50       7 return unless $our_coderef == $cur_coderef;
417            
418 3         4 my $stash = \%{"$into\::"};
  3         8  
419 3         12 my $old = delete $stash->{$name};
420 3         6 my $full_name = join('::', $into, $name);
421 3         13 foreach my $type (qw(SCALAR HASH ARRAY IO)) # everything but the CODE
422             {
423 12 100       15 next unless defined(*{$old}{$type});
  12         39  
424 3         6 *$full_name = *{$old}{$type};
  3         16  
425             }
426            
427 3         267 delete $TRACKED{$class}{$into}{$name};
428             }
429              
430             sub mkopt
431             {
432 72 50   72 0 217 my $in = shift or return [];
433 72         124 my @out;
434            
435 72 0       195 $in = [map(($_ => ref($in->{$_}) ? $in->{$_} : ()), sort keys %$in)]
    50          
436             if ref($in) eq q(HASH);
437            
438 72         202 for (my $i = 0; $i < @$in; $i++)
439             {
440 112         187 my $k = $in->[$i];
441 112         148 my $v;
442            
443 112 100       342 ($i == $#$in) ? ($v = undef) :
    50          
    100          
444             !defined($in->[$i+1]) ? (++$i, ($v = undef)) :
445             !ref($in->[$i+1]) ? ($v = undef) :
446             ($v = $in->[++$i]);
447            
448 112         386 push @out, [ $k => $v ];
449             }
450            
451 72         162 \@out;
452             }
453              
454             sub mkopt_hash
455             {
456 0 0   0 0   my $in = shift or return;
457 0           my %out = map +($_->[0] => $_->[1]), @{ mkopt($in) };
  0            
458 0           \%out;
459             }
460              
461             1;
462              
463             __END__