File Coverage

blib/lib/Test2/Util/Importer.pm
Criterion Covered Total %
statement 227 352 64.4
branch 82 174 47.1
condition 71 175 40.5
subroutine 24 40 60.0
pod 0 19 0.0
total 404 760 53.1


line stmt bran cond sub pod time code
1             package Test2::Util::Importer;
2 376     376   13940 use strict; no strict 'refs';
  327     327   13602  
  323         17983  
  170         885  
  170         358  
  170         4474  
3 170     323   1098 use warnings; no warnings 'once';
  170     170   440  
  170         4491  
  170         905  
  170         405  
  170         586751  
4              
5             our $VERSION = '0.000156';
6              
7             my %SIG_TO_SLOT = (
8             '&' => 'CODE',
9             '$' => 'SCALAR',
10             '%' => 'HASH',
11             '@' => 'ARRAY',
12             '*' => 'GLOB',
13             );
14              
15             our %IMPORTED;
16              
17             # This will be used to check if an import arg is a version number
18             my %NUMERIC = map +($_ => 1), 0 .. 9;
19              
20             sub IMPORTER_MENU() {
21             return (
22             export_ok => [qw/optimal_import/],
23             export_anon => {
24             import => sub {
25 164     164   759 my $from = shift;
26 164         2218 my @caller = caller(0);
27              
28 164 100 33     2507 _version_check($from, \@caller, shift @_) if @_ && $NUMERIC{substr($_[0], 0, 1)};
29              
30 164         1008 my $file = _mod_to_file($from);
31 164 50       1236 _load_file(\@caller, $file) unless $INC{$file};
32              
33 164 100       1200 return if optimal_import($from, $caller[0], \@caller, @_);
34              
35 162         1369 my $self = __PACKAGE__->new(
36             from => $from,
37             caller => \@caller,
38             );
39              
40 162         926 $self->do_import($caller[0], @_);
41             },
42             },
43 172     220 0 1773 );
44             }
45              
46             ###########################################################################
47             #
48             # These are class methods
49             # import and unimport are what you would expect.
50             # import_into and unimport_from are the indirect forms you can use in other
51             # package import() methods.
52             #
53             # These all attempt to do a fast optimal-import if possible, then fallback to
54             # the full-featured import that constructs an object when needed.
55             #
56              
57             sub import {
58 482     482   1544 my $class = shift;
59              
60 482         4349 my @caller = caller(0);
61              
62 482 50 66     6117 _version_check($class, \@caller, shift @_) if @_ && $NUMERIC{substr($_[0], 0, 1)};
63              
64 482 100       8061 return unless @_;
65              
66 327         1285 my ($from, @args) = @_;
67              
68 327         1325 my $file = _mod_to_file($from);
69 327 100       2213 _load_file(\@caller, $file) unless $INC{$file};
70              
71 327 50       2039 return if optimal_import($from, $caller[0], \@caller, @args);
72              
73 327         2334 my $self = $class->new(
74             from => $from,
75             caller => \@caller,
76             );
77              
78 327         1664 $self->do_import($caller[0], @args);
79             }
80              
81             sub unimport {
82 0     0   0 my $class = shift;
83 0         0 my @caller = caller(0);
84              
85 0         0 my $self = $class->new(
86             from => $caller[0],
87             caller => \@caller,
88             );
89              
90 0         0 $self->do_unimport(@_);
91             }
92              
93             sub import_into {
94 356     356 0 953 my $class = shift;
95 356         1089 my ($from, $into, @args) = @_;
96              
97 356         627 my @caller;
98              
99 356 50       2476 if (ref($into)) {
    50          
100 0         0 @caller = @$into;
101 0         0 $into = $caller[0];
102             }
103             elsif ($into =~ m/^\d+$/) {
104 0         0 @caller = caller($into + 1);
105 0         0 $into = $caller[0];
106             }
107             else {
108 356         3451 @caller = caller(0);
109             }
110              
111 356         1578 my $file = _mod_to_file($from);
112 356 50       1767 _load_file(\@caller, $file) unless $INC{$file};
113              
114 356 100       1506 return if optimal_import($from, $into, \@caller, @args);
115              
116 26         140 my $self = $class->new(
117             from => $from,
118             caller => \@caller,
119             );
120              
121 26         109 $self->do_import($into, @args);
122             }
123              
124             sub unimport_from {
125 0     0 0 0 my $class = shift;
126 0         0 my ($from, @args) = @_;
127              
128 0         0 my @caller;
129 0 0       0 if ($from =~ m/^\d+$/) {
130 0         0 @caller = caller($from + 1);
131 0         0 $from = $caller[0];
132             }
133             else {
134 0         0 @caller = caller(0);
135             }
136              
137 0         0 my $self = $class->new(
138             from => $from,
139             caller => \@caller,
140             );
141              
142 0         0 $self->do_unimport(@args);
143             }
144              
145             ###########################################################################
146             #
147             # Constructors
148             #
149              
150             sub new {
151 515     515 0 1367 my $class = shift;
152 515         1980 my %params = @_;
153              
154 515   50     1876 my $caller = $params{caller} || [caller()];
155              
156             die "You must specify a package to import from at $caller->[1] line $caller->[2].\n"
157 515 50       1535 unless $params{from};
158              
159             return bless {
160             from => $params{from},
161             caller => $params{caller}, # Do not use our caller.
162 515         2791 }, $class;
163             }
164              
165             ###########################################################################
166             #
167             # Shortcuts for getting symbols without any namespace modifications
168             #
169              
170             sub get {
171 0     0 0 0 my $proto = shift;
172 0         0 my @caller = caller(1);
173              
174 0 0       0 my $self = ref($proto) ? $proto : $proto->new(
175             from => shift(@_),
176             caller => \@caller,
177             );
178              
179 0         0 my %result;
180 0     0   0 $self->do_import($caller[0], @_, sub { $result{$_[0]} = $_[1] });
  0         0  
181 0         0 return \%result;
182             }
183              
184             sub get_list {
185 0     0 0 0 my $proto = shift;
186 0         0 my @caller = caller(1);
187              
188 0 0       0 my $self = ref($proto) ? $proto : $proto->new(
189             from => shift(@_),
190             caller => \@caller,
191             );
192              
193 0         0 my @result;
194 0     0   0 $self->do_import($caller[0], @_, sub { push @result => $_[1] });
  0         0  
195 0         0 return @result;
196             }
197              
198             sub get_one {
199 0     0 0 0 my $proto = shift;
200 0         0 my @caller = caller(1);
201              
202 0 0       0 my $self = ref($proto) ? $proto : $proto->new(
203             from => shift(@_),
204             caller => \@caller,
205             );
206              
207 0         0 my $result;
208 0     0   0 $self->do_import($caller[0], @_, sub { $result = $_[1] });
  0         0  
209 0         0 return $result;
210             }
211              
212             ###########################################################################
213             #
214             # Object methods
215             #
216              
217             sub do_import {
218 515     515 0 1082 my $self = shift;
219              
220 515         1920 my ($into, $versions, $exclude, $import, $set) = $self->parse_args(@_);
221              
222             # Exporter supported multiple version numbers being listed...
223 515 50       1518 _version_check($self->from, $self->get_caller, @$versions) if @$versions;
224              
225 515 50       1765 return unless @$import;
226              
227 515 50       1572 $self->_handle_fail($into, $import) if $self->menu($into)->{fail};
228 515         2252 $self->_set_symbols($into, $exclude, $import, $set);
229             }
230              
231             sub do_unimport {
232 0     0 0 0 my $self = shift;
233              
234 0         0 my $from = $self->from;
235 0 0       0 my $imported = $IMPORTED{$from} or $self->croak("'$from' does not have any imports to remove");
236              
237 0         0 my %allowed = map { $_ => 1 } @$imported;
  0         0  
238              
239 0 0       0 my @args = @_ ? @_ : @$imported;
240              
241 0         0 my $stash = \%{"$from\::"};
  0         0  
242              
243 0         0 for my $name (@args) {
244 0         0 $name =~ s/^&//;
245              
246 0 0       0 $self->croak("Sub '$name' was not imported using " . ref($self)) unless $allowed{$name};
247              
248 0         0 my $glob = delete $stash->{$name};
249 0         0 local *GLOBCLONE = *$glob;
250              
251 0         0 for my $type (qw/SCALAR HASH ARRAY FORMAT IO/) {
252 0 0       0 next unless defined(*{$glob}{$type});
  0         0  
253 0         0 *{"$from\::$name"} = *{$glob}{$type}
  0         0  
  0         0  
254             }
255             }
256             }
257              
258 2086     2086 0 4589 sub from { $_[0]->{from} }
259              
260             sub from_file {
261 0     0 0 0 my $self = shift;
262              
263 0   0     0 $self->{from_file} ||= _mod_to_file($self->{from});
264              
265 0         0 return $self->{from_file};
266             }
267              
268             sub load_from {
269 0     0 0 0 my $self = shift;
270 0         0 my $from_file = $self->from_file;
271 0         0 my $this_file = __FILE__;
272              
273 0 0       0 return if $INC{$from_file};
274              
275 0         0 my $caller = $self->get_caller;
276              
277 0         0 _load_file($caller, $from_file);
278             }
279              
280             sub get_caller {
281 687     687 0 1198 my $self = shift;
282 687 50       2686 return $self->{caller} if $self->{caller};
283              
284 0         0 my $level = 1;
285 0         0 while(my @caller = caller($level++)) {
286 0 0 0     0 return \@caller if @caller && !$caller[0]->isa(__PACKAGE__);
287 0 0       0 last unless @caller;
288             }
289              
290             # Fallback
291 0         0 return [caller(0)];
292             }
293              
294             sub croak {
295 0     0 0 0 my $self = shift;
296 0         0 my ($msg) = @_;
297 0         0 my $caller = $self->get_caller;
298 0   0     0 my $file = $caller->[1] || 'unknown file';
299 0   0     0 my $line = $caller->[2] || 'unknown line';
300 0         0 die "$msg at $file line $line.\n";
301             }
302              
303             sub carp {
304 0     0 0 0 my $self = shift;
305 0         0 my ($msg) = @_;
306 0         0 my $caller = $self->get_caller;
307 0   0     0 my $file = $caller->[1] || 'unknown file';
308 0   0     0 my $line = $caller->[2] || 'unknown line';
309 0         0 warn "$msg at $file line $line.\n";
310             }
311              
312             sub menu {
313 2086     2086 0 3224 my $self = shift;
314 2086         3624 my ($into) = @_;
315              
316 2086 50       4463 $self->croak("menu() requires the name of the destination package")
317             unless $into;
318              
319 2086         5509 my $for = $self->{menu_for};
320 2086 50 66     6981 delete $self->{menu} if $for && $for ne $into;
321 2086   66     7760 return $self->{menu} || $self->reload_menu($into);
322             }
323              
324             sub reload_menu {
325 515     515 0 976 my $self = shift;
326 515         1106 my ($into) = @_;
327              
328 515 50       1286 $self->croak("reload_menu() requires the name of the destination package")
329             unless $into;
330              
331 515         1670 my $from = $self->from;
332              
333 515 100       894 if (my $menu_sub = *{"$from\::IMPORTER_MENU"}{CODE}) {
  515         3058  
334             # Hook, other exporter modules can define this method to be compatible with
335             # Importer.pm
336              
337 172         931 my %got = $from->$menu_sub($into, $self->get_caller);
338              
339 172   50     1381 $got{export} ||= [];
340 172   50     706 $got{export_ok} ||= [];
341 172   50     1175 $got{export_tags} ||= {};
342 172   50     1034 $got{export_fail} ||= [];
343 172   50     635 $got{export_anon} ||= {};
344 172   50     1694 $got{export_magic} ||= {};
345              
346             $self->croak("'$from' provides both 'generate' and 'export_gen' in its IMPORTER_MENU (They are exclusive, module must pick 1)")
347 172 0 33     657 if $got{export_gen} && $got{generate};
348              
349 172   50     1157 $got{export_gen} ||= {};
350              
351 172         1057 $self->{menu} = $self->_build_menu($into => \%got, 1);
352             }
353             else {
354 343         819 my %got;
355 343         923 $got{export} = \@{"$from\::EXPORT"};
  343         2026  
356 343         698 $got{export_ok} = \@{"$from\::EXPORT_OK"};
  343         1569  
357 343         736 $got{export_tags} = \%{"$from\::EXPORT_TAGS"};
  343         1883  
358 343         698 $got{export_fail} = \@{"$from\::EXPORT_FAIL"};
  343         1556  
359 343         698 $got{export_gen} = \%{"$from\::EXPORT_GEN"};
  343         1378  
360 343         580 $got{export_anon} = \%{"$from\::EXPORT_ANON"};
  343         1488  
361 343         651 $got{export_magic} = \%{"$from\::EXPORT_MAGIC"};
  343         1348  
362              
363 343         1386 $self->{menu} = $self->_build_menu($into => \%got, 0);
364             }
365              
366 515         2158 $self->{menu_for} = $into;
367              
368 515         1908 return $self->{menu};
369             }
370              
371             sub _build_menu {
372 515     515   969 my $self = shift;
373 515         1399 my ($into, $got, $new_style) = @_;
374              
375 515         1331 my $from = $self->from;
376              
377 515   50     1708 my $export = $got->{export} || [];
378 515   50     1482 my $export_ok = $got->{export_ok} || [];
379 515   50     1783 my $export_tags = $got->{export_tags} || {};
380 515   50     1474 my $export_fail = $got->{export_fail} || [];
381 515   50     1281 my $export_anon = $got->{export_anon} || {};
382 515   50     1251 my $export_gen = $got->{export_gen} || {};
383 515   50     1216 my $export_magic = $got->{export_magic} || {};
384              
385 515         965 my $generate = $got->{generate};
386              
387             $generate ||= sub {
388 0     0   0 my $symbol = shift;
389 0         0 my ($sig, $name) = ($symbol =~ m/^(\W?)(.*)$/);
390 0   0     0 $sig ||= '&';
391              
392 0         0 my $do = $export_gen->{"${sig}${name}"};
393 0 0 0     0 $do ||= $export_gen->{$name} if !$sig || $sig eq '&';
      0        
394              
395 0 0       0 return undef unless $do;
396              
397 0         0 $from->$do($into, $symbol);
398 515 100 50     4658 } if $export_gen && keys %$export_gen;
      66        
399              
400 515         1074 my $lookup = {};
401 515         1004 my $exports = {};
402 515         1945 for my $sym (@$export, @$export_ok, keys %$export_gen, keys %$export_anon) {
403 2118         10259 my ($sig, $name) = ($sym =~ m/^(\W?)(.*)$/);
404 2118   100     7959 $sig ||= '&';
405              
406 2118         5287 $lookup->{"${sig}${name}"} = 1;
407 2118 50       5538 $lookup->{$name} = 1 if $sig eq '&';
408              
409 2118 100       4924 next if $export_gen->{"${sig}${name}"};
410 1956 50 33     6111 next if $sig eq '&' && $export_gen->{$name};
411 1956 50 33     4364 next if $got->{generate} && $generate->("${sig}${name}");
412              
413 1956         3790 my $fqn = "$from\::$name";
414             # We cannot use *{$fqn}{TYPE} here, it breaks for autoloaded subs, this
415             # does not:
416             $exports->{"${sig}${name}"} = $export_anon->{$sym} || (
417             $sig eq '&' ? \&{$fqn} :
418             $sig eq '$' ? \${$fqn} :
419             $sig eq '@' ? \@{$fqn} :
420             $sig eq '%' ? \%{$fqn} :
421 1956   66     5821 $sig eq '*' ? \*{$fqn} :
422             # Sometimes people (CGI::Carp) put invalid names (^name=) into
423             # @EXPORT. We simply go to 'next' in these cases. These modules
424             # have hooks to prevent anyone actually trying to import these.
425             next
426             );
427             }
428              
429 515   66     5951 my $f_import = $new_style || $from->can('import');
430             $self->croak("'$from' does not provide any exports")
431             unless $new_style
432             || keys %$exports
433             || $from->isa('Exporter')
434 515 0 66     3295 || ($INC{'Exporter.pm'} && $f_import && $f_import == \&Exporter::import);
      33        
      0        
      0        
      33        
435              
436             # Do not cleanup or normalize the list added to the DEFAULT tag, legacy....
437 515         2421 my $tags = {
438             %$export_tags,
439             'DEFAULT' => [ @$export ],
440             };
441              
442             # Add 'ALL' tag unless already specified. We want to normalize it.
443 515   50     3552 $tags->{ALL} ||= [ sort grep {m/^[\&\$\@\%\*]/} keys %$lookup ];
  4236         12447  
444              
445             my $fail = @$export_fail ? {
446             map {
447 515 50       1771 my ($sig, $name) = (m/^(\W?)(.*)$/);
  0         0  
448 0   0     0 $sig ||= '&';
449 0 0       0 ("${sig}${name}" => 1, $sig eq '&' ? ($name => 1) : ())
450             } @$export_fail
451             } : undef;
452              
453 515         2838 my $menu = {
454             lookup => $lookup,
455             exports => $exports,
456             tags => $tags,
457             fail => $fail,
458             generate => $generate,
459             magic => $export_magic,
460             };
461              
462 515         2130 return $menu;
463             }
464              
465             sub parse_args {
466 515     515 0 973 my $self = shift;
467 515         1426 my ($into, @args) = @_;
468              
469 515         1927 my $menu = $self->menu($into);
470              
471 515         2244 my @out = $self->_parse_args($into, $menu, \@args);
472 515         1039 pop @out;
473 515         2009 return @out;
474             }
475              
476             sub _parse_args {
477 541     541   1012 my $self = shift;
478 541         1521 my ($into, $menu, $args, $is_tag) = @_;
479              
480 541         1313 my $from = $self->from;
481 541         1442 my $main_menu = $self->menu($into);
482 541   33     1790 $menu ||= $main_menu;
483              
484             # First we strip out versions numbers and setters, this simplifies the logic late.
485 541         1674 my @sets;
486             my @versions;
487 541         0 my @leftover;
488 541         1460 for my $arg (@$args) {
489 170     170   3140 no warnings 'void';
  170         418  
  170         345335  
490              
491             # Code refs are custom setters
492             # If the first character is an ASCII numeric then it is a version number
493 1749 50 0     3602 push @sets => $arg and next if ref($arg) eq 'CODE';
494 1749 50 0     4115 push @versions => $arg xor next if $NUMERIC{substr($arg, 0, 1)};
495 1749         3342 push @leftover => $arg;
496             }
497              
498 541 50       1587 $self->carp("Multiple setters specified, only 1 will be used") if @sets > 1;
499 541         1042 my $set = pop @sets;
500              
501 541         1072 $args = \@leftover;
502 541 100 100     2642 @$args = (':DEFAULT') unless $is_tag || @$args || @versions;
      66        
503              
504 541         1263 my %exclude;
505             my @import;
506              
507 541         1601 while(my $full_arg = shift @$args) {
508 1598         2526 my $arg = $full_arg;
509 1598         2670 my $lead = substr($arg, 0, 1);
510              
511 1598         2268 my ($spec, $exc);
512 1598 100       2957 if ($lead eq '!') {
513 4         8 $exc = $lead;
514              
515 4 50       16 if ($arg eq '!') {
516             # If the current arg is just '!' then we are negating the next item.
517 0         0 $arg = shift @$args;
518             }
519             else {
520             # Strip off the '!'
521 4         10 substr($arg, 0, 1, '');
522             }
523              
524             # Exporter.pm legacy behavior
525             # negated first item implies starting with default set:
526 4 50 66     25 unshift @$args => ':DEFAULT' unless @import || keys %exclude || @versions;
      66        
527              
528             # Now we have a new lead character
529 4         21 $lead = substr($arg, 0, 1);
530             }
531             else {
532             # If the item is followed by a reference then they are asking us to
533             # do something special...
534 1594 100       4210 $spec = ref($args->[0]) eq 'HASH' ? shift @$args : {};
535             }
536              
537 1598 100       3277 if($lead eq ':') {
538 26         110 substr($arg, 0, 1, '');
539 26 50       114 my $tag = $menu->{tags}->{$arg} or $self->croak("$from does not export the :$arg tag");
540              
541 26         291 my (undef, $cvers, $cexc, $cimp, $cset, $newmenu) = $self->_parse_args($into, $menu, $tag, $arg);
542              
543 26 50       104 $self->croak("Exporter specified version numbers (" . join(', ', @$cvers) . ") in the :$arg tag!")
544             if @$cvers;
545              
546 26 50       98 $self->croak("Exporter specified a custom symbol setter in the :$arg tag!")
547             if $cset;
548              
549             # Merge excludes
550 26         84 %exclude = (%exclude, %$cexc);
551              
552 26 50 33     203 if ($exc) {
    50          
553 0 0       0 $exclude{$_} = 1 for grep {!ref($_) && substr($_, 0, 1) ne '+'} map {$_->[0]} @$cimp;
  0         0  
  0         0  
554             }
555             elsif ($spec && keys %$spec) {
556             $self->croak("Cannot use '-as' to rename multiple symbols included by: $full_arg")
557 0 0 0     0 if $spec->{'-as'} && @$cimp > 1;
558              
559 0         0 for my $set (@$cimp) {
560 0         0 my ($sym, $cspec) = @$set;
561              
562             # Start with a blind squash, spec from tag overrides the ones inside.
563 0         0 my $nspec = {%$cspec, %$spec};
564              
565 0 0 0     0 $nspec->{'-prefix'} = "$spec->{'-prefix'}$cspec->{'-prefix'}" if $spec->{'-prefix'} && $cspec->{'-prefix'};
566 0 0 0     0 $nspec->{'-postfix'} = "$cspec->{'-postfix'}$spec->{'-postfix'}" if $spec->{'-postfix'} && $cspec->{'-postfix'};
567              
568 0         0 push @import => [$sym, $nspec];
569             }
570             }
571             else {
572 26         217 push @import => @$cimp;
573             }
574              
575             # New menu
576 26         59 $menu = $newmenu;
577              
578 26         235 next;
579             }
580              
581             # Process the item to figure out what symbols are being touched, if it
582             # is a tag or regex than it can be multiple.
583 1572         2230 my @list;
584 1572 50 33     4783 if(ref($arg) eq 'Regexp') {
    50          
585 0         0 @list = sort grep /$arg/, keys %{$menu->{lookup}};
  0         0  
586             }
587             elsif($lead eq '/' && $arg =~ m{^/(.*)/$}) {
588 0         0 my $pattern = $1;
589 0         0 @list = sort grep /$1/, keys %{$menu->{lookup}};
  0         0  
590             }
591             else {
592 1572         2761 @list = ($arg);
593             }
594              
595             # Normalize list, always have a sigil
596 1572 100       2624 @list = map {m/^\W/ ? $_ : "\&$_" } @list;
  1572         6621  
597              
598 1572 100       3095 if ($exc) {
599 4         23 $exclude{$_} = 1 for @list;
600             }
601             else {
602             $self->croak("Cannot use '-as' to rename multiple symbols included by: $full_arg")
603 1568 50 66     4305 if $spec->{'-as'} && @list > 1;
604              
605 1568         7411 push @import => [$_, $spec] for @list;
606             }
607             }
608              
609 541         2670 return ($into, \@versions, \%exclude, \@import, $set, $menu);
610             }
611              
612             sub _handle_fail {
613 0     0   0 my $self = shift;
614 0         0 my ($into, $import) = @_;
615              
616 0         0 my $from = $self->from;
617 0         0 my $menu = $self->menu($into);
618              
619             # Historically Exporter would strip the '&' off of sub names passed into export_fail.
620 0 0       0 my @fail = map {my $x = $_->[0]; $x =~ s/^&//; $x} grep $menu->{fail}->{$_->[0]}, @$import or return;
  0         0  
  0         0  
  0         0  
621              
622 0 0       0 my @real_fail = $from->can('export_fail') ? $from->export_fail(@fail) : @fail;
623              
624 0 0       0 if (@real_fail) {
625             $self->carp(qq["$_" is not implemented by the $from module on this architecture])
626 0         0 for @real_fail;
627              
628 0         0 $self->croak("Can't continue after import errors");
629             }
630              
631 0         0 $self->reload_menu($menu);
632 0         0 return;
633             }
634              
635             sub _set_symbols {
636 515     515   971 my $self = shift;
637 515         1254 my ($into, $exclude, $import, $custom_set) = @_;
638              
639 515         5236 my $from = $self->from;
640 515         3749 my $menu = $self->menu($into);
641 515         1873 my $caller = $self->get_caller();
642              
643 170 50 50 170   8510 my $set_symbol = $custom_set || eval <<" EOT" || die $@;
  161 100   161   9778  
  515         52138  
644             # Inherit the callers warning settings. If they have warnings and we
645             # redefine their subs they will hear about it. If they do not have warnings
646             # on they will not.
647             BEGIN { \${^WARNING_BITS} = \$caller->[9] if defined \$caller->[9] }
648             #line $caller->[2] "$caller->[1]"
649             sub { *{"$into\\::\$_[0]"} = \$_[1] }
650             EOT
651              
652 515         2269 for my $set (@$import) {
653 1568         3596 my ($symbol, $spec) = @$set;
654              
655 1568 50       8774 my ($sig, $name) = ($symbol =~ m/^(\W)(.*)$/) or die "Invalid symbol: $symbol";
656              
657             # Find the thing we are actually shoving in a new namespace
658 1568         3565 my $ref = $menu->{exports}->{$symbol};
659 1568 100 33     3950 $ref ||= $menu->{generate}->($symbol) if $menu->{generate};
660              
661             # Exporter.pm supported listing items in @EXPORT that are not actually
662             # available for export. So if it is listed (lookup) but nothing is
663             # there (!$ref) we simply skip it.
664 1568 50 33     3524 $self->croak("$from does not export $symbol") unless $ref || $menu->{lookup}->{"${sig}${name}"};
665 1568 50       2759 next unless $ref;
666              
667 1568         2739 my $type = ref($ref);
668 1568 50       3213 $type = 'SCALAR' if $type eq 'REF';
669             $self->croak("Symbol '$sig$name' requested, but reference (" . ref($ref) . ") does not match sigil ($sig)")
670 1568 50 33     5950 if $ref && $type ne $SIG_TO_SLOT{$sig};
671              
672             # If they directly renamed it then we assume they want it under the new
673             # name, otherwise excludes get kicked. It is useful to be able to
674             # exclude an item in a tag/match where the group has a prefix/postfix.
675 1568 100 100     4758 next if $exclude->{"${sig}${name}"} && !$spec->{'-as'};
676              
677 1564   50     8766 my $new_name = join '' => ($spec->{'-prefix'} || '', $spec->{'-as'} || $name, $spec->{'-postfix'} || '');
      66        
      50        
678              
679             # Set the symbol (finally!)
680 1564         4843 $set_symbol->($new_name, $ref, sig => $sig, symbol => $symbol, into => $into, from => $from, spec => $spec);
681              
682             # The remaining things get skipped with a custom setter
683 1564 50       3812 next if $custom_set;
684              
685             # Record the import so that we can 'unimport'
686 1564 50       3425 push @{$IMPORTED{$into}} => $new_name if $sig eq '&';
  1564         3901  
687              
688             # Apply magic
689 1564         2917 my $magic = $menu->{magic}->{$symbol};
690 1564 50 33     6618 $magic ||= $menu->{magic}->{$name} if $sig eq '&';
691 1564 50       55912 $from->$magic(into => $into, orig_name => $name, new_name => $new_name, ref => $ref)
692             if $magic;
693             }
694             }
695              
696             ###########################################################################
697             #
698             # The rest of these are utility functions, not methods!
699             #
700              
701             sub _version_check {
702 0     0   0 my ($mod, $caller, @versions) = @_;
703              
704 0 0       0 eval <<" EOT" or die $@;
705             #line $caller->[2] "$caller->[1]"
706             \$mod->VERSION(\$_) for \@versions;
707             1;
708             EOT
709             }
710              
711             sub _mod_to_file {
712 847     847   1876 my $file = shift;
713 847         4415 $file =~ s{::}{/}g;
714 847         2195 $file .= '.pm';
715 847         2375 return $file;
716             }
717              
718             sub _load_file {
719 155     155   676 my ($caller, $file) = @_;
720              
721 155 50       4864 eval <<" EOT" || die $@;
722             #line $caller->[2] "$caller->[1]"
723             require \$file;
724             EOT
725             }
726              
727              
728             my %HEAVY_VARS = (
729             IMPORTER_MENU => 'CODE', # Origin package has a custom menu
730             EXPORT_FAIL => 'ARRAY', # Origin package has a failure handler
731             EXPORT_GEN => 'HASH', # Origin package has generators
732             EXPORT_ANON => 'HASH', # Origin package has anonymous exports
733             EXPORT_MAGIC => 'HASH', # Origin package has magic to apply post-export
734             );
735              
736             sub optimal_import {
737 847     847 0 2871 my ($from, $into, $caller, @args) = @_;
738              
739 847   100     3866 defined(*{"$from\::$_"}{$HEAVY_VARS{$_}}) and return 0 for keys %HEAVY_VARS;
  3589         21761  
740              
741             # Default to @EXPORT
742 507 100       2336 @args = @{"$from\::EXPORT"} unless @args;
  330         5503  
743              
744             # Subs will be listed without sigil in %allowed, all others keep sigil
745             my %allowed = map +(substr($_, 0, 1) eq '&' ? substr($_, 1) : $_ => 1),
746 507 50       1467 @{"$from\::EXPORT"}, @{"$from\::EXPORT_OK"};
  507         1877  
  507         32440  
747              
748             # First check if it is allowed, stripping '&' if necessary, which will also
749             # let scalars in, we will deal with those shortly.
750             # If not allowed return 0 (need to do a heavy import)
751             # if it is allowed then see if it has a CODE slot, if so use it, otherwise
752             # we have a symbol that needs heavy due to non-sub, autoload, etc.
753             # This will not allow $foo to import foo() since '$from' still contains the
754             # sigil making it an invalid symbol name in our globref below.
755             my %final = map +(
756             (!ref($_) && ($allowed{$_} || (substr($_, 0, 1, "") eq '&' && $allowed{$_})))
757 507 100 100     5666 ? ($_ => *{"$from\::$_"}{CODE} || return 0)
      50        
758             : return 0
759             ), @args;
760              
761 332 50       36463 eval <<" EOT" || die $@;
762             # If the caller has redefine warnings enabled then we want to warn them if
763             # their import redefines things.
764             BEGIN { \${^WARNING_BITS} = \$caller->[9] if defined \$caller->[9] };
765             #line $caller->[2] "$caller->[1]"
766             (*{"$into\\::\$_"} = \$final{\$_}, push \@{\$Test2::Util::Importer::IMPORTED{\$into}} => \$_) for keys %final;
767             1;
768             EOT
769             }
770              
771             1;
772              
773             __END__