1 package Moose::Exporter;
7 our $XS_VERSION = $VERSION;
8 $VERSION = eval $VERSION;
9 our $AUTHORITY = 'cpan:STEVAN';
12 use List::MoreUtils qw( first_index uniq );
13 use Moose::Deprecated;
14 use Moose::Util::MetaRole;
15 use Sub::Exporter 0.980;
16 use Sub::Name qw(subname);
20 XSLoader::load( 'Moose', $XS_VERSION );
24 sub setup_import_methods {
25 my ( $class, %args ) = @_;
27 my $exporting_package = $args{exporting_package} ||= caller();
29 $class->build_import_methods(
31 install => [qw(import unimport init_meta)]
35 sub build_import_methods {
36 my ( $class, %args ) = @_;
38 my $exporting_package = $args{exporting_package} ||= caller();
40 if ( $args{with_caller} ) {
41 Moose::Deprecated::deprecated(
42 feature => 'Moose::Exporter with_caller',
44 'The with_caller argument for Moose::Exporter has been deprecated'
48 $EXPORT_SPEC{$exporting_package} = \%args;
50 my @exports_from = $class->_follow_also($exporting_package);
52 my $export_recorder = {};
55 my $exports = $class->_make_sub_exporter_params(
56 [ @exports_from, $exporting_package ],
61 my $exporter = Sub::Exporter::build_exporter(
64 groups => { default => [':all'] }
69 $methods{import} = $class->_make_import_sub(
76 $methods{unimport} = $class->_make_unimport_sub(
83 $methods{init_meta} = $class->_make_init_meta(
88 my $package = Class::MOP::Package->initialize($exporting_package);
89 for my $to_install ( @{ $args{install} || [] } ) {
90 my $symbol = '&' . $to_install;
92 unless $methods{$to_install}
93 && !$package->has_package_symbol($symbol);
94 $package->add_package_symbol( $symbol, $methods{$to_install} );
97 return ( $methods{import}, $methods{unimport}, $methods{init_meta} );
105 my $exporting_package = shift;
107 local %$seen = ( $exporting_package => 1 );
109 return uniq( _follow_also_real($exporting_package) );
112 sub _follow_also_real {
113 my $exporting_package = shift;
115 if ( !exists $EXPORT_SPEC{$exporting_package} ) {
116 my $loaded = Class::MOP::is_class_loaded($exporting_package);
118 die "Package in also ($exporting_package) does not seem to "
119 . "use Moose::Exporter"
120 . ( $loaded ? "" : " (is it loaded?)" );
123 my $also = $EXPORT_SPEC{$exporting_package}{also};
125 return unless defined $also;
127 my @also = ref $also ? @{$also} : $also;
129 for my $package (@also) {
131 "Circular reference in 'also' parameter to Moose::Exporter between $exporting_package and $package"
132 if $seen->{$package};
134 $seen->{$package} = 1;
137 return @also, map { _follow_also_real($_) } @also;
141 sub _make_sub_exporter_params {
143 my $packages = shift;
144 my $export_recorder = shift;
145 my $is_reexport = shift;
149 for my $package ( @{$packages} ) {
150 my $args = $EXPORT_SPEC{$package}
151 or die "The $package package does not use Moose::Exporter\n";
153 for my $name ( @{ $args->{with_meta} } ) {
154 my $sub = $class->_sub_from_package( $package, $name )
157 my $fq_name = $package . '::' . $name;
159 $exports{$name} = $class->_make_wrapped_sub_with_meta(
166 for my $name ( @{ $args->{with_caller} } ) {
167 my $sub = $class->_sub_from_package( $package, $name )
170 my $fq_name = $package . '::' . $name;
172 $exports{$name} = $class->_make_wrapped_sub(
179 for my $name ( @{ $args->{as_is} } ) {
180 my ( $sub, $coderef_name );
186 ( $coderef_pkg, $coderef_name )
187 = Class::MOP::get_code_info($name);
189 if ( $coderef_pkg ne $package ) {
190 $is_reexport->{$coderef_name} = 1;
194 $sub = $class->_sub_from_package( $package, $name )
197 $coderef_name = $name;
200 $export_recorder->{$sub} = 1;
202 $exports{$coderef_name} = sub {$sub};
209 sub _sub_from_package {
216 \&{ $package . '::' . $name };
219 return $sub if defined &$sub;
221 Carp::cluck "Trying to export undefined sub ${package}::${name}";
228 sub _make_wrapped_sub {
232 my $export_recorder = shift;
234 # We need to set the package at import time, so that when
235 # package Foo imports has(), we capture "Foo" as the
236 # package. This lets other packages call Foo::has() and get
237 # the right package. This is done for backwards compatibility
238 # with existing production code, not because this is a good
241 my $caller = $CALLER;
243 my $wrapper = $self->_curry_wrapper( $sub, $fq_name, $caller );
245 my $sub = subname( $fq_name => $wrapper );
247 $export_recorder->{$sub} = 1;
253 sub _make_wrapped_sub_with_meta {
257 my $export_recorder = shift;
260 my $caller = $CALLER;
262 my $wrapper = $self->_late_curry_wrapper(
264 sub { Class::MOP::class_of(shift) } => $caller
267 my $sub = subname( $fq_name => $wrapper );
269 $export_recorder->{$sub} = 1;
281 my $wrapper = sub { $sub->( @extra, @_ ) };
282 if ( my $proto = prototype $sub ) {
284 # XXX - Perl's prototype sucks. Use & to make set_prototype
285 # ignore the fact that we're passing "private variables"
286 &Scalar::Util::set_prototype( $wrapper, $proto );
291 sub _late_curry_wrapper {
300 # resolve curried arguments at runtime via this closure
301 my @curry = ( $extra->(@ex_args) );
302 return $sub->( @curry, @_ );
305 if ( my $proto = prototype $sub ) {
307 # XXX - Perl's prototype sucks. Use & to make set_prototype
308 # ignore the fact that we're passing "private variables"
309 &Scalar::Util::set_prototype( $wrapper, $proto );
314 sub _make_import_sub {
316 my $exporting_package = shift;
317 my $exporter = shift;
318 my $exports_from = shift;
319 my $is_reexport = shift;
323 # I think we could use Sub::Exporter's collector feature
324 # to do this, but that would be rather gross, since that
325 # feature isn't really designed to return a value to the
326 # caller of the exporter sub.
328 # Also, this makes sure we preserve backwards compat for
329 # _get_caller, so it always sees the arguments in the
332 ( $traits, @_ ) = _strip_traits(@_);
335 ( $metaclass, @_ ) = _strip_metaclass(@_);
337 = Moose::Util::resolve_metaclass_alias( 'Class' => $metaclass )
338 if defined $metaclass && length $metaclass;
340 # Normally we could look at $_[0], but in some weird cases
341 # (involving goto &Moose::import), $_[0] ends as something
342 # else (like Squirrel).
343 my $class = $exporting_package;
345 $CALLER = _get_caller(@_);
347 # this works because both pragmas set $^H (see perldoc
348 # perlvar) which affects the current compilation -
349 # i.e. the file who use'd us - which is why we don't need
350 # to do anything special to make it affect that file
351 # rather than this one (which is already compiled)
357 for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
359 # init_meta can apply a role, which when loaded uses
360 # Moose::Exporter, which in turn sets $CALLER, so we need
361 # to protect against that.
362 local $CALLER = $CALLER;
363 $c->init_meta( for_class => $CALLER, metaclass => $metaclass );
367 if ( $did_init_meta && @{$traits} ) {
369 # The traits will use Moose::Role, which in turn uses
370 # Moose::Exporter, which in turn sets $CALLER, so we need
371 # to protect against that.
372 local $CALLER = $CALLER;
373 _apply_meta_traits( $CALLER, $traits );
375 elsif ( @{$traits} ) {
378 "Cannot provide traits when $class does not have an init_meta() method"
382 my ( undef, @args ) = @_;
383 my $extra = shift @args if ref $args[0] eq 'HASH';
386 if ( !$extra->{into} ) {
387 $extra->{into_level} ||= 0;
388 $extra->{into_level}++;
391 $class->$exporter( $extra, @args );
393 for my $name ( keys %{$is_reexport} ) {
396 _flag_as_reexport( \*{ join q{::}, $CALLER, $name } );
402 my $idx = first_index { $_ eq '-traits' } @_;
404 return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
406 my $traits = $_[ $idx + 1 ];
410 $traits = [$traits] unless ref $traits;
412 return ( $traits, @_ );
415 sub _strip_metaclass {
416 my $idx = first_index { $_ eq '-metaclass' } @_;
418 return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
420 my $metaclass = $_[ $idx + 1 ];
424 return ( $metaclass, @_ );
427 sub _apply_meta_traits {
428 my ( $class, $traits ) = @_;
430 return unless @{$traits};
432 my $meta = Class::MOP::class_of($class);
434 my $type = ( split /::/, ref $meta )[-1]
435 or Moose->throw_error(
436 'Cannot determine metaclass type for trait application . Meta isa '
439 my @resolved_traits = map {
442 : Moose::Util::resolve_metatrait_alias( $type => $_ )
445 return unless @resolved_traits;
447 my %args = ( for => $class );
449 if ( $meta->isa('Moose::Meta::Role') ) {
450 $args{role_metaroles} = { role => \@resolved_traits };
453 $args{class_metaroles} = { class => \@resolved_traits };
456 Moose::Util::MetaRole::apply_metaroles(%args);
461 # 1 extra level because it's called by import so there's a layer
466 ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
467 : ( ref $_[1] && defined $_[1]->{into_level} )
468 ? caller( $offset + $_[1]->{into_level} )
472 sub _make_unimport_sub {
474 my $exporting_package = shift;
476 my $export_recorder = shift;
477 my $is_reexport = shift;
480 my $caller = scalar caller();
481 Moose::Exporter->_remove_keywords(
483 [ keys %{$exports} ],
490 sub _remove_keywords {
493 my $keywords = shift;
494 my $recorded_exports = shift;
495 my $is_reexport = shift;
499 foreach my $name ( @{$keywords} ) {
500 if ( defined &{ $package . '::' . $name } ) {
501 my $sub = \&{ $package . '::' . $name };
503 # make sure it is from us
504 next unless $recorded_exports->{$sub};
506 if ( $is_reexport->{$name} ) {
509 unless _export_is_flagged(
510 \*{ join q{::} => $package, $name } );
513 # and if it is from us, then undef the slot
514 delete ${ $package . '::' }{$name};
519 sub _make_init_meta {
531 wrapped_method_metaclass
538 $old_style_roles{$role} = $args->{$role}
539 if exists $args->{$role};
542 my %base_class_roles;
543 %base_class_roles = ( roles => $args->{base_class_roles} )
544 if exists $args->{base_class_roles};
546 my %new_style_roles = map { $_ => $args->{$_} }
547 grep { exists $args->{$_} } qw( class_metaroles role_metaroles );
549 return unless %new_style_roles || %old_style_roles || %base_class_roles;
555 return unless Class::MOP::class_of( $options{for_class} );
557 if ( %new_style_roles || %old_style_roles ) {
558 Moose::Util::MetaRole::apply_metaroles(
559 for => $options{for_class},
565 Moose::Util::MetaRole::apply_base_class_roles(
566 for_class => $options{for_class},
569 if Class::MOP::class_of( $options{for_class} )
570 ->isa('Moose::Meta::Class');
572 return Class::MOP::class_of( $options{for_class} );
587 Moose::Exporter - make an import() and unimport() just like Moose.pm
591 package MyApp::Moose;
596 Moose::Exporter->setup_import_methods(
597 with_meta => [ 'has_rw', 'sugar2' ],
598 as_is => [ 'sugar3', \&Some::Random::thing ],
603 my ( $meta, $name, %options ) = @_;
604 $meta->add_attribute(
624 This module encapsulates the exporting of sugar functions in a
625 C<Moose.pm>-like manner. It does this by building custom C<import>,
626 C<unimport>, and C<init_meta> methods for your module, based on a spec you
629 It also lets you "stack" Moose-alike modules so you can export Moose's sugar
630 as well as your own, along with sugar from any random C<MooseX> module, as
631 long as they all use C<Moose::Exporter>. This feature exists to let you bundle
632 a set of MooseX modules into a policy module that developers can use directly
633 instead of using Moose itself.
635 To simplify writing exporter modules, C<Moose::Exporter> also imports
636 C<strict> and C<warnings> into your exporter module, as well as into
641 This module provides two public methods:
645 =item B<< Moose::Exporter->setup_import_methods(...) >>
647 When you call this method, C<Moose::Exporter> builds custom C<import>,
648 C<unimport>, and C<init_meta> methods for your module. The C<import> method
649 will export the functions you specify, and can also re-export functions
650 exported by some other module (like C<Moose.pm>).
652 The C<unimport> method cleans the caller's namespace of all the exported
653 functions. This includes any functions you re-export from other
654 packages. However, if the consumer of your package also imports those
655 functions from the original package, they will I<not> be cleaned.
657 If you pass any parameters for L<Moose::Util::MetaRole>, this method will
658 generate an C<init_meta> for you as well (see below for details). This
659 C<init_meta> will call C<Moose::Util::MetaRole::apply_metaclass_roles> and
660 C<Moose::Util::MetaRole::apply_base_class_roles> as needed.
662 Note that if any of these methods already exist, they will not be
663 overridden, you will have to use C<build_import_methods> to get the
664 coderef that would be installed.
666 This method accepts the following parameters:
670 =item * with_meta => [ ... ]
672 This list of function I<names only> will be wrapped and then exported. The
673 wrapper will pass the metaclass object for the caller as its first argument.
675 Many sugar functions will need to use this metaclass object to do something to
678 =item * as_is => [ ... ]
680 This list of function names or sub references will be exported as-is. You can
681 identify a subroutine by reference, which is handy to re-export some other
682 module's functions directly by reference (C<\&Some::Package::function>).
684 If you do export some other package's function, this function will never be
685 removed by the C<unimport> method. The reason for this is we cannot know if
686 the caller I<also> explicitly imported the sub themselves, and therefore wants
689 =item * also => $name or \@names
691 This is a list of modules which contain functions that the caller
692 wants to export. These modules must also use C<Moose::Exporter>. The
693 most common use case will be to export the functions from C<Moose.pm>.
694 Functions specified by C<with_meta> or C<as_is> take precedence over
695 functions exported by modules specified by C<also>, so that a module
696 can selectively override functions exported by another module.
698 C<Moose::Exporter> also makes sure all these functions get removed
699 when C<unimport> is called.
703 You can also provide parameters for C<Moose::Util::MetaRole::apply_metaroles>
704 and C<Moose::Util::MetaRole::base_class_roles>. Specifically, valid parameters
705 are "class_metaroles", "role_metaroles", and "base_class_roles".
707 =item B<< Moose::Exporter->build_import_methods(...) >>
709 Returns two or three code refs, one for C<import>, one for
710 C<unimport>, and optionally one for C<init_meta>, if the appropriate
711 options are passed in.
713 Accepts the additional C<install> option, which accepts an arrayref of method
714 names to install into your exporting package. The valid options are C<import>,
715 C<unimport>, and C<init_meta>. Calling C<setup_import_methods> is equivalent
716 to calling C<build_import_methods> with C<< install => [qw(import unimport
717 init_meta)] >> except that it doesn't also return the methods.
719 Used by C<setup_import_methods>.
723 =head1 IMPORTING AND init_meta
725 If you want to set an alternative base object class or metaclass class, see
726 above for details on how this module can call L<Moose::Util::MetaRole> for
729 If you want to do something that is not supported by this module, simply
730 define an C<init_meta> method in your class. The C<import> method that
731 C<Moose::Exporter> generates for you will call this method (if it exists). It
732 will always pass the caller to this method via the C<for_class> parameter.
734 Most of the time, your C<init_meta> method will probably just call C<<
735 Moose->init_meta >> to do the real work:
738 shift; # our class name
739 return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
742 Keep in mind that C<build_import_methods> will return an C<init_meta>
743 method for you, which you can also call from within your custom
746 my ( $import, $unimport, $init_meta ) =
747 Moose::Exporter->build_import_methods( ... );
754 $class->$import(...);
759 sub unimport { goto &$unimport }
766 $class->$init_meta(...);
771 =head1 METACLASS TRAITS
773 The C<import> method generated by C<Moose::Exporter> will allow the
774 user of your module to specify metaclass traits in a C<-traits>
775 parameter passed as part of the import:
777 use Moose -traits => 'My::Meta::Trait';
779 use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
781 These traits will be applied to the caller's metaclass
782 instance. Providing traits for an exporting class that does not create
783 a metaclass for the caller is an error.
787 See L<Moose/BUGS> for details on reporting bugs.
791 Dave Rolsky E<lt>autarch@urth.orgE<gt>
793 This is largely a reworking of code in Moose.pm originally written by
794 Stevan Little and others.
796 =head1 COPYRIGHT AND LICENSE
798 Copyright 2009 by Infinity Interactive, Inc.
800 L<http://www.iinteractive.com>
802 This library is free software; you can redistribute it and/or modify
803 it under the same terms as Perl itself.