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