File Coverage

blib/lib/Moose/Exporter.pm
Criterion Covered Total %
statement 342 368 92.9
branch 93 120 77.5
condition 43 61 70.4
subroutine 103 103 100.0
pod 66 66 100.0
total 647 718 90.1


line stmt bran cond sub pod time code
1             package Moose::Exporter;
2             our $VERSION = '2.2205';
3              
4 391     19084   79587 use strict;
  391         936  
  391         13441  
5 391     9457   2177 use warnings;
  391         903  
  391         12412  
6              
7 391     8466   22743 use Class::Load qw(is_class_loaded);
  391         789047  
  391         17747  
8 391     7337   177084 use Class::MOP;
  391         1499  
  391         24443  
9 391     4185   4668 use List::Util 1.45 qw( uniq );
  391         12502  
  391         33032  
10 391     3352   206294 use Moose::Util::MetaRole;
  391         2540  
  391         16914  
11 391     2777   2828 use Scalar::Util 1.40 qw(reftype);
  391         11206  
  391         21496  
12 391     2665   3952 use Sub::Exporter 0.980;
  391         6608  
  391         2337  
13 391     2587   80968 use Sub::Util 1.40 qw(set_subname);
  391         6871  
  391         19133  
14              
15 391     2261   3886 use Moose::Util 'throw_exception';
  391         979  
  391         3222  
