It turns out namespace::clean's different semantics break some code
[gitmo/Moose.git] / lib / Moose / Exporter.pm
CommitLineData
5bd4db9b 1package Moose::Exporter;
2
3use strict;
4use warnings;
5
6use Class::MOP;
4403da90 7use List::MoreUtils qw( uniq );
5bd4db9b 8use Sub::Exporter;
9
10
0338a411 11my %EXPORT_SPEC;
1a601f52 12
a5c426fc 13sub 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
78sub _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
192sub _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
204sub _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 214sub _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 2381;
2f29843c 239
240__END__
241
242=head1 NAME
243
244Moose::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
274This module encapsulates the logic to export sugar functions like
275C<Moose.pm>. It does this by building custom C<import> and C<unimport>
276methods for your module, based on a spec your provide.
277
278It also lets your "stack" Moose-alike modules so you can export
279Moose's sugar as well as your own, along with sugar from any random
280C<MooseX> module, as long as they all use C<Moose::Exporter>.
281
282=head1 METHODS
283
284This module provides exactly one public method:
285
286=head2 Moose::Exporter->build_import_methods(...)
287
288When you call this method, C<Moose::Exporter> build custom C<import>
289and C<unimport> methods for your module. The import method will export
290the functions you specify, and you can also tell it to export
291functions exported by some other module (like C<Moose.pm>).
292
293The C<unimport> method cleans the callers namespace of all the
294exported functions.
295
296This method accepts the following parameters:
297
298=over 4
299
97a93056 300=item * with_caller => [ ... ]
301
302This a list of function I<names only> to be exported wrapped and then
303exported. The wrapper will pass the name of the calling package as the
304first argument to the function. Many sugar functions need to know
305their caller so they can get the calling package's metaclass object.
306
307=item * as_is => [ ... ]
2f29843c 308
309This a list of function names or sub references to be exported
310as-is. You can identify a subroutine by reference, which is handy to
311re-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
322Dave Rolsky E<lt>autarch@urth.orgE<gt>
323
324This is largely a reworking of code in Moose.pm originally written by
325Stevan Little and others.
326
327=head1 COPYRIGHT AND LICENSE
328
329Copyright 2008 by Infinity Interactive, Inc.
330
331L<http://www.iinteractive.com>
332
333This library is free software; you can redistribute it and/or modify
334it under the same terms as Perl itself.
335
336=cut