File Coverage

blib/lib/Moose/Exporter.pm
Criterion Covered Total %
statement 366 368 99.4
branch 104 120 86.6
condition 47 61 77.0
subroutine 103 103 100.0
pod 65 66 98.4
total 685 718 95.4


line stmt bran cond sub pod time code
1             package Moose::Exporter;
2             our $VERSION = '2.2203';
3              
4 402     23125   258383 use strict;
  402         865  
  402         11302  
5 402     9175   1908 use warnings;
  402         730  
  402         11217  
6              
7 402     8169   20219 use Class::Load qw(is_class_loaded);
  402         716594  
  402         15837  
8 402     4643   154016 use Class::MOP;
  402         1336  
  402         20393  
9 402     4299   2882 use List::Util 1.45 qw( uniq );
  402         8532  
  402         26536  
10 402     3466   176736 use Moose::Util::MetaRole;
  402         978  
  402         14497  
11 402     2891   2473 use Scalar::Util 1.40 qw(reftype);
  402         9319  
  402         19812  
12 402     2779   2827 use Sub::Exporter 0.980;
  402         5733  
  402         2034  
13 402     2629   72273 use Sub::Util 1.40 qw(set_subname);
  402         5701  
  402         16910  
14              
15 402     2303   2152 use Moose::Util 'throw_exception';
  402         824  
  402         1559  