16              
17             my %EXPORT_SPEC;
18              
19             sub setup_import_methods {
20 1073     2225 1 78371 my ( $class, %args ) = @_;
21              
22 1073   66     10052 $args{exporting_package} ||= caller();
23              
24 1073         9494 $class->build_import_methods(
25             %args,
26             install => [qw(import unimport init_meta)]
27             );
28             }
29              
30             # A reminder to intrepid Moose hackers
31             # there may be more than one level of exporter
32             # don't make doy cry. -- perigrin
33              
34             sub build_import_methods {
35 1075     2159 1 6412 my ( $class, %args ) = @_;
36              
37 1075   66     4778 my $exporting_package = $args{exporting_package} ||= caller();
38              
39 1075   100 8285   10307 my $meta_lookup = $args{meta_lookup} || sub { Class::MOP::class_of(shift) };
  7301         22571  
40              
41 1075         3810 $EXPORT_SPEC{$exporting_package} = \%args;
42              
43 1075         5613 my @exports_from = $class->_follow_also($exporting_package);
44              
45 1072         2949 my $export_recorder = {};
46 1072         3861 my $is_reexport = {};
47              
48             my $exports = $class->_make_sub_exporter_params(
49             [ $exporting_package, @exports_from ],
50             $export_recorder,
51             $is_reexport,
52             $args{meta_lookup}, # so that we don't pass through the default
53 1072         7411 );
54              
55 1071         7312 my $exporter = $class->_make_exporter(
56             $exports,
57             $is_reexport,
58             $meta_lookup,
59             );
60              
61 1071         706009 my %methods;
62 1071         7352 $methods{import} = $class->_make_import_sub(
63             $exporting_package,
64             $exporter,
65             \@exports_from,
66             $is_reexport,
67             $meta_lookup,
68             );
69              
70 1071         8977 $methods{unimport} = $class->_make_unimport_sub(
71             $exporting_package,
72             $exports,
73             $export_recorder,
74             $is_reexport,
75             $meta_lookup,
76             );
77              
78 1071         6291 $methods{init_meta} = $class->_make_init_meta(
79             $exporting_package,
80             \%args,
81             $meta_lookup,
82             );
83              
84 1071         11881 my $package = Class::MOP::Package->initialize($exporting_package);
85 1071 50       2621 for my $to_install ( @{ $args{install} || [] } ) {
  1071         11180  
86 3211         8611 my $symbol = '&' . $to_install;
87              
88             next
89 3211 100 66     15097 unless $methods{$to_install}
90             && !$package->has_package_symbol($symbol);
91             $package->add_package_symbol(
92             $symbol,
93             set_subname( $exporting_package . '::'
94 2148         20807 . $to_install => $methods{$to_install} )
95             );
96             }
97              
98 1071         7739 return ( $methods{import}, $methods{unimport}, $methods{init_meta} );
99             }
100              
101             sub _make_exporter {
102 1071     2011   5020 my ($class, $exports, $is_reexport, $meta_lookup) = @_;
103              
104             return Sub::Exporter::build_exporter(
105             {
106             exports => $exports,
107             groups => { default => [':all'] },
108             installer => sub {
109 3626     4518   39038 my ($arg, $to_export) = @_;
110 3626         10937 my $meta = $meta_lookup->($arg->{into});
111              
112 3626 100       14687 goto &Sub::Exporter::default_installer unless $meta;
113              
114             # don't overwrite existing symbols with our magically flagged
115             # version of it if we would install the same sub that's already
116             # in the importer
117              
118 2924         6450 my @filtered_to_export;
119             my %installed;
120 2924         6729 for (my $i = 0; $i < @{ $to_export }; $i += 2) {
  41022         81426  
121 38066         50646 my ($as, $cv) = @{ $to_export }[$i, $i + 1];
  38101         64513  
122              
123 38101 100 100     127629 next if !ref($as)
      100        
124             && $meta->has_package_symbol('&' . $as)
125             && $meta->get_package_symbol('&' . $as) == $cv;
126              
127 37646         79089 push @filtered_to_export, $as, $cv;
128 37646 100       96294 $installed{$as} = 1 unless ref $as;
129             }
130              
131 2962         13428 Sub::Exporter::default_installer($arg, \@filtered_to_export);
132              
133 2924         1817112 for my $name ( keys %{$is_reexport} ) {
  2924         121552  
134 391     2141   320546 no strict 'refs';
  391         1102  
  391         20681  
135 391     1989   2890 no warnings 'once';
  391         2383  
  391         492212  
136 5619 100       44405 next unless exists $installed{$name};
137 5379         8160 _flag_as_reexport( \*{ join q{::}, $arg->{into}, $name } );
  5379         969100  
138             }
139             },
140             }
141 1071         19036 );
142             }
143              
144             sub _follow_also {
145 1081     1967   3073 my $class = shift;
146 1075         2312 my $exporting_package = shift;
147              
148 1075         4799 _die_if_cycle_found_in_also_list_for_package($exporting_package);
149              
150 1072         5084 return uniq( _follow_also_real($exporting_package) );
151             }
152              
153             sub _follow_also_real {
154 1128     1985   2725 my $exporting_package = shift;
155 1128         3440 my @also = _also_list_for_package($exporting_package);
156              
157 1128         8601 return map { $_, _follow_also_real($_) } @also;
  56         148  
158             }
159              
160             sub _also_list_for_package {
161 2262     3059   3942 my $package = shift;
162              
163 2262 100       6149 if ( !exists $EXPORT_SPEC{$package} ) {
164 1         10 my $loaded = is_class_loaded($package);
165              
166 1         6 throw_exception( PackageDoesNotUseMooseExporter => package => $package,
167             is_loaded => $loaded
168             );
169             }
170              
171 2261         4679 my $also = $EXPORT_SPEC{$package}{also};
172              
173 2261 100       10293 return unless defined $also;
174              
175 87 100       331 return ref $also ? @$also : $also;
176             }
177              
178             # this is no Tarjan algorithm, but for the list sizes expected,
179             # brute force will probably be fine (and more maintainable)
180             sub _die_if_cycle_found_in_also_list_for_package {
181 1075     1397   2370 my $package = shift;
182 1075         4425 _die_if_also_list_cycles_back_to_existing_stack(
183             [ _also_list_for_package($package) ],
184             [$package],
185             );
186             }
187              
188             sub _die_if_also_list_cycles_back_to_existing_stack {
189 1133     1455   3729 my ( $also_list, $existing_stack ) = @_;
190              
191 1133 100 66     5369 return unless @$also_list && @$existing_stack;
192              
193 45         106 for my $also_member (@$also_list) {
194 61         105 for my $stack_member (@$existing_stack) {
195 88 100       216 next unless $also_member eq $stack_member;
196              
197 2         25 throw_exception( CircularReferenceInAlso => also_parameter => $also_member,
198             stack => $existing_stack
199             );
200             }
201              
202             _die_if_also_list_cycles_back_to_existing_stack(
203 59         119 [ _also_list_for_package($also_member) ],
204             [ $also_member, @$existing_stack ],
205             );
206             }
207             }
208              
209             sub _parse_trait_aliases {
210 1110     1432   2744 my $class = shift;
211 1110         4185 my ($package, $aliases) = @_;
212              
213 1110         2409 my @ret;
214 1110         3528 for my $alias (@$aliases) {
215 3         6 my $name;
216 3 100       13 if (ref($alias)) {
217 2 100       16 reftype($alias) eq 'ARRAY'
218             or throw_exception( InvalidArgumentsToTraitAliases => class_name => $class,
219             package_name => $package,
220             alias => $alias
221             );
222 1         4 ($alias, $name) = @$alias;
223             }
224             else {
225 1         9 ($name = $alias) =~ s/.*:://;
226             }
227 2     326   25 push @ret, set_subname( "${package}::${name}" => sub () {$alias} );
  4         1098  
228             }
229              
230 1109         3294 return @ret;
231             }
232              
233             sub _make_sub_exporter_params {
234 1072     1233   2588 my $class = shift;
235 1072         2180 my $packages = shift;
236 1072         2066 my $export_recorder = shift;
237 1072         2126 my $is_reexport = shift;
238 1072         3472 my $meta_lookup_override = shift;
239              
240 1072         2774 my %exports;
241             my $current_meta_lookup;
242              
243 1072         2332 for my $package ( @{$packages} ) {
  1072         3501  
244 1110 50       4137 my $args = $EXPORT_SPEC{$package}
245             or die "The $package package does not use Moose::Exporter\n";
246              
247 1110   100     5732 $current_meta_lookup = $meta_lookup_override || $args->{meta_lookup};
248 1110         2316 $meta_lookup_override = $current_meta_lookup;
249              
250             my $meta_lookup = $current_meta_lookup
251 1110   100 4563   7717 || sub { Class::MOP::class_of(shift) };
  4405         15135  
252              
253 1110         2733 for my $name ( @{ $args->{with_meta} } ) {
  1110         4417  
254 5375 50       11590 my $sub = $class->_sub_from_package( $package, $name )
255             or next;
256              
257 5388         11474 my $fq_name = $package . '::' . $name;
258              
259             $exports{$name} = $class->_make_wrapped_sub_with_meta(
260             $fq_name,
261             $sub,
262             $export_recorder,
263             $meta_lookup,
264 5388 50       15417 ) unless exists $exports{$name};
265             }
266              
267 1123         3260 for my $name ( @{ $args->{with_caller} } ) {
  1110         4456  
268 3 0       12 my $sub = $class->_sub_from_package( $package, $name )
269             or next;
270              
271 0         0 my $fq_name = $package . '::' . $name;
272              
273             $exports{$name} = $class->_make_wrapped_sub(
274             $fq_name,
275             $sub,
276             $export_recorder,
277 0 0       0 ) unless exists $exports{$name};
278             }
279              
280             my @extra_exports = $class->_parse_trait_aliases(
281             $package, $args->{trait_aliases},
282 1107         6099 );
283 1109         2994 for my $name ( @{ $args->{as_is} }, @extra_exports ) {
  1109         3807  
284 10238         16616 my ( $sub, $coderef_name );
285              
286 10263 100       32480 if ( ref $name ) {
    100          
287 30         95 $sub = $name;
288              
289 2         3 my $coderef_pkg;
290 2         12 ( $coderef_pkg, $coderef_name )
291             = Class::MOP::get_code_info($name);
292              
293 2 50       9 if ( $coderef_pkg ne $package ) {
294 0         0 $is_reexport->{$coderef_name} = 1;
295             }
296             }
297             elsif ( $name =~ /^(.*)::([^:]+)$/ ) {
298 1342 50       7436 $sub = $class->_sub_from_package( "$1", "$2" )
299             or next;
300              
301 1346         3602 $coderef_name = "$2";
302              
303 1346 50       4266 if ( $1 ne $package ) {
304 1346         3586 $is_reexport->{$coderef_name} = 1;
305             }
306             }
307             else {
308 8895 50       16811 $sub = $class->_sub_from_package( $package, $name )
309             or next;
310              
311 8915         14583 $coderef_name = $name;
312             }
313              
314 10259         26262 $export_recorder->{$sub} = 1;
315              
316 28204     28387   1606060 $exports{$coderef_name} = sub { $sub }
317 10263 50       53295 unless exists $exports{$coderef_name};
318             }
319             }
320              
321 1118         7828 return \%exports;
322             }
323              
324             sub _sub_from_package {
325 15649     15810   22315 my $sclass = shift;
326 15649         20523 my $package = shift;
327 15649         19455 my $name = shift;
328              
329 15649         19660 my $sub = do {
330 391     1947   3569 no strict 'refs';
  391         3658  
  391         803147  
331 15649         18184 \&{ $package . '::' . $name };
  15649         44816  
332             };
333              
334 15649 50       49782 return $sub if defined &$sub;
335              
336 0         0 Carp::cluck "Trying to export undefined sub ${package}::${name}";
337              
338 0         0 return;
339             }
340              
341             our $CALLER;
342              
343             sub _make_wrapped_sub {
344 0     161   0 my $self = shift;
345 0         0 my $fq_name = shift;
346 0         0 my $sub = shift;
347 0         0 my $export_recorder = shift;
348              
349             # We need to set the package at import time, so that when
350             # package Foo imports has(), we capture "Foo" as the
351             # package. This lets other packages call Foo::has() and get
352             # the right package. This is done for backwards compatibility
353             # with existing production code, not because this is a good
354             # idea ;)
355             return sub {
356 0     161   0 my $caller = $CALLER;
357              
358 0         0 my $wrapper = $self->_curry_wrapper( $sub, $fq_name, $caller );
359              
360 0         0 my $sub = set_subname( $fq_name => $wrapper );
361              
362 0         0 $export_recorder->{$sub} = 1;
363              
364 0         0 return $sub;
365 0         0 };
366             }
367              
368             sub _make_wrapped_sub_with_meta {
369 5388     5549   8168 my $self = shift;
370 5388         7512 my $fq_name = shift;
371 5388         7193 my $sub = shift;
372 5388         6846 my $export_recorder = shift;
373 5388         6951 my $meta_lookup = shift;
374              
375             return sub {
376 22478     22639   1288263 my $caller = $CALLER;
377              
378 22478         55492 my $wrapper = $self->_late_curry_wrapper(
379             $sub, $fq_name,
380             $meta_lookup => $caller
381             );
382              
383 22478         106026 my $sub = set_subname( $fq_name => $wrapper );
384              
385 22478         79202 $export_recorder->{$sub} = 1;
386              
387 22478         54422 return $sub;
388 5388         26036 };
389             }
390              
391             sub _curry_wrapper {
392 0     161   0 my $class = shift;
393 0         0 my $sub = shift;
394 0         0 my $fq_name = shift;
395 0         0 my @extra = @_;
396              
397 0     161   0 my $wrapper = sub { $sub->( @extra, @_ ) };
  0         0  
398 0 0       0 if ( my $proto = prototype $sub ) {
399              
400             # XXX - Perl's prototype sucks. Use & to make set_prototype
401             # ignore the fact that we're passing "private variables"
402 0         0 &Scalar::Util::set_prototype( $wrapper, $proto );
403             }
404 0         0 return $wrapper;
405             }
406              
407             sub _late_curry_wrapper {
408 22478     22639   30820 my $class = shift;
409 22478         29803 my $sub = shift;
410 22478         29347 my $fq_name = shift;
411 22478         28162 my $extra = shift;
412 22478         41434 my @ex_args = @_;
413              
414             my $wrapper = sub {
415              
416             # resolve curried arguments at runtime via this closure
417 4406     4567 1 230889 my @curry = ( $extra->(@ex_args) );
        4527 1    
        4527 1    
        8771 1    
        12588 1    
        15901 1    
        22635 1    
        23869 1    
        23564 1    
        3077 1    
        2841 1    
        2689 1    
        2497 1    
        2329 1    
        2246 1    
        2174 1    
        2119 1    
        1869 1    
        1721 1    
        1594 1    
        1498 1    
        1367 1    
        1271 1    
        1156 1    
        1041 1    
        966 1    
        966 1    
        966 1    
        966 1    
        966 1    
        805 1    
        805 1    
        805 1    
        805 1    
        805 1    
        805 1    
        805 1    
        644 1    
        644 1    
        483 1    
        483 1    
        322 1    
        161 1    
          1    
          1    
          1    
          1    
          1    
          1    
          1    
          1    
          1    
          1    
          1    
          1    
          1    
          1    
          1    
          1    
          1    
          1    
          1    
          1    
          1    
418 4406         20017 return $sub->( @curry, @_ );
419 22478         90348 };
420              
421 22478 100       53868 if ( my $proto = prototype $sub ) {
422              
423             # XXX - Perl's prototype sucks. Use & to make set_prototype
424             # ignore the fact that we're passing "private variables"
425 1         8 &Scalar::Util::set_prototype( $wrapper, $proto );
426             }
427 22478         47455 return $wrapper;
428             }
429              
430             sub _make_import_sub {
431 1071     25876   2398 shift;
432 1071         2924 my $exporting_package = shift;
433 1071         2648 my $exporter = shift;
434 1071         2213 my $exports_from = shift;
435 1071         2325 my $is_reexport = shift;
436 1071         2649 my $meta_lookup = shift;
437              
438             return sub {
439              
440             # I think we could use Sub::Exporter's collector feature
441             # to do this, but that would be rather gross, since that
442             # feature isn't really designed to return a value to the
443             # caller of the exporter sub.
444             #
445             # Also, this makes sure we preserve backwards compat for
446             # _get_caller, so it always sees the arguments in the
447             # expected order.
448 3630     23978   81130 my $traits;
        20974      
        18895      
        2012      
449 3630         13304 ( $traits, @_ ) = _strip_traits(@_);
450              
451 3630         7137 my $metaclass;
452 3630         10131 ( $metaclass, @_ ) = _strip_metaclass(@_);
453 3630 100 66     14385 $metaclass
454             = Moose::Util::resolve_metaclass_alias( 'Class' => $metaclass )
455             if defined $metaclass && length $metaclass;
456              
457 3630         6340 my $meta_name;
458 3630         9961 ( $meta_name, @_ ) = _strip_meta_name(@_);
459              
460             # Normally we could look at $_[0], but in some weird cases
461             # (involving goto &Moose::import), $_[0] ends as something
462             # else (like Squirrel).
463 3630         8253 my $class = $exporting_package;
464              
465 3630         10825 $CALLER = _get_caller(@_);
466              
467             # this works because both pragmas set $^H (see perldoc
468             # perlvar) which affects the current compilation -
469             # i.e. the file who use'd us - which is why we don't need
470             # to do anything special to make it affect that file
471             # rather than this one (which is already compiled)
472              
473 3630         23261 strict->import;
474 3630         42419 warnings->import;
475              
476 3630         7289 my $did_init_meta;
477 3630         6920 for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
  3645         30599  
  3630         8819  
478              
479             # init_meta can apply a role, which when loaded uses
480             # Moose::Exporter, which in turn sets $CALLER, so we need
481             # to protect against that.
482 2829         7415 local $CALLER = $CALLER;
483 2829         12823 $c->init_meta(
484             for_class => $CALLER,
485             metaclass => $metaclass,
486             meta_name => $meta_name,
487             );
488 2828         8057 $did_init_meta = 1;
489             }
490              
491             {
492             # The metaroles will use Moose::Role, which in turn uses
493             # Moose::Exporter, which in turn sets $CALLER, so we need
494             # to protect against that.
495 3629         7280 local $CALLER = $CALLER;
  3629         7710  
496 3629         14583 _apply_metaroles(
497             $CALLER,
498             [$class, @$exports_from],
499             $meta_lookup
500             );
501             }
502              
503 3629 100 100     14457 if ( $did_init_meta && @{$traits} ) {
  2818 100       9697  
504              
505             # The traits will use Moose::Role, which in turn uses
506             # Moose::Exporter, which in turn sets $CALLER, so we need
507             # to protect against that.
508 39         129 local $CALLER = $CALLER;
509 39         147 _apply_meta_traits( $CALLER, $traits, $meta_lookup );
510             }
511 3590         10683 elsif ( @{$traits} ) {
512 2         16 throw_exception( ClassDoesNotHaveInitMeta => class_name => $class,
513             traits => $traits
514             );
515             }
516              
517 3626         9696 my ( undef, @args ) = @_;
518 3626 50       10445 my $extra = shift @args if ref $args[0] eq 'HASH';
519              
520 3626   100     12426 $extra ||= {};
521 3626 50       10619 if ( !$extra->{into} ) {
522 3626   50     17911 $extra->{into_level} ||= 0;
523 3626         6480 $extra->{into_level}++;
524             }
525              
526 3626         15812 $class->$exporter( $extra, @args );
527 1071         9276 };
528             }
529              
530             sub _strip_option {
531 10890     27390   17882 my $option_name = shift;
532 10890         15705 my $default = shift;
533 10890         27645 for my $i ( 0 .. $#_ - 1 ) {
534 187 100 50     735 if (($_[$i] || '') eq $option_name) {
535 55         203 (undef, my $value) = splice @_, $i, 2;
536 55         236 return ( $value, @_ );
537             }
538             }
539 10835         34113 return ( $default, @_ );
540             }
541              
542             sub _strip_traits {
543 3630     15542   12849 my ($traits, @other) = _strip_option('-traits', [], @_);
544 3630 100       12906 $traits = ref $traits ? $traits : [ $traits ];
545 3630         11935 return ( $traits, @other );
546             }
547              
548             sub _strip_metaclass {
549 3630     14256   8474 _strip_option('-metaclass', undef, @_);
550             }
551              
552             sub _strip_meta_name {
553 3630     13294   8173 _strip_option('-meta_name', 'meta', @_);
554             }
555              
556             sub _apply_metaroles {
557 3629     12543   9505 my ($class, $exports_from, $meta_lookup) = @_;
558              
559 3629         9682 my $metaroles = _collect_metaroles($exports_from);
560 3629         8331 my $base_class_roles = delete $metaroles->{base_class_roles};
561              
562 3629         11082 my $meta = $meta_lookup->($class);
563             # for instance, Moose.pm uses Moose::Util::TypeConstraints
564 3629 100       11712 return unless $meta;
565              
566 2925 100       10119 Moose::Util::MetaRole::apply_metaroles(
567             for => $meta,
568             %$metaroles,
569             ) if keys %$metaroles;
570              
571 2925 100 100     23698 Moose::Util::MetaRole::apply_base_class_roles(
      66        
572             for => $meta,
573             roles => $base_class_roles,
574             ) if $meta->isa('Class::MOP::Class')
575             && $base_class_roles && @$base_class_roles;
576             }
577              
578             sub _collect_metaroles {
579 3629     12049   7613 my ($exports_from) = @_;
580              
581 3629         8648 my @old_style_role_types = map { "${_}_roles" } qw(
  29032         62052  
582             metaclass
583             attribute_metaclass
584             method_metaclass
585             wrapped_method_metaclass
586             instance_metaclass
587             constructor_class
588             destructor_class
589             error_class
590             );
591              
592 3629         15139 my %class_metaroles;
593             my %role_metaroles;
594 3629         7 my @base_class_roles;
595 3629         6 my %old_style_roles;
596              
597 3629         8950 for my $exporter (@$exports_from) {
598 3644         8433 my $data = $EXPORT_SPEC{$exporter};
599              
600 3644 100       11716 if (exists $data->{class_metaroles}) {
601 13         36 for my $type (keys %{ $data->{class_metaroles} }) {
  8         46  
602 11   50     53 push @{ $class_metaroles{$type} ||= [] },
603 11         20 @{ $data->{class_metaroles}{$type} };
  11         39  
604             }
605             }
606              
607 3639 100       10010 if (exists $data->{role_metaroles}) {
608 8         17 for my $type (keys %{ $data->{role_metaroles} }) {
  3         13  
609 4   50     17 push @{ $role_metaroles{$type} ||= [] },
610 4         6 @{ $data->{role_metaroles}{$type} };
  4         12  
611             }
612             }
613              
614 3639 100       9758 if (exists $data->{base_class_roles}) {
615 8         19 push @base_class_roles, @{ $data->{base_class_roles} };
  3         7  
616             }
617              
618 3639         7737 for my $type (@old_style_role_types) {
619 29117 50       57279 if (exists $data->{$type}) {
620 0   0     0 push @{ $old_style_roles{$type} ||= [] },
621 40         81 @{ $data->{$type} };
  0         0  
622             }
623             }
624             }
625              
626             return {
627 3624 100       27945 (keys(%class_metaroles)
    100          
    100          
628             ? (class_metaroles => \%class_metaroles)
629             : ()),
630             (keys(%role_metaroles)
631             ? (role_metaroles => \%role_metaroles)
632             : ()),
633             (@base_class_roles
634             ? (base_class_roles => \@base_class_roles)
635             : ()),
636             %old_style_roles,
637             };
638             }
639              
640             sub _apply_meta_traits {
641 44     7727   163 my ( $class, $traits, $meta_lookup ) = @_;
642              
643 39 50       67 return unless @{$traits};
  39         120  
644              
645 39         100 my $meta = $meta_lookup->($class);
646              
647 39 50       354 my $type = $meta->isa('Moose::Meta::Role') ? 'Role'
    100          
648             : $meta->isa('Class::MOP::Class') ? 'Class'
649             : confess('Cannot determine metaclass type for '
650             . 'trait application. Meta isa '
651             . ref $meta);
652              
653             my @resolved_traits = map {
654 39 100       105 ref $_
  42         202  
655             ? $_
656             : Moose::Util::resolve_metatrait_alias( $type => $_ )
657             } @$traits;
658              
659 39 50       170 return unless @resolved_traits;
660              
661 39         138 my %args = ( for => $class );
662              
663 39 100       215 if ( $meta->isa('Moose::Meta::Role') ) {
664 1         4 $args{role_metaroles} = { role => \@resolved_traits };
665             }
666             else {
667 38         160 $args{class_metaroles} = { class => \@resolved_traits };
668             }
669              
670 39         224 Moose::Util::MetaRole::apply_metaroles(%args);
671             }
672              
673             sub _get_caller {
674              
675             # 1 extra level because it's called by import so there's a layer
676             # of indirection
677 4249     11361   7598 my $offset = 1;
678              
679             return
680             ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
681             : ( ref $_[1] && defined $_[1]->{into_level} )
682             ? caller( $offset + $_[1]->{into_level} )
683 4249 50 33     27323 : caller($offset);
    50 33        
684             }
685              
686             sub _make_unimport_sub {
687 1071     7724   2200 shift;
688 1071         2460 my $exporting_package = shift;
689 1071         4277 my $exports = shift;
690 1071         2223 my $export_recorder = shift;
691 1071         2142 my $is_reexport = shift;
692 1071         2456 my $meta_lookup = shift;
693              
694             return sub {
695 619     6751   21603 my $caller = _get_caller(@_);
        6274      
        5681      
        1921      
696             Moose::Exporter->_remove_keywords(
697             $caller,
698 619         1580 [ keys %{$exports} ],
  619         6176  
699             $export_recorder,
700             $is_reexport,
701             );
702 1071         6057 };
703             }
704              
705             sub _remove_keywords {
706 619     5837   1295 shift;
707 619         1081 my $package = shift;
708 619         1036 my $keywords = shift;
709 619         1019 my $recorded_exports = shift;
710 619         1035 my $is_reexport = shift;
711              
712 391     1767   3728 no strict 'refs';
  391         1166  
  391         38454  
713              
714 619         971 foreach my $name ( @{$keywords} ) {
  619         1613  
715 8779 100       11722 if ( defined &{ $package . '::' . $name } ) {
  8779         32340  
716 8767         10610 my $sub = \&{ $package . '::' . $name };
  8767         21201  
717              
718             # make sure it is from us
719 8767 50       20014 next unless $recorded_exports->{$sub};
720              
721 8767 100       15460 if ( $is_reexport->{$name} ) {
722 391     1664   3188 no strict 'refs';
  391         2244  
  391         149494  
723             next
724             unless _export_is_flagged(
725 1125 100       1650 \*{ join q{::} => $package, $name } );
  1125         6023  
726             }
727              
728             # and if it is from us, then undef the slot
729 8668         10472 delete ${ $package . '::' }{$name};
  8668         80553  
730             }
731             }
732             }
733              
734             # maintain this for now for backcompat
735             # make sure to return a sub to install in the same circumstances as previously
736             # but this functionality now happens at the end of ->import
737             sub _make_init_meta {
738 1071     5199   2289 shift;
739 1071         2675 my $class = shift;
740 1071         2576 my $args = shift;
741 1071         2292 my $meta_lookup = shift;
742              
743 1071         2261 my %old_style_roles;
744 1071         4662 for my $role (
745 8568         20838 map {"${_}_roles"}
746             qw(
747             metaclass
748             attribute_metaclass
749             method_metaclass
750             wrapped_method_metaclass
751             instance_metaclass
752             constructor_class
753             destructor_class
754             error_class
755             )
756             ) {
757             $old_style_roles{$role} = $args->{$role}
758 8568 50       19650 if exists $args->{$role};
759             }
760              
761 1071         4936 my %base_class_roles;
762             %base_class_roles = ( roles => $args->{base_class_roles} )
763 1071 100       5247 if exists $args->{base_class_roles};
764              
765 9         40 my %new_style_roles = map { $_ => $args->{$_} }
766 1071         3720 grep { exists $args->{$_} } qw( class_metaroles role_metaroles );
  2142         7971  
767              
768 1071 50 66     11864 return unless %new_style_roles || %old_style_roles || %base_class_roles;
      66        
769              
770             return sub {
771 9     3800   28 shift;
772 9         42 my %opts = @_;
773 9         33 $meta_lookup->($opts{for_class});
774 8         46 };
775             }
776              
777             sub import {
778 1057     4404   10928 strict->import;
779 1057         46596 warnings->import;
780             }
781              
782             1;
783              
784             # ABSTRACT: make an import() and unimport() just like Moose.pm
785              
786             __END__
787              
788             =pod
789              
790             =encoding UTF-8
791              
792             =head1 NAME
793              
794             Moose::Exporter - make an import() and unimport() just like Moose.pm
795              
796             =head1 VERSION
797              
798             version 2.2205
799              
800             =head1 SYNOPSIS
801              
802             package MyApp::Moose;
803              
804             use Moose ();
805             use Moose::Exporter;
806             use Some::Random ();
807              
808             Moose::Exporter->setup_import_methods(
809             with_meta => [ 'has_rw', 'sugar2' ],
810             as_is => [ 'sugar3', \&Some::Random::thing, 'Some::Random::other_thing' ],
811             also => 'Moose',
812             );
813              
814             sub has_rw {
815             my ( $meta, $name, %options ) = @_;
816             $meta->add_attribute(
817             $name,
818             is => 'rw',
819             %options,
820             );
821             }
822              
823             # then later ...
824             package MyApp::User;
825              
826             use MyApp::Moose;
827              
828             has 'name' => ( is => 'ro' );
829             has_rw 'size';
830             thing;
831             other_thing;
832              
833             no MyApp::Moose;
834              
835             =head1 DESCRIPTION
836              
837             This module encapsulates the exporting of sugar functions in a
838             C<Moose.pm>-like manner. It does this by building custom C<import> and
839             C<unimport> methods for your module, based on a spec you provide.
840              
841             It also lets you "stack" Moose-alike modules so you can export Moose's sugar
842             as well as your own, along with sugar from any random C<MooseX> module, as
843             long as they all use C<Moose::Exporter>. This feature exists to let you bundle
844             a set of MooseX modules into a policy module that developers can use directly
845             instead of using Moose itself.
846              
847             To simplify writing exporter modules, C<Moose::Exporter> also imports
848             C<strict> and C<warnings> into your exporter module, as well as into
849             modules that use it.
850              
851             =head1 METHODS
852              
853             This module provides two public methods:
854              
855             =head2 Moose::Exporter->setup_import_methods(...)
856              
857             When you call this method, C<Moose::Exporter> builds custom C<import> and
858             C<unimport> methods for your module. The C<import> method
859             will export the functions you specify, and can also re-export functions
860             exported by some other module (like C<Moose.pm>). If you pass any parameters
861             for L<Moose::Util::MetaRole>, the C<import> method will also call
862             L<Moose::Util::MetaRole::apply_metaroles|Moose::Util::MetaRole/apply_metaroles> and
863             L<Moose::Util::MetaRole::apply_base_class_roles|Moose::Util::MetaRole/apply_base_class_roles> as needed, after making
864             sure the metaclass is initialized.
865              
866             The C<unimport> method cleans the caller's namespace of all the exported
867             functions. This includes any functions you re-export from other
868             packages. However, if the consumer of your package also imports those
869             functions from the original package, they will I<not> be cleaned.
870              
871             Note that if any of these methods already exist, they will not be
872             overridden, you will have to use C<build_import_methods> to get the
873             coderef that would be installed.
874              
875             This method accepts the following parameters:
876              
877             =over 4
878              
879             =item * with_meta => [ ... ]
880              
881             This list of function I<names only> will be wrapped and then exported. The
882             wrapper will pass the metaclass object for the caller as its first argument.
883              
884             Many sugar functions will need to use this metaclass object to do something to
885             the calling package.
886              
887             =item * as_is => [ ... ]
888              
889             This list of function names or sub references will be exported as-is. You can
890             identify a subroutine by reference, which is handy to re-export some other
891             module's functions directly by reference (C<\&Some::Package::function>).
892              
893             If you do export some other package's function, this function will never be
894             removed by the C<unimport> method. The reason for this is we cannot know if
895             the caller I<also> explicitly imported the sub themselves, and therefore wants
896             to keep it.
897              
898             =item * trait_aliases => [ ... ]
899              
900             This is a list of package names which should have shortened aliases exported,
901             similar to the functionality of L<aliased>. Each element in the list can be
902             either a package name, in which case the export will be named as the last
903             namespace component of the package, or an arrayref, whose first element is the
904             package to alias to, and second element is the alias to export.
905              
906             =item * also => $name or \@names
907              
908             This is a list of modules which contain functions that the caller
909             wants to export. These modules must also use C<Moose::Exporter>. The
910             most common use case will be to export the functions from C<Moose.pm>.
911             Functions specified by C<with_meta> or C<as_is> take precedence over
912             functions exported by modules specified by C<also>, so that a module
913             can selectively override functions exported by another module.
914              
915             C<Moose::Exporter> also makes sure all these functions get removed
916             when C<unimport> is called.
917              
918             =item * meta_lookup => sub { ... }
919              
920             This is a function which will be called to provide the metaclass
921             to be operated upon by the exporter. This is an advanced feature
922             intended for use by package generator modules in the vein of
923             L<MooseX::Role::Parameterized> in order to simplify reusing sugar
924             from other modules that use C<Moose::Exporter>. This function is
925             used, for example, to select the metaclass to bind to functions
926             that are exported using the C<with_meta> option.
927              
928             This function will receive one parameter: the class name into which
929             the sugar is being exported. The default implementation is:
930              
931             sub { Class::MOP::class_of(shift) }
932              
933             Accordingly, this function is expected to return a metaclass.
934              
935             =back
936              
937             You can also provide parameters for L<Moose::Util::MetaRole::apply_metaroles|Moose::Util::MetaRole/apply_metaroles>
938             and L<Moose::Util::MetaRole::apply_base_class_roles|Moose::Util::MetaRole/apply_base_class_roles>. Specifically, valid parameters
939             are "class_metaroles", "role_metaroles", and "base_class_roles".
940              
941             =head2 Moose::Exporter->build_import_methods(...)
942              
943             Returns three code refs, one for C<import>, one for C<unimport> and one for
944             C<init_meta>.
945              
946             Accepts the additional C<install> option, which accepts an arrayref of method
947             names to install into your exporting package. The valid options are C<import>
948             and C<unimport>. Calling C<setup_import_methods> is equivalent
949             to calling C<build_import_methods> with C<< install => [qw(import unimport)] >>
950             except that it doesn't also return the methods.
951              
952             The C<import> method is built using L<Sub::Exporter>. This means that it can
953             take a hashref of the form C<< { into => $package } >> to specify the package
954             it operates on.
955              
956             Used by C<setup_import_methods>.
957              
958             =head1 IMPORTING AND init_meta
959              
960             If you want to set an alternative base object class or metaclass class, see
961             above for details on how this module can call L<Moose::Util::MetaRole> for
962             you.
963              
964             If you want to do something that is not supported by this module, simply
965             define an C<init_meta> method in your class. The C<import> method that
966             C<Moose::Exporter> generates for you will call this method (if it exists). It
967             will always pass the caller to this method via the C<for_class> parameter.
968              
969             Most of the time, your C<init_meta> method will probably just call C<<
970             Moose->init_meta >> to do the real work:
971              
972             sub init_meta {
973             shift; # our class name
974             return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
975             }
976              
977             =head1 METACLASS TRAITS
978              
979             The C<import> method generated by C<Moose::Exporter> will allow the
980             user of your module to specify metaclass traits in a C<-traits>
981             parameter passed as part of the import:
982              
983             use Moose -traits => 'My::Meta::Trait';
984              
985             use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
986              
987             These traits will be applied to the caller's metaclass
988             instance. Providing traits for an exporting class that does not create
989             a metaclass for the caller is an error.
990              
991             =head1 BUGS
992              
993             See L<Moose/BUGS> for details on reporting bugs.
994              
995             =head1 AUTHORS
996              
997             =over 4
998              
999             =item *
1000              
1001             Stevan Little <stevan@cpan.org>
1002              
1003             =item *
1004              
1005             Dave Rolsky <autarch@urth.org>
1006              
1007             =item *
1008              
1009             Jesse Luehrs <doy@cpan.org>
1010              
1011             =item *
1012              
1013             Shawn M Moore <sartak@cpan.org>
1014              
1015             =item *
1016              
1017             יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
1018              
1019             =item *
1020              
1021             Karen Etheridge <ether@cpan.org>
1022              
1023             =item *
1024              
1025             Florian Ragwitz <rafl@debian.org>
1026              
1027             =item *
1028              
1029             Hans Dieter Pearcey <hdp@cpan.org>
1030              
1031             =item *
1032              
1033             Chris Prather <chris@prather.org>
1034              
1035             =item *
1036              
1037             Matt S Trout <mstrout@cpan.org>
1038              
1039             =back
1040              
1041             =head1 COPYRIGHT AND LICENSE
1042              
1043             This software is copyright (c) 2006 by Infinity Interactive, Inc.
1044              
1045             This is free software; you can redistribute it and/or modify it under
1046             the same terms as the Perl 5 programming language system itself.
1047              
1048             =cut