Link to MX::Types here
[gitmo/Moose.git] / lib / Moose / Exporter.pm
1 package Moose::Exporter;
2
3 use strict;
4 use warnings;
5
6 our $VERSION   = '0.71';
7 $VERSION = eval $VERSION;
8 our $AUTHORITY = 'cpan:STEVAN';
9
10 use Class::MOP;
11 use List::MoreUtils qw( first_index uniq );
12 use Moose::Util::MetaRole;
13 use Sub::Exporter;
14
15
16 my %EXPORT_SPEC;
17
18 sub setup_import_methods {
19     my ( $class, %args ) = @_;
20
21     my $exporting_package = $args{exporting_package} ||= caller();
22
23     my ( $import, $unimport ) = $class->build_import_methods(%args);
24
25     no strict 'refs';
26     *{ $exporting_package . '::import' }   = $import;
27     *{ $exporting_package . '::unimport' } = $unimport;
28 }
29
30 sub build_import_methods {
31     my ( $class, %args ) = @_;
32
33     my $exporting_package = $args{exporting_package} ||= caller();
34
35     $EXPORT_SPEC{$exporting_package} = \%args;
36
37     my @exports_from = $class->_follow_also( $exporting_package );
38
39     my $export_recorder = {};
40
41     my ( $exports, $is_removable )
42         = $class->_make_sub_exporter_params(
43         [ @exports_from, $exporting_package ], $export_recorder );
44
45     my $exporter = Sub::Exporter::build_exporter(
46         {
47             exports => $exports,
48             groups  => { default => [':all'] }
49         }
50     );
51
52     # $args{_export_to_main} exists for backwards compat, because
53     # Moose::Util::TypeConstraints did export to main (unlike Moose &
54     # Moose::Role).
55     my $import = $class->_make_import_sub( $exporting_package, $exporter,
56         \@exports_from, $args{_export_to_main} );
57
58     my $unimport = $class->_make_unimport_sub( $exporting_package, $exports,
59         $is_removable, $export_recorder );
60
61     return ( $import, $unimport )
62 }
63
64 {
65     my $seen = {};
66
67     sub _follow_also {
68         my $class             = shift;
69         my $exporting_package = shift;
70
71         local %$seen = ( $exporting_package => 1 );
72
73         return uniq( _follow_also_real($exporting_package) );
74     }
75
76     sub _follow_also_real {
77         my $exporting_package = shift;
78
79         die "Package in also ($exporting_package) does not seem to use Moose::Exporter"
80             unless exists $EXPORT_SPEC{$exporting_package};
81
82         my $also = $EXPORT_SPEC{$exporting_package}{also};
83
84         return unless defined $also;
85
86         my @also = ref $also ? @{$also} : $also;
87
88         for my $package (@also)
89         {
90             die "Circular reference in also parameter to Moose::Exporter between $exporting_package and $package"
91                 if $seen->{$package};
92
93             $seen->{$package} = 1;
94         }
95
96         return @also, map { _follow_also_real($_) } @also;
97     }
98 }
99
100 sub _make_sub_exporter_params {
101     my $class             = shift;
102     my $packages          = shift;
103     my $export_recorder   = shift;
104
105     my %exports;
106     my %is_removable;
107
108     for my $package ( @{$packages} ) {
109         my $args = $EXPORT_SPEC{$package}
110             or die "The $package package does not use Moose::Exporter\n";
111
112         for my $name ( @{ $args->{with_caller} } ) {
113             my $sub = do {
114                 no strict 'refs';
115                 \&{ $package . '::' . $name };
116             };
117
118             my $fq_name = $package . '::' . $name;
119
120             $exports{$name} = $class->_make_wrapped_sub(
121                 $fq_name,
122                 $sub,
123                 $export_recorder,
124             );
125
126             $is_removable{$name} = 1;
127         }
128
129         for my $name ( @{ $args->{as_is} } ) {
130             my $sub;
131
132             if ( ref $name ) {
133                 $sub  = $name;
134
135                 # Even though Moose re-exports things from Carp &
136                 # Scalar::Util, we don't want to remove those at
137                 # unimport time, because the importing package may
138                 # have imported them explicitly ala
139                 #
140                 # use Carp qw( confess );
141                 #
142                 # This is a hack. Since we can't know whether they
143                 # really want to keep these subs or not, we err on the
144                 # safe side and leave them in.
145                 my $coderef_pkg;
146                 ( $coderef_pkg, $name ) = Class::MOP::get_code_info($name);
147
148                 $is_removable{$name} = $coderef_pkg eq $package ? 1 : 0;
149             }
150             else {
151                 $sub = do {
152                     no strict 'refs';
153                     \&{ $package . '::' . $name };
154                 };
155
156                 $is_removable{$name} = 1;
157             }
158
159             $export_recorder->{$sub} = 1;
160
161             $exports{$name} = sub {$sub};
162         }
163     }
164
165     return ( \%exports, \%is_removable );
166 }
167
168 our $CALLER;
169
170 sub _make_wrapped_sub {
171     my $self            = shift;
172     my $fq_name         = shift;
173     my $sub             = shift;
174     my $export_recorder = shift;
175
176     # We need to set the package at import time, so that when
177     # package Foo imports has(), we capture "Foo" as the
178     # package. This lets other packages call Foo::has() and get
179     # the right package. This is done for backwards compatibility
180     # with existing production code, not because this is a good
181     # idea ;)
182     return sub {
183         my $caller = $CALLER;
184
185         my $wrapper = $self->_make_wrapper($caller, $sub, $fq_name);
186
187         my $sub = Class::MOP::subname($fq_name => $wrapper);
188
189         $export_recorder->{$sub} = 1;
190
191         return $sub;
192     };
193 }
194
195 sub _make_wrapper {
196     shift;
197     my $caller  = shift;
198     my $sub     = shift;
199     my $fq_name = shift;
200
201     return sub { $sub->($caller, @_) };
202 }
203
204 sub _make_import_sub {
205     shift;
206     my $exporting_package = shift;
207     my $exporter          = shift;
208     my $exports_from      = shift;
209     my $export_to_main    = shift;
210
211     return sub {
212
213         # I think we could use Sub::Exporter's collector feature
214         # to do this, but that would be rather gross, since that
215         # feature isn't really designed to return a value to the
216         # caller of the exporter sub.
217         #
218         # Also, this makes sure we preserve backwards compat for
219         # _get_caller, so it always sees the arguments in the
220         # expected order.
221         my $traits;
222         ( $traits, @_ ) = _strip_traits(@_);
223
224         # Normally we could look at $_[0], but in some weird cases
225         # (involving goto &Moose::import), $_[0] ends as something
226         # else (like Squirrel).
227         my $class = $exporting_package;
228
229         $CALLER = _get_caller(@_);
230
231         # this works because both pragmas set $^H (see perldoc
232         # perlvar) which affects the current compilation -
233         # i.e. the file who use'd us - which is why we don't need
234         # to do anything special to make it affect that file
235         # rather than this one (which is already compiled)
236
237         strict->import;
238         warnings->import;
239
240         # we should never export to main
241         if ( $CALLER eq 'main' && !$export_to_main ) {
242             warn
243                 qq{$class does not export its sugar to the 'main' package.\n};
244             return;
245         }
246
247         my $did_init_meta;
248         for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
249             # init_meta can apply a role, which when loaded uses
250             # Moose::Exporter, which in turn sets $CALLER, so we need
251             # to protect against that.
252             local $CALLER = $CALLER;
253             $c->init_meta( for_class => $CALLER );
254             $did_init_meta = 1;
255         }
256
257         if ( $did_init_meta && @{$traits} ) {
258             # The traits will use Moose::Role, which in turn uses
259             # Moose::Exporter, which in turn sets $CALLER, so we need
260             # to protect against that.
261             local $CALLER = $CALLER;
262             _apply_meta_traits( $CALLER, $traits );
263         }
264         elsif ( @{$traits} ) {
265             Moose->throw_error(
266                 "Cannot provide traits when $class does not have an init_meta() method"
267             );
268         }
269
270         goto $exporter;
271     };
272 }
273
274
275 sub _strip_traits {
276     my $idx = first_index { $_ eq '-traits' } @_;
277
278     return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
279
280     my $traits = $_[ $idx + 1 ];
281
282     splice @_, $idx, 2;
283
284     $traits = [ $traits ] unless ref $traits;
285
286     return ( $traits, @_ );
287 }
288
289 sub _apply_meta_traits {
290     my ( $class, $traits ) = @_;
291
292     return unless @{$traits};
293
294     my $meta = $class->meta();
295
296     my $type = ( split /::/, ref $meta )[-1]
297         or Moose->throw_error(
298         'Cannot determine metaclass type for trait application . Meta isa '
299         . ref $meta );
300
301     my @resolved_traits
302         = map { Moose::Util::resolve_metatrait_alias( $type => $_ ) }
303         @$traits;
304
305     return unless @resolved_traits;
306
307     Moose::Util::MetaRole::apply_metaclass_roles(
308         for_class       => $class,
309         metaclass_roles => \@resolved_traits,
310     );
311 }
312
313 sub _get_caller {
314     # 1 extra level because it's called by import so there's a layer
315     # of indirection
316     my $offset = 1;
317
318     return
319           ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
320         : ( ref $_[1] && defined $_[1]->{into_level} )
321         ? caller( $offset + $_[1]->{into_level} )
322         : caller($offset);
323 }
324
325 sub _make_unimport_sub {
326     shift;
327     my $exporting_package = shift;
328     my $exports           = shift;
329     my $is_removable      = shift;
330     my $export_recorder   = shift;
331
332     return sub {
333         my $caller = scalar caller();
334         Moose::Exporter->_remove_keywords(
335             $caller,
336             [ keys %{$exports} ],
337             $is_removable,
338             $export_recorder,
339         );
340     };
341 }
342
343 sub _remove_keywords {
344     shift;
345     my $package          = shift;
346     my $keywords         = shift;
347     my $is_removable     = shift;
348     my $recorded_exports = shift;
349
350     no strict 'refs';
351
352     foreach my $name ( @{ $keywords } ) {
353         next unless $is_removable->{$name};
354
355         if ( defined &{ $package . '::' . $name } ) {
356             my $sub = \&{ $package . '::' . $name };
357
358             # make sure it is from us
359             next unless $recorded_exports->{$sub};
360
361             # and if it is from us, then undef the slot
362             delete ${ $package . '::' }{$name};
363         }
364     }
365 }
366
367 1;
368
369 __END__
370
371 =head1 NAME
372
373 Moose::Exporter - make an import() and unimport() just like Moose.pm
374
375 =head1 SYNOPSIS
376
377   package MyApp::Moose;
378
379   use strict;
380   use warnings;
381
382   use Moose ();
383   use Moose::Exporter;
384
385   Moose::Exporter->setup_import_methods(
386       with_caller => [ 'has_rw', 'sugar2' ],
387       as_is       => [ 'sugar3', \&Some::Random::thing ],
388       also        => 'Moose',
389   );
390
391   sub has_rw {
392       my ($caller, $name, %options) = @_;
393       Class::MOP::Class->initialize($caller)->add_attribute($name,
394           is => 'rw',
395           %options,
396       );
397   }
398
399   # then later ...
400   package MyApp::User;
401
402   use MyApp::Moose;
403
404   has 'name';
405   has_rw 'size';
406   thing;
407
408   no MyApp::Moose;
409
410 =head1 DESCRIPTION
411
412 This module encapsulates the logic to export sugar functions like
413 C<Moose.pm>. It does this by building custom C<import> and C<unimport>
414 methods for your module, based on a spec your provide.
415
416 It also lets your "stack" Moose-alike modules so you can export
417 Moose's sugar as well as your own, along with sugar from any random
418 C<MooseX> module, as long as they all use C<Moose::Exporter>.
419
420 =head1 METHODS
421
422 This module provides two public methods:
423
424 =head2 Moose::Exporter->setup_import_methods(...)
425
426 When you call this method, C<Moose::Exporter> build custom C<import>
427 and C<unimport> methods for your module. The import method will export
428 the functions you specify, and you can also tell it to export
429 functions exported by some other module (like C<Moose.pm>).
430
431 The C<unimport> method cleans the callers namespace of all the
432 exported functions.
433
434 This method accepts the following parameters:
435
436 =over 4
437
438 =item * with_caller => [ ... ]
439
440 This a list of function I<names only> to be exported wrapped and then
441 exported. The wrapper will pass the name of the calling package as the
442 first argument to the function. Many sugar functions need to know
443 their caller so they can get the calling package's metaclass object.
444
445 =item * as_is => [ ... ]
446
447 This a list of function names or sub references to be exported
448 as-is. You can identify a subroutine by reference, which is handy to
449 re-export some other module's functions directly by reference
450 (C<\&Some::Package::function>).
451
452 If you do export some other packages function, this function will
453 never be removed by the C<unimport> method. The reason for this is we
454 cannot know if the caller I<also> explicitly imported the sub
455 themselves, and therefore wants to keep it.
456
457 =item * also => $name or \@names
458
459 This is a list of modules which contain functions that the caller
460 wants to export. These modules must also use C<Moose::Exporter>. The
461 most common use case will be to export the functions from C<Moose.pm>.
462 Functions specified by C<with_caller> or C<as_is> take precedence over
463 functions exported by modules specified by C<also>, so that a module
464 can selectively override functions exported by another module.
465
466 C<Moose::Exporter> also makes sure all these functions get removed
467 when C<unimport> is called.
468
469 =back
470
471 =head2 Moose::Exporter->build_import_methods(...)
472
473 Returns two code refs, one for import and one for unimport.
474
475 Used by C<setup_import_methods>.
476
477 =head1 IMPORTING AND init_meta
478
479 If you want to set an alternative base object class or metaclass
480 class, simply define an C<init_meta> method in your class. The
481 C<import> method that C<Moose::Exporter> generates for you will call
482 this method (if it exists). It will always pass the caller to this
483 method via the C<for_class> parameter.
484
485 Most of the time, your C<init_meta> method will probably just call C<<
486 Moose->init_meta >> to do the real work:
487
488   sub init_meta {
489       shift; # our class name
490       return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
491   }
492
493 =head1 METACLASS TRAITS
494
495 The C<import> method generated by C<Moose::Exporter> will allow the
496 user of your module to specify metaclass traits in a C<-traits>
497 parameter passed as part of the import:
498
499   use Moose -traits => 'My::Meta::Trait';
500
501   use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
502
503 These traits will be applied to the caller's metaclass
504 instance. Providing traits for an exporting class that does not create
505 a metaclass for the caller is an error.
506
507 =head1 AUTHOR
508
509 Dave Rolsky E<lt>autarch@urth.orgE<gt>
510
511 This is largely a reworking of code in Moose.pm originally written by
512 Stevan Little and others.
513
514 =head1 COPYRIGHT AND LICENSE
515
516 Copyright 2009 by Infinity Interactive, Inc.
517
518 L<http://www.iinteractive.com>
519
520 This library is free software; you can redistribute it and/or modify
521 it under the same terms as Perl itself.
522
523 =cut