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