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