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