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 374     437   12859 use strict; no strict 'refs';
  325     325   12186  
  322         16559  
  169         773  
  169         343  
  169         3994  
3 169     322   734 use warnings; no warnings 'once';
  169     169   367  
  169         4130  
  169         788  
  169         389  
  169         524772  
4              
5             our $VERSION = '0.000153';
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 163     163   600 my $from = shift;
26 163         1664 my @caller = caller(0);
27              
28 163 100 33     2213 _version_check($from, \@caller, shift @_) if @_ && $NUMERIC{substr($_[0], 0, 1)};
29              
30 163         799 my $file = _mod_to_file($from);
31 163 50       950 _load_file(\@caller, $file) unless $INC{$file};
32              
33 163 100       933 return if optimal_import($from, $caller[0], \@caller, @_);
34              
35 161         1343 my $self = __PACKAGE__->new(
36             from => $from,
37             caller => \@caller,
38             );
39              
40 161         911 $self->do_import($caller[0], @_);
41             },
42             },
43 171     171 0 1657 );
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 479     479   2972 my $class = shift;
59              
60 479         5505 my @caller = caller(0);
61              
62 479 50 66     9271 _version_check($class, \@caller, shift @_) if @_ && $NUMERIC{substr($_[0], 0, 1)};
63              
64 479 100       8006 return unless @_;
65              
66 325         1230 my ($from, @args) = @_;
67              
68 325         1247 my $file = _mod_to_file($from);
69 325 100       1940 _load_file(\@caller, $file) unless $INC{$file};
70              
71 325 50       2003 return if optimal_import($from, $caller[0], \@caller, @args);
72              
73 325         2301 my $self = $class->new(
74             from => $from,
75             caller => \@caller,
76             );
77              
78 325         1961 $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 355     355 0 990 my $class = shift;
95 355         1035 my ($from, $into, @args) = @_;
96              
97 355         660 my @caller;
98              
99 355 50       2310 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 355         3126 @caller = caller(0);
109             }
110              
111 355         1562 my $file = _mod_to_file($from);
112 355 50       1631 _load_file(\@caller, $file) unless $INC{$file};
113              
114 355 100       1481 return if optimal_import($from, $into, \@caller, @args);
115              
116 26         187 my $self = $class->new(
117             from => $from,
118             caller => \@caller,
119             );
120              
121 26         121 $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 512     512 0 1223 my $class = shift;
152 512         1942 my %params = @_;
153              
154 512   50     1780 my $caller = $params{caller} || [caller()];
155              
156             die "You must specify a package to import from at $caller->[1] line $caller->[2].\n"
157 512 50       1484 unless $params{from};
158              
159             return bless {
160             from => $params{from},
161             caller => $params{caller}, # Do not use our caller.
162 512         2616 }, $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 512     512 0 1051 my $self = shift;
219              
220 512         1918 my ($into, $versions, $exclude, $import, $set) = $self->parse_args(@_);
221              
222             # Exporter supported multiple version numbers being listed...
223 512 50       1575 _version_check($self->from, $self->get_caller, @$versions) if @$versions;
224              
225 512 50       1785 return unless @$import;
226              
227 512 50       1416 $self->_handle_fail($into, $import) if $self->menu($into)->{fail};
228 512         1856 $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 2074     2074 0 4337 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 683     683 0 1176 my $self = shift;
282 683 50       2505 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 2074     2074 0 3284 my $self = shift;
314 2074         3415 my ($into) = @_;
315              
316 2074 50       4399 $self->croak("menu() requires the name of the destination package")
317             unless $into;
318              
319 2074         5302 my $for = $self->{menu_for};
320 2074 50 66     6792 delete $self->{menu} if $for && $for ne $into;
321 2074   66     6913 return $self->{menu} || $self->reload_menu($into);
322             }
323              
324             sub reload_menu {
325 512     512 0 884 my $self = shift;
326 512         1040 my ($into) = @_;
327              
328 512 50       2003 $self->croak("reload_menu() requires the name of the destination package")
329             unless $into;
330              
331 512         1650 my $from = $self->from;
332              
333 512 100       900 if (my $menu_sub = *{"$from\::IMPORTER_MENU"}{CODE}) {
  512         2781  
334             # Hook, other exporter modules can define this method to be compatible with
335             # Importer.pm
336              
337 171         872 my %got = $from->$menu_sub($into, $self->get_caller);
338              
339 171   50     1320 $got{export} ||= [];
340 171   50     682 $got{export_ok} ||= [];
341 171   50     1017 $got{export_tags} ||= {};
342 171   50     910 $got{export_fail} ||= [];
343 171   50     578 $got{export_anon} ||= {};
344 171   50     965 $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 171 0 33     663 if $got{export_gen} && $got{generate};
348              
349 171   50     1019 $got{export_gen} ||= {};
350              
351 171         845 $self->{menu} = $self->_build_menu($into => \%got, 1);
352             }
353             else {
354 341         780 my %got;
355 341         613 $got{export} = \@{"$from\::EXPORT"};
  341         1957  
356 341         661 $got{export_ok} = \@{"$from\::EXPORT_OK"};
  341         1265  
357 341         603 $got{export_tags} = \%{"$from\::EXPORT_TAGS"};
  341         1999  
358 341         684 $got{export_fail} = \@{"$from\::EXPORT_FAIL"};
  341         1517  
359 341         654 $got{export_gen} = \%{"$from\::EXPORT_GEN"};
  341         1241  
360 341         700 $got{export_anon} = \%{"$from\::EXPORT_ANON"};
  341         1282  
361 341         570 $got{export_magic} = \%{"$from\::EXPORT_MAGIC"};
  341         1473  
362              
363 341         1332 $self->{menu} = $self->_build_menu($into => \%got, 0);
364             }
365              
366 512         2095 $self->{menu_for} = $into;
367              
368 512         2192 return $self->{menu};
369             }
370              
371             sub _build_menu {
372 512     512   1038 my $self = shift;
373 512         1255 my ($into, $got, $new_style) = @_;
374              
375 512         1240 my $from = $self->from;
376              
377 512   50     1676 my $export = $got->{export} || [];
378 512   50     1524 my $export_ok = $got->{export_ok} || [];
379 512   50     1768 my $export_tags = $got->{export_tags} || {};
380 512   50     1428 my $export_fail = $got->{export_fail} || [];
381 512   50     1300 my $export_anon = $got->{export_anon} || {};
382 512   50     1269 my $export_gen = $got->{export_gen} || {};
383 512   50     1329 my $export_magic = $got->{export_magic} || {};
384              
385 512         968 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 512 100 50     4281 } if $export_gen && keys %$export_gen;
      66        
