ignore generated recipes
[gitmo/Moose.git] / lib / Moose / Exporter.pm
CommitLineData
e606ae5f 1package Moose::Exporter;
2
3use strict;
4use warnings;
5
dc39b850 6our $VERSION = '0.70';
ae18d5ec 7$VERSION = eval $VERSION;
8our $AUTHORITY = 'cpan:STEVAN';
9
e606ae5f 10use Class::MOP;
11use List::MoreUtils qw( first_index uniq );
12use Moose::Util::MetaRole;
13use Sub::Exporter;
14
15
16my %EXPORT_SPEC;
17
18sub 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
30sub 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
e05fb8ae 41 my ( $exports, $is_removable )
42 = $class->_make_sub_exporter_params(
e606ae5f 43 [ $exporting_package, @exports_from ], $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,
e05fb8ae 59 $is_removable, $export_recorder );
e606ae5f 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
f5d03831 79 die "Package in also ($exporting_package) does not seem to use Moose::Exporter"
e606ae5f 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 {
f5d03831 90 die "Circular reference in also parameter to Moose::Exporter between $exporting_package and $package"
e606ae5f 91 if $seen->{$package};
92
93 $seen->{$package} = 1;
94 }
95
96 return @also, map { _follow_also_real($_) } @also;
97 }
98}
99
100sub _make_sub_exporter_params {
101 my $class = shift;
102 my $packages = shift;
103 my $export_recorder = shift;
104
105 my %exports;
e05fb8ae 106 my %is_removable;
e606ae5f 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 );
e05fb8ae 125
126 $is_removable{$name} = 1;
e606ae5f 127 }
128
129 for my $name ( @{ $args->{as_is} } ) {
130 my $sub;
131
132 if ( ref $name ) {
133 $sub = $name;
e05fb8ae 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;
e606ae5f 149 }
150 else {
151 $sub = do {
152 no strict 'refs';
153 \&{ $package . '::' . $name };
154 };
e05fb8ae 155
156 $is_removable{$name} = 1;
e606ae5f 157 }
158
159 $export_recorder->{$sub} = 1;
160
161 $exports{$name} = sub {$sub};
162 }
163 }
164
e05fb8ae 165 return ( \%exports, \%is_removable );
e606ae5f 166}
167
96bb13ea 168our $CALLER;
169
170sub _make_wrapped_sub {
b4f00a34 171 my $self = shift;
96bb13ea 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
b4f00a34 185 my $wrapper = $self->_make_wrapper($caller, $sub, $fq_name);
186
187 my $sub = Class::MOP::subname($fq_name => $wrapper);
96bb13ea 188
189 $export_recorder->{$sub} = 1;
190
191 return $sub;
192 };
193}
e606ae5f 194
b4f00a34 195sub _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
96bb13ea 204sub _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 }
e606ae5f 246
96bb13ea 247 my $did_init_meta;
248 for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
816208bc 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.
fdeb8354 252 local $CALLER = $CALLER;
96bb13ea 253 $c->init_meta( for_class => $CALLER );
254 $did_init_meta = 1;
255 }
e606ae5f 256
96bb13ea 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 }
e606ae5f 269
96bb13ea 270 goto $exporter;
271 };
e606ae5f 272}
273
96bb13ea 274
e606ae5f 275sub _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
289sub _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]
c245d69b 297 or Moose->throw_error(
e606ae5f 298 'Cannot determine metaclass type for trait application . Meta isa '
4c0b3599 299 . ref $meta );
e606ae5f 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
313sub _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
325sub _make_unimport_sub {
326 shift;
327 my $exporting_package = shift;
328 my $exports = shift;
e05fb8ae 329 my $is_removable = shift;
e606ae5f 330 my $export_recorder = shift;
331
332 return sub {
333 my $caller = scalar caller();
334 Moose::Exporter->_remove_keywords(
335 $caller,
336 [ keys %{$exports} ],
e05fb8ae 337 $is_removable,
e606ae5f 338 $export_recorder,
339 );
340 };
341}
342
343sub _remove_keywords {
344 shift;
345 my $package = shift;
346 my $keywords = shift;
e05fb8ae 347 my $is_removable = shift;
e606ae5f 348 my $recorded_exports = shift;
349
350 no strict 'refs';
351
352 foreach my $name ( @{ $keywords } ) {
e05fb8ae 353 next unless $is_removable->{$name};
e606ae5f 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
3671;
368
369__END__
370
371=head1 NAME
372
373Moose::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(
82ad7804 386 with_caller => [ 'has_rw', 'sugar2' ],
e606ae5f 387 as_is => [ 'sugar3', \&Some::Random::thing ],
388 also => 'Moose',
389 );
390
82ad7804 391 sub has_rw {
6daad0b9 392 my ($caller, $name, %options) = @_;
82ad7804 393 Class::MOP::Class->initialize($caller)->add_attribute($name,
394 is => 'rw',
395 %options,
396 );
397 }
398
e606ae5f 399 # then later ...
400 package MyApp::User;
401
402 use MyApp::Moose;
403
404 has 'name';
6daad0b9 405 has_rw 'size';
e606ae5f 406 thing;
407
408 no MyApp::Moose;
409
410=head1 DESCRIPTION
411
412This module encapsulates the logic to export sugar functions like
413C<Moose.pm>. It does this by building custom C<import> and C<unimport>
414methods for your module, based on a spec your provide.
415
416It also lets your "stack" Moose-alike modules so you can export
417Moose's sugar as well as your own, along with sugar from any random
418C<MooseX> module, as long as they all use C<Moose::Exporter>.
419
420=head1 METHODS
421
422This module provides two public methods:
423
424=head2 Moose::Exporter->setup_import_methods(...)
425
426When you call this method, C<Moose::Exporter> build custom C<import>
427and C<unimport> methods for your module. The import method will export
428the functions you specify, and you can also tell it to export
429functions exported by some other module (like C<Moose.pm>).
430
431The C<unimport> method cleans the callers namespace of all the
432exported functions.
433
434This method accepts the following parameters:
435
436=over 4
437
438=item * with_caller => [ ... ]
439
440This a list of function I<names only> to be exported wrapped and then
441exported. The wrapper will pass the name of the calling package as the
442first argument to the function. Many sugar functions need to know
443their caller so they can get the calling package's metaclass object.
444
445=item * as_is => [ ... ]
446
447This a list of function names or sub references to be exported
448as-is. You can identify a subroutine by reference, which is handy to
449re-export some other module's functions directly by reference
450(C<\&Some::Package::function>).
451
e05fb8ae 452If you do export some other packages function, this function will
453never be removed by the C<unimport> method. The reason for this is we
454cannot know if the caller I<also> explicitly imported the sub
455themselves, and therefore wants to keep it.
456
e606ae5f 457=item * also => $name or \@names
458
459This is a list of modules which contain functions that the caller
460wants to export. These modules must also use C<Moose::Exporter>. The
461most common use case will be to export the functions from C<Moose.pm>.
462
463C<Moose::Exporter> also makes sure all these functions get removed
464when C<unimport> is called.
465
466=back
467
468=head2 Moose::Exporter->build_import_methods(...)
469
470Returns two code refs, one for import and one for unimport.
471
472Used by C<setup_import_methods>.
473
474=head1 IMPORTING AND init_meta
475
476If you want to set an alternative base object class or metaclass
477class, simply define an C<init_meta> method in your class. The
478C<import> method that C<Moose::Exporter> generates for you will call
479this method (if it exists). It will always pass the caller to this
480method via the C<for_class> parameter.
481
482Most of the time, your C<init_meta> method will probably just call C<<
483Moose->init_meta >> to do the real work:
484
485 sub init_meta {
486 shift; # our class name
487 return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
488 }
489
490=head1 METACLASS TRAITS
491
492The C<import> method generated by C<Moose::Exporter> will allow the
493user of your module to specify metaclass traits in a C<-traits>
494parameter passed as part of the import:
495
496 use Moose -traits => 'My::Meta::Trait';
497
498 use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
499
500These traits will be applied to the caller's metaclass
501instance. Providing traits for an exporting class that does not create
502a metaclass for the caller is an error.
503
504=head1 AUTHOR
505
506Dave Rolsky E<lt>autarch@urth.orgE<gt>
507
508This is largely a reworking of code in Moose.pm originally written by
509Stevan Little and others.
510
511=head1 COPYRIGHT AND LICENSE
512
2840a3b2 513Copyright 2009 by Infinity Interactive, Inc.
e606ae5f 514
515L<http://www.iinteractive.com>
516
517This library is free software; you can redistribute it and/or modify
518it under the same terms as Perl itself.
519
520=cut