16              
17             my %EXPORT_SPEC;
18              
19             sub setup_import_methods {
20 1123     2306 1 130622 my ( $class, %args ) = @_;
21              
22 1123   66     10188 $args{exporting_package} ||= caller();
23              
24 1123         8180 $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 1125     2209 1 5730 my ( $class, %args ) = @_;
36              
37 1125   66     4247 my $exporting_package = $args{exporting_package} ||= caller();
38              
39 1125   100 8428   9120 my $meta_lookup = $args{meta_lookup} || sub { Class::MOP::class_of(shift) };
  7444         20013  
40              
41 1125         3339 $EXPORT_SPEC{$exporting_package} = \%args;
42              
43 1125         4843 my @exports_from = $class->_follow_also($exporting_package);
44              
45 1119         2738 my $export_recorder = {};
46 1119         2282 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 1119         6767 );
54              
55 1118         6014 my $exporter = $class->_make_exporter(
56             $exports,
57             $is_reexport,
58             $meta_lookup,
59             );
60              
61 1118         617724 my %methods;
62 1118         5910 $methods{import} = $class->_make_import_sub(
63             $exporting_package,
64             $exporter,
65             \@exports_from,
66             $is_reexport,
67             $meta_lookup,
68             );
69              
70 1118         8515 $methods{unimport} = $class->_make_unimport_sub(
71             $exporting_package,
72             $exports,
73             $export_recorder,
74             $is_reexport,
75             $meta_lookup,
76             );
77              
78 1118         5405 $methods{init_meta} = $class->_make_init_meta(
79             $exporting_package,
80             \%args,
81             $meta_lookup,
82             );
83              
84 1118         10938 my $package = Class::MOP::Package->initialize($exporting_package);
85 1118 50       2348 for my $to_install ( @{ $args{install} || [] } ) {
  1118         9836  
86 3352         7711 my $symbol = '&' . $to_install;
87              
88             next
89 3352 100 66     13174 unless $methods{$to_install}
90             && !$package->has_package_symbol($symbol);
91             $package->add_package_symbol(
92             $symbol,
93             set_subname( $exporting_package . '::'
94 2244         18132 . $to_install => $methods{$to_install} )
95             );
96             }
97              
98 1118         6259 return ( $methods{import}, $methods{unimport}, $methods{init_meta} );
99             }
100              
101             sub _make_exporter {
102 1118     2058   4402 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 3697     4589   32933 my ($arg, $to_export) = @_;
110 3697         9361 my $meta = $meta_lookup->($arg->{into});
111              
112 3697 100       11427 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 2979         5290 my @filtered_to_export;
119             my %installed;
120 2979         6043 for (my $i = 0; $i < @{ $to_export }; $i += 2) {
  41716         71601  
121 38705         44795 my ($as, $cv) = @{ $to_export }[$i, $i + 1];
  38740         57530  
122              
123 38740 100 100     114787 next if !ref($as)
      100        
124             && $meta->has_package_symbol('&' . $as)
125             && $meta->get_package_symbol('&' . $as) == $cv;
126              
127 38285         68817 push @filtered_to_export, $as, $cv;
128 38285 100       84699 $installed{$as} = 1 unless ref $as;
129             }
130              
131 3017         11230 Sub::Exporter::default_installer($arg, \@filtered_to_export);
132              
133 2979         1609790 for my $name ( keys %{$is_reexport} ) {
  2979         107269  
134 402     2183   281367 no strict 'refs';
  402         946  
  402         14925  
135 402     2031   2344 no warnings 'once';
  402         823  
  402         427777  
136 5721 100       39138 next unless exists $installed{$name};
137 5481         7126 _flag_as_reexport( \*{ join q{::}, $arg->{into}, $name } );
  5481         906718  
138             }
139             },
140             }
141 1118         17084 );
142             }
143              
144             sub _follow_also {
145 1131     2017   2733 my $class = shift;
146 1125         2120 my $exporting_package = shift;
147              
148 1125         4308 _die_if_cycle_found_in_also_list_for_package($exporting_package);
149              
150 1119         4377 return uniq( _follow_also_real($exporting_package) );
151             }
152              
153             sub _follow_also_real {
154 1198     2055   2497 my $exporting_package = shift;
155 1198         2821 my @also = _also_list_for_package($exporting_package);
156              
157 1198         6148 return map { $_, _follow_also_real($_) } @also;
  79         157  
158             }
159              
160             sub _also_list_for_package {
161 2408     3205   3609 my $package = shift;
162              
163 2408 100       5868 if ( !exists $EXPORT_SPEC{$package} ) {
164 3         18 my $loaded = is_class_loaded($package);
165              
166 3         13 throw_exception( PackageDoesNotUseMooseExporter => package => $package,
167             is_loaded => $loaded
168             );
169             }
170              
171 2405         4218 my $also = $EXPORT_SPEC{$package}{also};
172              
173 2405 100       9123 return unless defined $also;
174              
175 134 100       459 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 1125     1447   2200 my $package = shift;
182 1125         4047 _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 1207     1529   3219 my ( $also_list, $existing_stack ) = @_;
190              
191 1207 100 66     4922 return unless @$also_list && @$existing_stack;
192              
193 70         159 for my $also_member (@$also_list) {
194 88         148 for my $stack_member (@$existing_stack) {
195 122 100       242 next unless $also_member eq $stack_member;
196              
197 3         17 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 85         146 [ _also_list_for_package($also_member) ],
204             [ $also_member, @$existing_stack ],
205             );
206             }
207             }
208              
209             sub _parse_trait_aliases {
210 1180     1502   2452 my $class = shift;
211 1180         4171 my ($package, $aliases) = @_;
212              
213 1180         2223 my @ret;
214 1180         3177 for my $alias (@$aliases) {
215 3         5 my $name;
216 3 100       23 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         7 ($name = $alias) =~ s/.*:://;
226             }
227 2     326   41 push @ret, set_subname( "${package}::${name}" => sub () {$alias} );
  4         1101  
228             }
229              
230 1179         2985 return @ret;
231             }
232              
233             sub _make_sub_exporter_params {
234 1119     1280   2322 my $class = shift;
235 1119         2041 my $packages = shift;
236 1119         1930 my $export_recorder = shift;
237 1119         1890 my $is_reexport = shift;
238 1119         3083 my $meta_lookup_override = shift;
239              
240 1119         2494 my %exports;
241             my $current_meta_lookup;
242              
243 1119         2156 for my $package ( @{$packages} ) {
  1119         3142  
244 1180 50       3662 my $args = $EXPORT_SPEC{$package}
245             or die "The $package package does not use Moose::Exporter\n";
246              
247 1180   100     5081 $current_meta_lookup = $meta_lookup_override || $args->{meta_lookup};
248 1180         2088 $meta_lookup_override = $current_meta_lookup;
249              
250             my $meta_lookup = $current_meta_lookup
251 1180   100 4626   6871 || sub { Class::MOP::class_of(shift) };
  4468         13390  
252              
253 1180         2456 for my $name ( @{ $args->{with_meta} } ) {
  1180         3888  
254 5646 100       10543 my $sub = $class->_sub_from_package( $package, $name )
255             or next;
256              
257 5658         10649 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 5658 100       14001 ) unless exists $exports{$name};
265             }
266              
267 1193         2681 for my $name ( @{ $args->{with_caller} } ) {
  1180         3811  
268 5 50       12 my $sub = $class->_sub_from_package( $package, $name )
269             or next;
270              
271 2         5 my $fq_name = $package . '::' . $name;
272              
273             $exports{$name} = $class->_make_wrapped_sub(
274             $fq_name,
275             $sub,
276             $export_recorder,
277 2 50       7 ) unless exists $exports{$name};
278             }
279              
280             my @extra_exports = $class->_parse_trait_aliases(
281             $package, $args->{trait_aliases},
282 1177         5545 );
283 1179         2736 for my $name ( @{ $args->{as_is} }, @extra_exports ) {
  1179         3546  
284 10568         14721 my ( $sub, $coderef_name );
285              
286 10593 100       28199 if ( ref $name ) {
    100          
287 31         69 $sub = $name;
288              
289 3         5 my $coderef_pkg;
290 3         23 ( $coderef_pkg, $coderef_name )
291             = Class::MOP::get_code_info($name);
292              
293 3 100       11 if ( $coderef_pkg ne $package ) {
294 1         3 $is_reexport->{$coderef_name} = 1;
295             }
296             }
297             elsif ( $name =~ /^(.*)::([^:]+)$/ ) {
298 1401 50       6754 $sub = $class->_sub_from_package( "$1", "$2" )
299             or next;
300              
301 1405         3126 $coderef_name = "$2";
302              
303 1405 50       3736 if ( $1 ne $package ) {
304 1405         3134 $is_reexport->{$coderef_name} = 1;
305             }
306             }
307             else {
308 9165 50       15066 $sub = $class->_sub_from_package( $package, $name )
309             or next;
310              
311 9185         12446 $coderef_name = $name;
312             }
313              
314 10589         22285 $export_recorder->{$sub} = 1;
315              
316 28708     28891   1341958 $exports{$coderef_name} = sub { $sub }
317 10593 50       46408 unless exists $exports{$coderef_name};
318             }
319             }
320              
321 1165         6050 return \%exports;
322             }
323              
324             sub _sub_from_package {
325 16251     16412   20266 my $sclass = shift;
326 16251         17840 my $package = shift;
327 16251         17586 my $name = shift;
328              
329 16251         17117 my $sub = do {
330 402     1989   3144 no strict 'refs';
  402         959  
  402         712734  
331 16251         16444 \&{ $package . '::' . $name };
  16251         40466  
332             };
333              
334 16251 100       44759 return $sub if defined &$sub;
335              
336 1         287 Carp::cluck "Trying to export undefined sub ${package}::${name}";
337              
338 1         513 return;
339             }
340              
341             our $CALLER;
342              
343             sub _make_wrapped_sub {
344 2     163   3 my $self = shift;
345 2         4 my $fq_name = shift;
346 2         3 my $sub = shift;
347 2         3 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 2     163   37 my $caller = $CALLER;
357              
358 2         6 my $wrapper = $self->_curry_wrapper( $sub, $fq_name, $caller );
359              
360 2         8 my $sub = set_subname( $fq_name => $wrapper );
361              
362 2         5 $export_recorder->{$sub} = 1;
363              
364 2         4 return $sub;
365 2         8 };
366             }
367              
368             sub _make_wrapped_sub_with_meta {
369 5641     5802   7459 my $self = shift;
370 5641         6723 my $fq_name = shift;
371 5641         6412 my $sub = shift;
372 5641         6424 my $export_recorder = shift;
373 5641         6459 my $meta_lookup = shift;
374              
375             return sub {
376 22899     23060   1178050 my $caller = $CALLER;
377              
378 22899         47390 my $wrapper = $self->_late_curry_wrapper(
379             $sub, $fq_name,
380             $meta_lookup => $caller
381             );
382              
383 22899         93510 my $sub = set_subname( $fq_name => $wrapper );
384              
385 22899         62340 $export_recorder->{$sub} = 1;
386              
387 22899         49076 return $sub;
388 5641         22622 };
389             }
390              
391             sub _curry_wrapper {
392 2     163   3 my $class = shift;
393 2         3 my $sub = shift;
394 2         3 my $fq_name = shift;
395 2         3 my @extra = @_;
396              
397 2     162   5 my $wrapper = sub { $sub->( @extra, @_ ) };
  1         2870  
398 2 100       5 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 1         9 &Scalar::Util::set_prototype( $wrapper, $proto );
403             }
404 2         4 return $wrapper;
405             }
406              
407             sub _late_curry_wrapper {
408 22899     23060   28108 my $class = shift;
409 22899         26406 my $sub = shift;
410 22899         25960 my $fq_name = shift;
411 22899         25533 my $extra = shift;
412 22899         36936 my @ex_args = @_;
413              
414             my $wrapper = sub {
415              
416             # resolve curried arguments at runtime via this closure
417 4469     4630 1 270285 my @curry = ( $extra->(@ex_args) );
        4589 1    
        4589 1    
        8892 1    
        12754 1    
        16116 1    
        22926 1    
        24200 1    
        23850 1    
        3122 1    
        2885 1    
        2733 1    
        2541 1    
        2373 1    
        2290 1    
        2218 1    
        2163 1    
        1877 1    
        1729 1    
        1602 1    
        1506 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    
          0    
418 4469         16297 return $sub->( @curry, @_ );
419 22899         77990 };
420              
421 22899 100       47500 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 2         13 &Scalar::Util::set_prototype( $wrapper, $proto );
426             }
427 22899         42681 return $wrapper;
428             }
429              
430             sub _make_import_sub {
431 1118     26237   2279 shift;
432 1118         2626 my $exporting_package = shift;
433 1118         2342 my $exporter = shift;
434 1118         2029 my $exports_from = shift;
435 1118         2036 my $is_reexport = shift;
436 1118         2278 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 3703     24333   86414 my $traits;
        21280      
        19192      
        2020      
449 3703         11934 ( $traits, @_ ) = _strip_traits(@_);
450              
451 3703         6215 my $metaclass;
452 3703         8907 ( $metaclass, @_ ) = _strip_metaclass(@_);
453 3703 100 66     11849 $metaclass
454             = Moose::Util::resolve_metaclass_alias( 'Class' => $metaclass )
455             if defined $metaclass && length $metaclass;
456              
457 3703         5484 my $meta_name;
458 3703         8557 ( $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 3703         6862 my $class = $exporting_package;
464              
465 3703         9492 $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 3703         20680 strict->import;
474 3703         37509 warnings->import;
475              
476 3703         6574 my $did_init_meta;
477 3703         6076 for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
  3740         26228  
  3703         7918  
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 2897         6334 local $CALLER = $CALLER;
483 2897         11465 $c->init_meta(
484             for_class => $CALLER,
485             metaclass => $metaclass,
486             meta_name => $meta_name,
487             );
488 2894         7215 $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 3700         6508 local $CALLER = $CALLER;
  3700         6611  
496 3700         12427 _apply_metaroles(
497             $CALLER,
498             [$class, @$exports_from],
499             $meta_lookup
500             );
501             }
502              
503 3700 100 100     12248 if ( $did_init_meta && @{$traits} ) {
  2873 100       8628  
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         103 local $CALLER = $CALLER;
509 39         130 _apply_meta_traits( $CALLER, $traits, $meta_lookup );
510             }
511 3661         9577 elsif ( @{$traits} ) {
512 2         10 throw_exception( ClassDoesNotHaveInitMeta => class_name => $class,
513             traits => $traits
514             );
515             }
516              
517 3697         8474 my ( undef, @args ) = @_;
518 3697 100       9401 my $extra = shift @args if ref $args[0] eq 'HASH';
519              
520 3697   100     13000 $extra ||= {};
521 3697 50       9458 if ( !$extra->{into} ) {
522 3697   100     16231 $extra->{into_level} ||= 0;
523 3697         5918 $extra->{into_level}++;
524             }
525              
526 3697         13572 $class->$exporter( $extra, @args );
527 1118         8111 };
528             }
529              
530             sub _strip_option {
531 11109     27881   16147 my $option_name = shift;
532 11109         14258 my $default = shift;
533 11109         23504 for my $i ( 0 .. $#_ - 1 ) {
534 190 100 50     655 if (($_[$i] || '') eq $option_name) {
535 55         163 (undef, my $value) = splice @_, $i, 2;
536 55         216 return ( $value, @_ );
537             }
538             }
539 11054         29338 return ( $default, @_ );
540             }
541              
542             sub _strip_traits {
543 3703     15831   11640 my ($traits, @other) = _strip_option('-traits', [], @_);
544 3703 100       11536 $traits = ref $traits ? $traits : [ $traits ];
545 3703         10847 return ( $traits, @other );
546             }
547              
548             sub _strip_metaclass {
549 3703     14545   7559 _strip_option('-metaclass', undef, @_);
550             }
551              
552             sub _strip_meta_name {
553 3703     13583   7183 _strip_option('-meta_name', 'meta', @_);
554             }
555              
556             sub _apply_metaroles {
557 3700     12794   8354 my ($class, $exports_from, $meta_lookup) = @_;
558              
559 3700         8692 my $metaroles = _collect_metaroles($exports_from);
560 3700         7137 my $base_class_roles = delete $metaroles->{base_class_roles};
561              
562 3700         9534 my $meta = $meta_lookup->($class);
563             # for instance, Moose.pm uses Moose::Util::TypeConstraints
564 3700 100       9859 return unless $meta;
565              
566 2980 100       8959 Moose::Util::MetaRole::apply_metaroles(
567             for => $meta,
568             %$metaroles,
569             ) if keys %$metaroles;
570              
571 2980 100 100     21406 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 3700     12300   6939 my ($exports_from) = @_;
580              
581 3700         7698 my @old_style_role_types = map { "${_}_roles" } qw(
  29600         55318  
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 3700         12892 my %class_metaroles;
593             my %role_metaroles;
594 3700         7 my @base_class_roles;
595 3700         7 my %old_style_roles;
596              
597 3700         7904 for my $exporter (@$exports_from) {
598 3735         7445 my $data = $EXPORT_SPEC{$exporter};
599              
600 3735 100       10827 if (exists $data->{class_metaroles}) {
601 13         33 for my $type (keys %{ $data->{class_metaroles} }) {
  8         31  
602 11   50     51 push @{ $class_metaroles{$type} ||= [] },
603 11         18 @{ $data->{class_metaroles}{$type} };
  11         33  
604             }
605             }
606              
607 3730 100       8987 if (exists $data->{role_metaroles}) {
608 8         19 for my $type (keys %{ $data->{role_metaroles} }) {
  3         9  
609 4   50     17 push @{ $role_metaroles{$type} ||= [] },
610 4         5 @{ $data->{role_metaroles}{$type} };
  4         9  
611             }
612             }
613              
614 3730 100       8533 if (exists $data->{base_class_roles}) {
615 9         17 push @base_class_roles, @{ $data->{base_class_roles} };
  4         9  
616             }
617              
618 3730         6973 for my $type (@old_style_role_types) {
619 29845 50       50122 if (exists $data->{$type}) {
620 0   0     0 push @{ $old_style_roles{$type} ||= [] },
621 40         63 @{ $data->{$type} };
  0         0  
622             }
623             }
624             }
625              
626             return {
627 3695 100       24000 (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     7871   136 my ( $class, $traits, $meta_lookup ) = @_;
642              
643 39 50       69 return unless @{$traits};
  39         126  
644              
645 39         88 my $meta = $meta_lookup->($class);
646              
647 39 50       289 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       89 ref $_
  42         176  
655             ? $_
656             : Moose::Util::resolve_metatrait_alias( $type => $_ )
657             } @$traits;
658              
659 39 50       151 return unless @resolved_traits;
660              
661 39         131 my %args = ( for => $class );
662              
663 39 100       203 if ( $meta->isa('Moose::Meta::Role') ) {
664 1         4 $args{role_metaroles} = { role => \@resolved_traits };
665             }
666             else {
667 38         130 $args{class_metaroles} = { class => \@resolved_traits };
668             }
669              
670 39         196 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 4331     11587   6753 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 4331 100 66     24835 : caller($offset);
    50 66        
684             }
685              
686             sub _make_unimport_sub {
687 1118     7879   2062 shift;
688 1118         2155 my $exporting_package = shift;
689 1118         3765 my $exports = shift;
690 1118         2073 my $export_recorder = shift;
691 1118         2065 my $is_reexport = shift;
692 1118         2315 my $meta_lookup = shift;
693              
694             return sub {
695 628     6832   26439 my $caller = _get_caller(@_);
        6319      
        5726      
        1929      
696             Moose::Exporter->_remove_keywords(
697             $caller,
698 628         1449 [ keys %{$exports} ],
  628         5390  
699             $export_recorder,
700             $is_reexport,
701             );
702 1118         5529 };
703             }
704              
705             sub _remove_keywords {
706 628     5892   1165 shift;
707 628         1083 my $package = shift;
708 628         967 my $keywords = shift;
709 628         893 my $recorded_exports = shift;
710 628         981 my $is_reexport = shift;
711              
712 402     1809   3416 no strict 'refs';
  402         1025  
  402         33407  
713              
714 628         959 foreach my $name ( @{$keywords} ) {
  628         1470  
715 8900 100       10525 if ( defined &{ $package . '::' . $name } ) {
  8900         28934  
716 8888         9750 my $sub = \&{ $package . '::' . $name };
  8888         19223  
717              
718             # make sure it is from us
719 8888 50       18241 next unless $recorded_exports->{$sub};
720              
721 8888 100       14057 if ( $is_reexport->{$name} ) {
722 402     1706   2781 no strict 'refs';
  402         934  
  402         130843  
723             next
724             unless _export_is_flagged(
725 1145 100       1445 \*{ join q{::} => $package, $name } );
  1145         5448  
726             }
727              
728             # and if it is from us, then undef the slot
729 8789         9442 delete ${ $package . '::' }{$name};
  8789         71930  
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 1118     5255   2386 shift;
739 1118         2396 my $class = shift;
740 1118         2434 my $args = shift;
741 1118         2114 my $meta_lookup = shift;
742              
743 1118         1969 my %old_style_roles;
744 1118         3990 for my $role (
745 8944         17968 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 8944 50       17133 if exists $args->{$role};
759             }
760              
761 1118         4353 my %base_class_roles;
762             %base_class_roles = ( roles => $args->{base_class_roles} )
763 1118 100       3987 if exists $args->{base_class_roles};
764              
765 11         44 my %new_style_roles = map { $_ => $args->{$_} }
766 1118         2921 grep { exists $args->{$_} } qw( class_metaroles role_metaroles );
  2236         7043  
767              
768 1118 100 66     10179 return unless %new_style_roles || %old_style_roles || %base_class_roles;
      100        
769              
770             return sub {
771 10     3809   26 shift;
772 10         41 my %opts = @_;
773 10         44 $meta_lookup->($opts{for_class});
774 10         54 };
775             }
776              
777             sub import {
778 1096     4451   10871 strict->import;
779 1096         41565 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.2203
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