399              
400 512         1031 my $lookup = {};
401 512         1059 my $exports = {};
402 512         1981 for my $sym (@$export, @$export_ok, keys %$export_gen, keys %$export_anon) {
403 2080         9937 my ($sig, $name) = ($sym =~ m/^(\W?)(.*)$/);
404 2080   100     7736 $sig ||= '&';
405              
406 2080         5226 $lookup->{"${sig}${name}"} = 1;
407 2080 50       5618 $lookup->{$name} = 1 if $sig eq '&';
408              
409 2080 100       4945 next if $export_gen->{"${sig}${name}"};
410 1919 50 33     6290 next if $sig eq '&' && $export_gen->{$name};
411 1919 50 33     4502 next if $got->{generate} && $generate->("${sig}${name}");
412              
413 1919         3860 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 1919   66     5648 $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 512   66     5491 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 512 0 66     2931 || ($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 512         2258 my $tags = {
438             %$export_tags,
439             'DEFAULT' => [ @$export ],
440             };
441              
442             # Add 'ALL' tag unless already specified. We want to normalize it.
443 512   50     3633 $tags->{ALL} ||= [ sort grep {m/^[\&\$\@\%\*]/} keys %$lookup ];
  4160         11927  
444              
445             my $fail = @$export_fail ? {
446             map {
447 512 50       1782 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 512         2612 my $menu = {
454             lookup => $lookup,
455             exports => $exports,
456             tags => $tags,
457             fail => $fail,
458             generate => $generate,
459             magic => $export_magic,
460             };
461              
462 512         1947 return $menu;
463             }
464              
465             sub parse_args {
466 512     512 0 903 my $self = shift;
467 512         1378 my ($into, @args) = @_;
468              
469 512         1762 my $menu = $self->menu($into);
470              
471 512         2070 my @out = $self->_parse_args($into, $menu, \@args);
472 512         942 pop @out;
473 512         1910 return @out;
474             }
475              
476             sub _parse_args {
477 538     538   1021 my $self = shift;
478 538         1510 my ($into, $menu, $args, $is_tag) = @_;
479              
480 538         1244 my $from = $self->from;
481 538         1359 my $main_menu = $self->menu($into);
482 538   33     1554 $menu ||= $main_menu;
483              
484             # First we strip out versions numbers and setters, this simplifies the logic late.
485 538         1505 my @sets;
486             my @versions;
487 538         0 my @leftover;
488 538         1281 for my $arg (@$args) {
489 169     169   1436 no warnings 'void';
  169         400  
  169         311849  
490              
491             # Code refs are custom setters
492             # If the first character is an ASCII numeric then it is a version number
493 1713 50 0     3410 push @sets => $arg and next if ref($arg) eq 'CODE';
494 1713 50 0     3972 push @versions => $arg xor next if $NUMERIC{substr($arg, 0, 1)};
495 1713         3297 push @leftover => $arg;
496             }
497              
498 538 50       1540 $self->carp("Multiple setters specified, only 1 will be used") if @sets > 1;
499 538         1073 my $set = pop @sets;
500              
501 538         982 $args = \@leftover;
502 538 100 100     2618 @$args = (':DEFAULT') unless $is_tag || @$args || @versions;
      66        
503              
504 538         1003 my %exclude;
505             my @import;
506              
507 538         1610 while(my $full_arg = shift @$args) {
508 1563         2339 my $arg = $full_arg;
509 1563         2570 my $lead = substr($arg, 0, 1);
510              
511 1563         2281 my ($spec, $exc);
512 1563 100       3036 if ($lead eq '!') {
513 4         9 $exc = $lead;
514              
515 4 50       11 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         33 substr($arg, 0, 1, '');
522             }
523              
524             # Exporter.pm legacy behavior
525             # negated first item implies starting with default set:
526 4 50 66     31 unshift @$args => ':DEFAULT' unless @import || keys %exclude || @versions;
      66        
527              
528             # Now we have a new lead character
529 4         13 $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 1559 100       3944 $spec = ref($args->[0]) eq 'HASH' ? shift @$args : {};
535             }
536              
537 1563 100       3281 if($lead eq ':') {
538 26         114 substr($arg, 0, 1, '');
539 26 50       109 my $tag = $menu->{tags}->{$arg} or $self->croak("$from does not export the :$arg tag");
540              
541 26         594 my (undef, $cvers, $cexc, $cimp, $cset, $newmenu) = $self->_parse_args($into, $menu, $tag, $arg);
542              
543 26 50       93 $self->croak("Exporter specified version numbers (" . join(', ', @$cvers) . ") in the :$arg tag!")
544             if @$cvers;
545              
546 26 50       97 $self->croak("Exporter specified a custom symbol setter in the :$arg tag!")
547             if $cset;
548              
549             # Merge excludes
550 26         110 %exclude = (%exclude, %$cexc);
551              
552 26 50 33     368 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         204 push @import => @$cimp;
573             }
574              
575             # New menu
576 26         66 $menu = $newmenu;
577              
578 26         242 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 1537         2203 my @list;
584 1537 50 33     4471 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 1537         2692 @list = ($arg);
593             }
594              
595             # Normalize list, always have a sigil
596 1537 100       2505 @list = map {m/^\W/ ? $_ : "\&$_" } @list;
  1537         6576  
597              
598 1537 100       3063 if ($exc) {
599 4         24 $exclude{$_} = 1 for @list;
600             }
601             else {
602             $self->croak("Cannot use '-as' to rename multiple symbols included by: $full_arg")
603 1533 50 66     4081 if $spec->{'-as'} && @list > 1;
604              
605 1533         6916 push @import => [$_, $spec] for @list;
606             }
607             }
608              
609 538         2604 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 512     512   938 my $self = shift;
637 512         5191 my ($into, $exclude, $import, $custom_set) = @_;
638              
639 512         1167 my $from = $self->from;
640 512         3941 my $menu = $self->menu($into);
641 512         1791 my $caller = $self->get_caller();
642              
643 169 50 50 169   8032 my $set_symbol = $custom_set || eval <<" EOT" || die $@;
  160 100   160   9210  
  512         48134  
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 512         2515 for my $set (@$import) {
653 1533         3479 my ($symbol, $spec) = @$set;
654              
655 1533 50       8104 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 1533         3467 my $ref = $menu->{exports}->{$symbol};
659 1533 100 33     3614 $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 1533 50 33     3446 $self->croak("$from does not export $symbol") unless $ref || $menu->{lookup}->{"${sig}${name}"};
665 1533 50       2710 next unless $ref;
666              
667 1533         2656 my $type = ref($ref);
668 1533 50       3096 $type = 'SCALAR' if $type eq 'REF';
669             $self->croak("Symbol '$sig$name' requested, but reference (" . ref($ref) . ") does not match sigil ($sig)")
670 1533 50 33     5564 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 1533 100 100     4402 next if $exclude->{"${sig}${name}"} && !$spec->{'-as'};
676              
677 1529   50     8852 my $new_name = join '' => ($spec->{'-prefix'} || '', $spec->{'-as'} || $name, $spec->{'-postfix'} || '');
      66        
      50        
678              
679             # Set the symbol (finally!)
680 1529         4699 $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 1529 50       3380 next if $custom_set;
684              
685             # Record the import so that we can 'unimport'
686 1529 50       3377 push @{$IMPORTED{$into}} => $new_name if $sig eq '&';
  1529         3997  
687              
688             # Apply magic
689 1529         2725 my $magic = $menu->{magic}->{$symbol};
690 1529 50 33     7012 $magic ||= $menu->{magic}->{$name} if $sig eq '&';
691 1529 50       51943 $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 843     843   1873 my $file = shift;
713 843         4178 $file =~ s{::}{/}g;
714 843         2191 $file .= '.pm';
715 843         2208 return $file;
716             }
717              
718             sub _load_file {
719 154     154   565 my ($caller, $file) = @_;
720              
721 154 50       4742 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 843     843 0 2634 my ($from, $into, $caller, @args) = @_;
738              
739 843   100     3606 defined(*{"$from\::$_"}{$HEAVY_VARS{$_}}) and return 0 for keys %HEAVY_VARS;
  3558         20864  
740              
741             # Default to @EXPORT
742 505 100       2201 @args = @{"$from\::EXPORT"} unless @args;
  329         4873  
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 505 50       1328 @{"$from\::EXPORT"}, @{"$from\::EXPORT_OK"};
  505         1720  
  505         28759  
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 505 100 100     5129 ? ($_ => *{"$from\::$_"}{CODE} || return 0)
      50        
758             : return 0
759             ), @args;
760              
761 331 50       34069 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__