Commit | Line | Data |
5bd4db9b |
1 | package Moose::Exporter; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use Class::MOP; |
4403da90 |
7 | use List::MoreUtils qw( uniq ); |
5bd4db9b |
8 | use Sub::Exporter; |
9 | |
10 | |
0338a411 |
11 | my %EXPORT_SPEC; |
1a601f52 |
12 | |
a5c426fc |
13 | sub build_import_methods { |
14 | my $class = shift; |
15 | my %args = @_; |
16 | |
17 | my $exporting_package = caller(); |
18 | |
0338a411 |
19 | $EXPORT_SPEC{$exporting_package} = \%args; |
a5c426fc |
20 | |
4403da90 |
21 | my @exports_from = $class->_follow_also( $exporting_package ); |
22 | |
23 | my $exports |
24 | = $class->_process_exports( $exporting_package, @exports_from ); |
f5324cca |
25 | |
26 | my $exporter = Sub::Exporter::build_exporter( |
27 | { |
28 | exports => $exports, |
29 | groups => { default => [':all'] } |
30 | } |
1a601f52 |
31 | ); |
a5c426fc |
32 | |
42c391b1 |
33 | my $import = $class->_make_import_sub( $exporter, \@exports_from ); |
a5c426fc |
34 | |
f5324cca |
35 | my $unimport = $class->_make_unimport_sub( [ keys %{$exports} ] ); |
a5c426fc |
36 | |
37 | no strict 'refs'; |
1a601f52 |
38 | *{ $exporting_package . '::import' } = $import; |
a5c426fc |
39 | *{ $exporting_package . '::unimport' } = $unimport; |
40 | } |
41 | |
4403da90 |
42 | { |
43 | my %seen; |
5bd4db9b |
44 | |
4403da90 |
45 | sub _follow_also { |
46 | my $class = shift; |
47 | my $exporting_package = shift; |
5bd4db9b |
48 | |
4403da90 |
49 | %seen = ( $exporting_package => 1 ); |
97a93056 |
50 | |
4403da90 |
51 | return uniq( _follow_also_real($exporting_package) ); |
97a93056 |
52 | } |
53 | |
4403da90 |
54 | sub _follow_also_real { |
55 | my $exporting_package = shift; |
56 | |
57 | die "Package in also ($exporting_package) does not seem to use MooseX::Exporter" |
58 | unless exists $EXPORT_SPEC{$exporting_package}; |
59 | |
60 | my $also = $EXPORT_SPEC{$exporting_package}{also}; |
61 | |
62 | return unless defined $also; |
63 | |
64 | my @also = ref $also ? @{$also} : $also; |
65 | |
66 | for my $package (@also) |
67 | { |
68 | die "Circular reference in also parameter to MooseX::Exporter between $exporting_package and $package" |
69 | if $seen{$package}; |
97a93056 |
70 | |
4403da90 |
71 | $seen{$package} = 1; |
5bd4db9b |
72 | } |
4403da90 |
73 | |
74 | return @also, map { _follow_also_real($_) } @also; |
75 | } |
76 | } |
77 | |
78 | sub _process_exports { |
79 | my $class = shift; |
80 | my @packages = @_; |
81 | |
82 | my %exports; |
83 | |
84 | for my $package (@packages) { |
85 | my $args = $EXPORT_SPEC{$package} |
86 | or die "The $package package does not use Moose::Exporter\n"; |
87 | |
88 | for my $name ( @{ $args->{with_caller} } ) { |
89 | my $sub = do { |
e05b7c8e |
90 | no strict 'refs'; |
4403da90 |
91 | \&{ $package . '::' . $name }; |
e05b7c8e |
92 | }; |
4403da90 |
93 | |
94 | $exports{$name} = $class->_make_wrapped_sub( |
95 | $package, |
96 | $name, |
97 | $sub |
98 | ); |
5bd4db9b |
99 | } |
100 | |
4403da90 |
101 | for my $name ( @{ $args->{as_is} } ) { |
102 | my $sub; |
103 | |
104 | if ( ref $name ) { |
105 | $sub = $name; |
106 | $name = ( Class::MOP::get_code_info($name) )[1]; |
107 | } |
108 | else { |
109 | $sub = do { |
110 | no strict 'refs'; |
111 | \&{ $package . '::' . $name }; |
112 | }; |
113 | } |
114 | |
115 | $exports{$name} = sub {$sub}; |
116 | } |
5bd4db9b |
117 | } |
118 | |
f5324cca |
119 | return \%exports; |
5bd4db9b |
120 | } |
121 | |
e05b7c8e |
122 | { |
123 | # This variable gets closed over in each export _generator_. Then |
124 | # in the generator we grab the value and close over it _again_ in |
125 | # the real export, so it gets captured each time the generator |
126 | # runs. |
127 | # |
128 | # In the meantime, we arrange for the import method we generate to |
129 | # set this variable to the caller each time it is called. |
130 | # |
131 | # This is all a bit confusing, but it works. |
132 | my $CALLER; |
133 | |
134 | sub _make_wrapped_sub { |
135 | my $class = shift; |
136 | my $exporting_package = shift; |
137 | my $name = shift; |
138 | my $sub = shift; |
1a601f52 |
139 | |
e05b7c8e |
140 | # We need to set the package at import time, so that when |
141 | # package Foo imports has(), we capture "Foo" as the |
142 | # package. This lets other packages call Foo::has() and get |
143 | # the right package. This is done for backwards compatibility |
144 | # with existing production code, not because this is a good |
145 | # idea ;) |
146 | return sub { |
147 | my $caller = $CALLER; |
148 | Class::MOP::subname( $exporting_package . '::' |
149 | . $name => sub { $sub->( $caller, @_ ) } ); |
150 | }; |
151 | } |
f5324cca |
152 | |
e05b7c8e |
153 | sub _make_import_sub { |
42c391b1 |
154 | shift; |
155 | my $exporter = shift; |
156 | my $exports_from = shift; |
1a601f52 |
157 | |
e05b7c8e |
158 | return sub { |
1a601f52 |
159 | |
e05b7c8e |
160 | # It's important to leave @_ as-is for the benefit of |
161 | # Sub::Exporter. |
162 | my $class = $_[0]; |
1a601f52 |
163 | |
e05b7c8e |
164 | $CALLER = Moose::Exporter::_get_caller(@_); |
1a601f52 |
165 | |
e05b7c8e |
166 | # this works because both pragmas set $^H (see perldoc |
167 | # perlvar) which affects the current compilation - |
168 | # i.e. the file who use'd us - which is why we don't need |
169 | # to do anything special to make it affect that file |
170 | # rather than this one (which is already compiled) |
171 | |
172 | strict->import; |
173 | warnings->import; |
174 | |
175 | # we should never export to main |
176 | if ( $CALLER eq 'main' ) { |
177 | warn |
178 | qq{$class does not export its sugar to the 'main' package.\n}; |
179 | return; |
180 | } |
1a601f52 |
181 | |
42c391b1 |
182 | for my $c (grep { $_->can('init_meta') } $class, @{$exports_from} ) { |
183 | |
184 | $c->init_meta( for_class => $CALLER ); |
e05b7c8e |
185 | } |
186 | |
187 | goto $exporter; |
188 | }; |
189 | } |
1a601f52 |
190 | } |
191 | |
192 | sub _get_caller { |
193 | # 1 extra level because it's called by import so there's a layer |
194 | # of indirection |
195 | my $offset = 1; |
196 | |
197 | return |
198 | ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into} |
199 | : ( ref $_[1] && defined $_[1]->{into_level} ) |
200 | ? caller( $offset + $_[1]->{into_level} ) |
201 | : caller($offset); |
202 | } |
203 | |
204 | sub _make_unimport_sub { |
205 | my $class = shift; |
206 | my $exported = shift; |
207 | |
1a601f52 |
208 | return sub { |
2c9c8797 |
209 | my $caller = scalar caller(); |
210 | Moose::Exporter->_remove_keywords( $caller, $exported ); |
1a601f52 |
211 | }; |
212 | } |
213 | |
2c9c8797 |
214 | sub _remove_keywords { |
215 | shift; |
216 | my $package = shift; |
217 | my $keywords = shift; |
218 | |
219 | no strict 'refs'; |
220 | |
221 | # loop through the keywords ... |
222 | foreach my $name ( @{$keywords} ) { |
223 | |
224 | # if we find one ... |
225 | if ( defined &{ $package . '::' . $name } ) { |
226 | my $keyword = \&{ $package . '::' . $name }; |
227 | |
228 | # make sure it is from us |
229 | my ($pkg_name) = Class::MOP::get_code_info($keyword); |
230 | next if $pkg_name eq $package; |
231 | |
232 | # and if it is from us, then undef the slot |
233 | delete ${ $package . '::' }{$name}; |
234 | } |
235 | } |
236 | } |
237 | |
5bd4db9b |
238 | 1; |
2f29843c |
239 | |
240 | __END__ |
241 | |
242 | =head1 NAME |
243 | |
244 | Moose::Exporter - make an import() and unimport() just like Moose.pm |
245 | |
246 | =head1 SYNOPSIS |
247 | |
248 | package MyApp::Moose; |
249 | |
250 | use strict; |
251 | use warnings; |
252 | |
253 | use Moose (); |
254 | use Moose::Exporter; |
255 | |
256 | Moose::Exporter->build_export_methods( |
257 | export => [ 'sugar1', 'sugar2', \&Some::Random::thing ], |
258 | init_meta_args => { metaclass_class => 'MyApp::Meta::Class' ], |
259 | ); |
260 | |
261 | # then later ... |
262 | package MyApp::User; |
263 | |
264 | use MyApp::Moose; |
265 | |
266 | has 'name'; |
267 | sugar1 'do your thing'; |
268 | thing; |
269 | |
270 | no MyApp::Moose; |
271 | |
272 | =head1 DESCRIPTION |
273 | |
274 | This module encapsulates the logic to export sugar functions like |
275 | C<Moose.pm>. It does this by building custom C<import> and C<unimport> |
276 | methods for your module, based on a spec your provide. |
277 | |
278 | It also lets your "stack" Moose-alike modules so you can export |
279 | Moose's sugar as well as your own, along with sugar from any random |
280 | C<MooseX> module, as long as they all use C<Moose::Exporter>. |
281 | |
282 | =head1 METHODS |
283 | |
284 | This module provides exactly one public method: |
285 | |
286 | =head2 Moose::Exporter->build_import_methods(...) |
287 | |
288 | When you call this method, C<Moose::Exporter> build custom C<import> |
289 | and C<unimport> methods for your module. The import method will export |
290 | the functions you specify, and you can also tell it to export |
291 | functions exported by some other module (like C<Moose.pm>). |
292 | |
293 | The C<unimport> method cleans the callers namespace of all the |
294 | exported functions. |
295 | |
296 | This method accepts the following parameters: |
297 | |
298 | =over 4 |
299 | |
97a93056 |
300 | =item * with_caller => [ ... ] |
301 | |
302 | This a list of function I<names only> to be exported wrapped and then |
303 | exported. The wrapper will pass the name of the calling package as the |
304 | first argument to the function. Many sugar functions need to know |
305 | their caller so they can get the calling package's metaclass object. |
306 | |
307 | =item * as_is => [ ... ] |
2f29843c |
308 | |
309 | This a list of function names or sub references to be exported |
310 | as-is. You can identify a subroutine by reference, which is handy to |
311 | re-export some other module's functions directly by reference |
312 | (C<\&Some::Package::function>). |
313 | |
314 | =item * init_meta_args |
315 | |
316 | ... |
317 | |
318 | =back |
319 | |
320 | =head1 AUTHOR |
321 | |
322 | Dave Rolsky E<lt>autarch@urth.orgE<gt> |
323 | |
324 | This is largely a reworking of code in Moose.pm originally written by |
325 | Stevan Little and others. |
326 | |
327 | =head1 COPYRIGHT AND LICENSE |
328 | |
329 | Copyright 2008 by Infinity Interactive, Inc. |
330 | |
331 | L<http://www.iinteractive.com> |
332 | |
333 | This library is free software; you can redistribute it and/or modify |
334 | it under the same terms as Perl itself. |
335 | |
336 | =cut |