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