1 package Moose::Exporter;
7 $VERSION = eval $VERSION;
8 our $AUTHORITY = 'cpan:STEVAN';
11 use List::MoreUtils qw( first_index uniq );
12 use Moose::Util::MetaRole;
14 use Sub::Name qw(subname);
18 sub setup_import_methods {
19 my ( $class, %args ) = @_;
21 my $exporting_package = $args{exporting_package} ||= caller();
23 my ( $import, $unimport ) = $class->build_import_methods(%args);
26 *{ $exporting_package . '::import' } = $import;
27 *{ $exporting_package . '::unimport' } = $unimport;
30 sub build_import_methods {
31 my ( $class, %args ) = @_;
33 my $exporting_package = $args{exporting_package} ||= caller();
35 $EXPORT_SPEC{$exporting_package} = \%args;
37 my @exports_from = $class->_follow_also( $exporting_package );
39 my $export_recorder = {};
41 my ( $exports, $is_removable )
42 = $class->_make_sub_exporter_params(
43 [ @exports_from, $exporting_package ], $export_recorder );
45 my $exporter = Sub::Exporter::build_exporter(
48 groups => { default => [':all'] }
52 # $args{_export_to_main} exists for backwards compat, because
53 # Moose::Util::TypeConstraints did export to main (unlike Moose &
55 my $import = $class->_make_import_sub( $exporting_package, $exporter,
56 \@exports_from, $args{_export_to_main} );
58 my $unimport = $class->_make_unimport_sub( $exporting_package, $exports,
59 $is_removable, $export_recorder );
61 return ( $import, $unimport )
69 my $exporting_package = shift;
71 local %$seen = ( $exporting_package => 1 );
73 return uniq( _follow_also_real($exporting_package) );
76 sub _follow_also_real {
77 my $exporting_package = shift;
79 if (!exists $EXPORT_SPEC{$exporting_package}) {
80 my $loaded = Class::MOP::is_class_loaded($exporting_package);
82 die "Package in also ($exporting_package) does not seem to "
83 . "use Moose::Exporter"
84 . ($loaded ? "" : " (is it loaded?)");
87 my $also = $EXPORT_SPEC{$exporting_package}{also};
89 return unless defined $also;
91 my @also = ref $also ? @{$also} : $also;
93 for my $package (@also)
95 die "Circular reference in also parameter to Moose::Exporter between $exporting_package and $package"
98 $seen->{$package} = 1;
101 return @also, map { _follow_also_real($_) } @also;
105 sub _make_sub_exporter_params {
107 my $packages = shift;
108 my $export_recorder = shift;
113 for my $package ( @{$packages} ) {
114 my $args = $EXPORT_SPEC{$package}
115 or die "The $package package does not use Moose::Exporter\n";
117 for my $name ( @{ $args->{with_caller} } ) {
120 \&{ $package . '::' . $name };
123 my $fq_name = $package . '::' . $name;
125 $exports{$name} = $class->_make_wrapped_sub(
131 $is_removable{$name} = 1;
134 for my $name ( @{ $args->{as_is} } ) {
140 # Even though Moose re-exports things from Carp &
141 # Scalar::Util, we don't want to remove those at
142 # unimport time, because the importing package may
143 # have imported them explicitly ala
145 # use Carp qw( confess );
147 # This is a hack. Since we can't know whether they
148 # really want to keep these subs or not, we err on the
149 # safe side and leave them in.
151 ( $coderef_pkg, $name ) = Class::MOP::get_code_info($name);
153 $is_removable{$name} = $coderef_pkg eq $package ? 1 : 0;
158 \&{ $package . '::' . $name };
161 $is_removable{$name} = 1;
164 $export_recorder->{$sub} = 1;
166 $exports{$name} = sub {$sub};
170 return ( \%exports, \%is_removable );
175 sub _make_wrapped_sub {
179 my $export_recorder = shift;
181 # We need to set the package at import time, so that when
182 # package Foo imports has(), we capture "Foo" as the
183 # package. This lets other packages call Foo::has() and get
184 # the right package. This is done for backwards compatibility
185 # with existing production code, not because this is a good
188 my $caller = $CALLER;
190 my $wrapper = $self->_curry_wrapper($sub, $fq_name, $caller);
192 my $sub = subname($fq_name => $wrapper);
194 $export_recorder->{$sub} = 1;
206 my $wrapper = sub { $sub->(@extra, @_) };
207 if (my $proto = prototype $sub) {
208 # XXX - Perl's prototype sucks. Use & to make set_prototype
209 # ignore the fact that we're passing "private variables"
210 &Scalar::Util::set_prototype($wrapper, $proto);
215 sub _make_import_sub {
217 my $exporting_package = shift;
218 my $exporter = shift;
219 my $exports_from = shift;
220 my $export_to_main = shift;
224 # I think we could use Sub::Exporter's collector feature
225 # to do this, but that would be rather gross, since that
226 # feature isn't really designed to return a value to the
227 # caller of the exporter sub.
229 # Also, this makes sure we preserve backwards compat for
230 # _get_caller, so it always sees the arguments in the
233 ( $traits, @_ ) = _strip_traits(@_);
236 ( $metaclass, @_ ) = _strip_metaclass(@_);
238 # Normally we could look at $_[0], but in some weird cases
239 # (involving goto &Moose::import), $_[0] ends as something
240 # else (like Squirrel).
241 my $class = $exporting_package;
243 $CALLER = _get_caller(@_);
245 # this works because both pragmas set $^H (see perldoc
246 # perlvar) which affects the current compilation -
247 # i.e. the file who use'd us - which is why we don't need
248 # to do anything special to make it affect that file
249 # rather than this one (which is already compiled)
254 # we should never export to main
255 if ( $CALLER eq 'main' && !$export_to_main ) {
257 qq{$class does not export its sugar to the 'main' package.\n};
262 for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
263 # init_meta can apply a role, which when loaded uses
264 # Moose::Exporter, which in turn sets $CALLER, so we need
265 # to protect against that.
266 local $CALLER = $CALLER;
267 $c->init_meta( for_class => $CALLER, metaclass => $metaclass );
271 if ( $did_init_meta && @{$traits} ) {
272 # The traits will use Moose::Role, which in turn uses
273 # Moose::Exporter, which in turn sets $CALLER, so we need
274 # to protect against that.
275 local $CALLER = $CALLER;
276 _apply_meta_traits( $CALLER, $traits );
278 elsif ( @{$traits} ) {
281 "Cannot provide traits when $class does not have an init_meta() method"
291 my $idx = first_index { $_ eq '-traits' } @_;
293 return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
295 my $traits = $_[ $idx + 1 ];
299 $traits = [ $traits ] unless ref $traits;
301 return ( $traits, @_ );
304 sub _strip_metaclass {
305 my $idx = first_index { $_ eq '-metaclass' } @_;
307 return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
309 my $metaclass = $_[ $idx + 1 ];
313 return ( $metaclass, @_ );
316 sub _apply_meta_traits {
317 my ( $class, $traits ) = @_;
319 return unless @{$traits};
321 my $meta = Class::MOP::class_of($class);
323 my $type = ( split /::/, ref $meta )[-1]
324 or Moose->throw_error(
325 'Cannot determine metaclass type for trait application . Meta isa '
329 = map { Moose::Util::resolve_metatrait_alias( $type => $_ ) }
332 return unless @resolved_traits;
334 Moose::Util::MetaRole::apply_metaclass_roles(
336 metaclass_roles => \@resolved_traits,
341 # 1 extra level because it's called by import so there's a layer
346 ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
347 : ( ref $_[1] && defined $_[1]->{into_level} )
348 ? caller( $offset + $_[1]->{into_level} )
352 sub _make_unimport_sub {
354 my $exporting_package = shift;
356 my $is_removable = shift;
357 my $export_recorder = shift;
360 my $caller = scalar caller();
361 Moose::Exporter->_remove_keywords(
363 [ keys %{$exports} ],
370 sub _remove_keywords {
373 my $keywords = shift;
374 my $is_removable = shift;
375 my $recorded_exports = shift;
379 foreach my $name ( @{ $keywords } ) {
380 next unless $is_removable->{$name};
382 if ( defined &{ $package . '::' . $name } ) {
383 my $sub = \&{ $package . '::' . $name };
385 # make sure it is from us
386 next unless $recorded_exports->{$sub};
388 # and if it is from us, then undef the slot
389 delete ${ $package . '::' }{$name};
405 Moose::Exporter - make an import() and unimport() just like Moose.pm
409 package MyApp::Moose;
414 Moose::Exporter->setup_import_methods(
415 with_caller => [ 'has_rw', 'sugar2' ],
416 as_is => [ 'sugar3', \&Some::Random::thing ],
421 my ($caller, $name, %options) = @_;
422 Class::MOP::class_of($caller)->add_attribute($name,
441 This module encapsulates the exporting of sugar functions in a
442 C<Moose.pm>-like manner. It does this by building custom C<import> and
443 C<unimport> methods for your module, based on a spec you provide.
445 It also lets you "stack" Moose-alike modules so you can export
446 Moose's sugar as well as your own, along with sugar from any random
447 C<MooseX> module, as long as they all use C<Moose::Exporter>.
449 To simplify writing exporter modules, C<Moose::Exporter> also imports
450 C<strict> and C<warnings> into your exporter module, as well as into
455 This module provides two public methods:
459 =item B<< Moose::Exporter->setup_import_methods(...) >>
461 When you call this method, C<Moose::Exporter> build custom C<import>
462 and C<unimport> methods for your module. The import method will export
463 the functions you specify, and you can also tell it to export
464 functions exported by some other module (like C<Moose.pm>).
466 The C<unimport> method cleans the callers namespace of all the
469 This method accepts the following parameters:
473 =item * with_caller => [ ... ]
475 This a list of function I<names only> to be exported wrapped and then
476 exported. The wrapper will pass the name of the calling package as the
477 first argument to the function. Many sugar functions need to know
478 their caller so they can get the calling package's metaclass object.
480 =item * as_is => [ ... ]
482 This a list of function names or sub references to be exported
483 as-is. You can identify a subroutine by reference, which is handy to
484 re-export some other module's functions directly by reference
485 (C<\&Some::Package::function>).
487 If you do export some other packages function, this function will
488 never be removed by the C<unimport> method. The reason for this is we
489 cannot know if the caller I<also> explicitly imported the sub
490 themselves, and therefore wants to keep it.
492 =item * also => $name or \@names
494 This is a list of modules which contain functions that the caller
495 wants to export. These modules must also use C<Moose::Exporter>. The
496 most common use case will be to export the functions from C<Moose.pm>.
497 Functions specified by C<with_caller> or C<as_is> take precedence over
498 functions exported by modules specified by C<also>, so that a module
499 can selectively override functions exported by another module.
501 C<Moose::Exporter> also makes sure all these functions get removed
502 when C<unimport> is called.
506 =item B<< Moose::Exporter->build_import_methods(...) >>
508 Returns two code refs, one for import and one for unimport.
510 Used by C<setup_import_methods>.
514 =head1 IMPORTING AND init_meta
516 If you want to set an alternative base object class or metaclass
517 class, simply define an C<init_meta> method in your class. The
518 C<import> method that C<Moose::Exporter> generates for you will call
519 this method (if it exists). It will always pass the caller to this
520 method via the C<for_class> parameter.
522 Most of the time, your C<init_meta> method will probably just call C<<
523 Moose->init_meta >> to do the real work:
526 shift; # our class name
527 return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
530 =head1 METACLASS TRAITS
532 The C<import> method generated by C<Moose::Exporter> will allow the
533 user of your module to specify metaclass traits in a C<-traits>
534 parameter passed as part of the import:
536 use Moose -traits => 'My::Meta::Trait';
538 use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
540 These traits will be applied to the caller's metaclass
541 instance. Providing traits for an exporting class that does not create
542 a metaclass for the caller is an error.
546 Dave Rolsky E<lt>autarch@urth.orgE<gt>
548 This is largely a reworking of code in Moose.pm originally written by
549 Stevan Little and others.
551 =head1 COPYRIGHT AND LICENSE
553 Copyright 2009 by Infinity Interactive, Inc.
555 L<http://www.iinteractive.com>
557 This library is free software; you can redistribute it and/or modify
558 it under the same terms as Perl itself.