1 package Moose::Exporter;
6 use Class::Load qw(is_class_loaded);
8 use List::MoreUtils qw( first_index uniq );
9 use Moose::Util::MetaRole;
10 use Scalar::Util qw(reftype);
11 use Sub::Exporter 0.980;
12 use Sub::Name qw(subname);
16 sub setup_import_methods {
17 my ( $class, %args ) = @_;
19 $args{exporting_package} ||= caller();
21 $class->build_import_methods(
23 install => [qw(import unimport init_meta)]
27 # A reminder to intrepid Moose hackers
28 # there may be more than one level of exporter
29 # don't make doy cry. -- perigrin
31 sub build_import_methods {
32 my ( $class, %args ) = @_;
34 my $exporting_package = $args{exporting_package} ||= caller();
36 my $meta_lookup = $args{meta_lookup} || sub { Class::MOP::class_of(shift) };
38 $EXPORT_SPEC{$exporting_package} = \%args;
40 my @exports_from = $class->_follow_also($exporting_package);
42 my $export_recorder = {};
45 my $exports = $class->_make_sub_exporter_params(
46 [ $exporting_package, @exports_from ],
49 $args{meta_lookup}, # so that we don't pass through the default
52 my $exporter = $class->_make_exporter(
59 $methods{import} = $class->_make_import_sub(
67 $methods{unimport} = $class->_make_unimport_sub(
75 $methods{init_meta} = $class->_make_init_meta(
81 my $package = Class::MOP::Package->initialize($exporting_package);
82 for my $to_install ( @{ $args{install} || [] } ) {
83 my $symbol = '&' . $to_install;
85 unless $methods{$to_install}
86 && !$package->has_package_symbol($symbol);
87 $package->add_package_symbol( $symbol, $methods{$to_install} );
90 return ( $methods{import}, $methods{unimport}, $methods{init_meta} );
94 my ($class, $exports, $is_reexport, $meta_lookup) = @_;
96 return Sub::Exporter::build_exporter(
99 groups => { default => [':all'] },
101 my ($arg, $to_export) = @_;
102 my $meta = $meta_lookup->($arg->{into});
104 goto &Sub::Exporter::default_installer unless $meta;
106 # don't overwrite existing symbols with our magically flagged
107 # version of it if we would install the same sub that's already
110 my @filtered_to_export;
112 for (my $i = 0; $i < @{ $to_export }; $i += 2) {
113 my ($as, $cv) = @{ $to_export }[$i, $i + 1];
116 && $meta->has_package_symbol('&' . $as)
117 && $meta->get_package_symbol('&' . $as) == $cv;
119 push @filtered_to_export, $as, $cv;
120 $installed{$as} = 1 unless ref $as;
123 Sub::Exporter::default_installer($arg, \@filtered_to_export);
125 for my $name ( keys %{$is_reexport} ) {
128 next unless exists $installed{$name};
129 _flag_as_reexport( \*{ join q{::}, $arg->{into}, $name } );
138 my $exporting_package = shift;
140 _die_if_cycle_found_in_also_list_for_package($exporting_package);
142 return uniq( _follow_also_real($exporting_package) );
145 sub _follow_also_real {
146 my $exporting_package = shift;
147 my @also = _also_list_for_package($exporting_package);
149 return map { $_, _follow_also_real($_) } @also;
152 sub _also_list_for_package {
155 if ( !exists $EXPORT_SPEC{$package} ) {
156 my $loaded = is_class_loaded($package);
158 die "Package in also ($package) does not seem to "
159 . "use Moose::Exporter"
160 . ( $loaded ? "" : " (is it loaded?)" );
163 my $also = $EXPORT_SPEC{$package}{also};
165 return unless defined $also;
167 return ref $also ? @$also : $also;
170 # this is no Tarjan algorithm, but for the list sizes expected,
171 # brute force will probably be fine (and more maintainable)
172 sub _die_if_cycle_found_in_also_list_for_package {
174 _die_if_also_list_cycles_back_to_existing_stack(
175 [ _also_list_for_package($package) ],
180 sub _die_if_also_list_cycles_back_to_existing_stack {
181 my ( $also_list, $existing_stack ) = @_;
183 return unless @$also_list && @$existing_stack;
185 for my $also_member (@$also_list) {
186 for my $stack_member (@$existing_stack) {
187 next unless $also_member eq $stack_member;
190 "Circular reference in 'also' parameter to Moose::Exporter between "
194 ) . " and $also_member";
197 _die_if_also_list_cycles_back_to_existing_stack(
198 [ _also_list_for_package($also_member) ],
199 [ $also_member, @$existing_stack ],
204 sub _parse_trait_aliases {
206 my ($package, $aliases) = @_;
209 for my $alias (@$aliases) {
212 reftype($alias) eq 'ARRAY'
213 or Moose->throw_error(reftype($alias) . " references are not "
214 . "valid arguments to the 'trait_aliases' "
217 ($alias, $name) = @$alias;
220 ($name = $alias) =~ s/.*:://;
222 push @ret, subname "${package}::${name}" => sub () { $alias };
228 sub _make_sub_exporter_params {
230 my $packages = shift;
231 my $export_recorder = shift;
232 my $is_reexport = shift;
233 my $meta_lookup_override = shift;
236 my $current_meta_lookup;
238 for my $package ( @{$packages} ) {
239 my $args = $EXPORT_SPEC{$package}
240 or die "The $package package does not use Moose::Exporter\n";
242 $current_meta_lookup = $meta_lookup_override || $args->{meta_lookup};
243 $meta_lookup_override = $current_meta_lookup;
245 my $meta_lookup = $current_meta_lookup
246 || sub { Class::MOP::class_of(shift) };
248 for my $name ( @{ $args->{with_meta} } ) {
249 my $sub = $class->_sub_from_package( $package, $name )
252 my $fq_name = $package . '::' . $name;
254 $exports{$name} = $class->_make_wrapped_sub_with_meta(
259 ) unless exists $exports{$name};
262 for my $name ( @{ $args->{with_caller} } ) {
263 my $sub = $class->_sub_from_package( $package, $name )
266 my $fq_name = $package . '::' . $name;
268 $exports{$name} = $class->_make_wrapped_sub(
272 ) unless exists $exports{$name};
275 my @extra_exports = $class->_parse_trait_aliases(
276 $package, $args->{trait_aliases},
278 for my $name ( @{ $args->{as_is} }, @extra_exports ) {
279 my ( $sub, $coderef_name );
285 ( $coderef_pkg, $coderef_name )
286 = Class::MOP::get_code_info($name);
288 if ( $coderef_pkg ne $package ) {
289 $is_reexport->{$coderef_name} = 1;
293 $sub = $class->_sub_from_package( $package, $name )
296 $coderef_name = $name;
299 $export_recorder->{$sub} = 1;
301 $exports{$coderef_name} = sub { $sub }
302 unless exists $exports{$coderef_name};
309 sub _sub_from_package {
316 \&{ $package . '::' . $name };
319 return $sub if defined &$sub;
321 Carp::cluck "Trying to export undefined sub ${package}::${name}";
328 sub _make_wrapped_sub {
332 my $export_recorder = shift;
334 # We need to set the package at import time, so that when
335 # package Foo imports has(), we capture "Foo" as the
336 # package. This lets other packages call Foo::has() and get
337 # the right package. This is done for backwards compatibility
338 # with existing production code, not because this is a good
341 my $caller = $CALLER;
343 my $wrapper = $self->_curry_wrapper( $sub, $fq_name, $caller );
345 my $sub = subname( $fq_name => $wrapper );
347 $export_recorder->{$sub} = 1;
353 sub _make_wrapped_sub_with_meta {
357 my $export_recorder = shift;
358 my $meta_lookup = shift;
361 my $caller = $CALLER;
363 my $wrapper = $self->_late_curry_wrapper(
365 $meta_lookup => $caller
368 my $sub = subname( $fq_name => $wrapper );
370 $export_recorder->{$sub} = 1;
382 my $wrapper = sub { $sub->( @extra, @_ ) };
383 if ( my $proto = prototype $sub ) {
385 # XXX - Perl's prototype sucks. Use & to make set_prototype
386 # ignore the fact that we're passing "private variables"
387 &Scalar::Util::set_prototype( $wrapper, $proto );
392 sub _late_curry_wrapper {
401 # resolve curried arguments at runtime via this closure
402 my @curry = ( $extra->(@ex_args) );
403 return $sub->( @curry, @_ );
406 if ( my $proto = prototype $sub ) {
408 # XXX - Perl's prototype sucks. Use & to make set_prototype
409 # ignore the fact that we're passing "private variables"
410 &Scalar::Util::set_prototype( $wrapper, $proto );
415 sub _make_import_sub {
417 my $exporting_package = shift;
418 my $exporter = shift;
419 my $exports_from = shift;
420 my $is_reexport = shift;
421 my $meta_lookup = shift;
425 # I think we could use Sub::Exporter's collector feature
426 # to do this, but that would be rather gross, since that
427 # feature isn't really designed to return a value to the
428 # caller of the exporter sub.
430 # Also, this makes sure we preserve backwards compat for
431 # _get_caller, so it always sees the arguments in the
434 ( $traits, @_ ) = _strip_traits(@_);
437 ( $metaclass, @_ ) = _strip_metaclass(@_);
439 = Moose::Util::resolve_metaclass_alias( 'Class' => $metaclass )
440 if defined $metaclass && length $metaclass;
443 ( $meta_name, @_ ) = _strip_meta_name(@_);
445 # Normally we could look at $_[0], but in some weird cases
446 # (involving goto &Moose::import), $_[0] ends as something
447 # else (like Squirrel).
448 my $class = $exporting_package;
450 $CALLER = _get_caller(@_);
452 # this works because both pragmas set $^H (see perldoc
453 # perlvar) which affects the current compilation -
454 # i.e. the file who use'd us - which is why we don't need
455 # to do anything special to make it affect that file
456 # rather than this one (which is already compiled)
462 for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
464 # init_meta can apply a role, which when loaded uses
465 # Moose::Exporter, which in turn sets $CALLER, so we need
466 # to protect against that.
467 local $CALLER = $CALLER;
469 for_class => $CALLER,
470 metaclass => $metaclass,
471 meta_name => $meta_name,
477 # The metaroles will use Moose::Role, which in turn uses
478 # Moose::Exporter, which in turn sets $CALLER, so we need
479 # to protect against that.
480 local $CALLER = $CALLER;
483 [$class, @$exports_from],
488 if ( $did_init_meta && @{$traits} ) {
490 # The traits will use Moose::Role, which in turn uses
491 # Moose::Exporter, which in turn sets $CALLER, so we need
492 # to protect against that.
493 local $CALLER = $CALLER;
494 _apply_meta_traits( $CALLER, $traits, $meta_lookup );
496 elsif ( @{$traits} ) {
499 "Cannot provide traits when $class does not have an init_meta() method"
503 my ( undef, @args ) = @_;
504 my $extra = shift @args if ref $args[0] eq 'HASH';
507 if ( !$extra->{into} ) {
508 $extra->{into_level} ||= 0;
509 $extra->{into_level}++;
512 $class->$exporter( $extra, @args );
517 my $idx = first_index { ( $_ || '' ) eq '-traits' } @_;
519 return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
521 my $traits = $_[ $idx + 1 ];
525 $traits = [$traits] unless ref $traits;
527 return ( $traits, @_ );
530 sub _strip_metaclass {
531 my $idx = first_index { ( $_ || '' ) eq '-metaclass' } @_;
533 return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
535 my $metaclass = $_[ $idx + 1 ];
539 return ( $metaclass, @_ );
542 sub _strip_meta_name {
543 my $idx = first_index { ( $_ || '' ) eq '-meta_name' } @_;
545 return ( 'meta', @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
547 my $meta_name = $_[ $idx + 1 ];
551 return ( $meta_name, @_ );
554 sub _apply_metaroles {
555 my ($class, $exports_from, $meta_lookup) = @_;
557 my $metaroles = _collect_metaroles($exports_from);
558 my $base_class_roles = delete $metaroles->{base_class_roles};
560 my $meta = $meta_lookup->($class);
561 # for instance, Moose.pm uses Moose::Util::TypeConstraints
564 Moose::Util::MetaRole::apply_metaroles(
567 ) if keys %$metaroles;
569 Moose::Util::MetaRole::apply_base_class_roles(
571 roles => $base_class_roles,
572 ) if $meta->isa('Class::MOP::Class')
573 && $base_class_roles && @$base_class_roles;
576 sub _collect_metaroles {
577 my ($exports_from) = @_;
579 my @old_style_role_types = map { "${_}_roles" } qw(
583 wrapped_method_metaclass
592 my @base_class_roles;
595 for my $exporter (@$exports_from) {
596 my $data = $EXPORT_SPEC{$exporter};
598 if (exists $data->{class_metaroles}) {
599 for my $type (keys %{ $data->{class_metaroles} }) {
600 push @{ $class_metaroles{$type} ||= [] },
601 @{ $data->{class_metaroles}{$type} };
605 if (exists $data->{role_metaroles}) {
606 for my $type (keys %{ $data->{role_metaroles} }) {
607 push @{ $role_metaroles{$type} ||= [] },
608 @{ $data->{role_metaroles}{$type} };
612 if (exists $data->{base_class_roles}) {
613 push @base_class_roles, @{ $data->{base_class_roles} };
616 for my $type (@old_style_role_types) {
617 if (exists $data->{$type}) {
618 push @{ $old_style_roles{$type} ||= [] },
625 (keys(%class_metaroles)
626 ? (class_metaroles => \%class_metaroles)
628 (keys(%role_metaroles)
629 ? (role_metaroles => \%role_metaroles)
632 ? (base_class_roles => \@base_class_roles)
638 sub _apply_meta_traits {
639 my ( $class, $traits, $meta_lookup ) = @_;
641 return unless @{$traits};
643 my $meta = $meta_lookup->($class);
645 my $type = $meta->isa('Moose::Meta::Role') ? 'Trait'
646 : $meta->isa('Class::MOP::Class') ? 'Class'
647 : Moose->throw_error('Cannot determine metaclass type for '
648 . 'trait application. Meta isa '
651 my @resolved_traits = map {
654 : Moose::Util::resolve_metatrait_alias( $type => $_ )
657 return unless @resolved_traits;
659 my %args = ( for => $class );
661 if ( $meta->isa('Moose::Meta::Role') ) {
662 $args{role_metaroles} = { role => \@resolved_traits };
665 $args{class_metaroles} = { class => \@resolved_traits };
668 Moose::Util::MetaRole::apply_metaroles(%args);
673 # 1 extra level because it's called by import so there's a layer
678 ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
679 : ( ref $_[1] && defined $_[1]->{into_level} )
680 ? caller( $offset + $_[1]->{into_level} )
684 sub _make_unimport_sub {
686 my $exporting_package = shift;
688 my $export_recorder = shift;
689 my $is_reexport = shift;
690 my $meta_lookup = shift;
693 my $caller = scalar caller();
694 Moose::Exporter->_remove_keywords(
696 [ keys %{$exports} ],
703 sub _remove_keywords {
706 my $keywords = shift;
707 my $recorded_exports = shift;
708 my $is_reexport = shift;
712 foreach my $name ( @{$keywords} ) {
713 if ( defined &{ $package . '::' . $name } ) {
714 my $sub = \&{ $package . '::' . $name };
716 # make sure it is from us
717 next unless $recorded_exports->{$sub};
719 if ( $is_reexport->{$name} ) {
722 unless _export_is_flagged(
723 \*{ join q{::} => $package, $name } );
726 # and if it is from us, then undef the slot
727 delete ${ $package . '::' }{$name};
732 # maintain this for now for backcompat
733 # make sure to return a sub to install in the same circumstances as previously
734 # but this functionality now happens at the end of ->import
735 sub _make_init_meta {
739 my $meta_lookup = shift;
748 wrapped_method_metaclass
755 $old_style_roles{$role} = $args->{$role}
756 if exists $args->{$role};
759 my %base_class_roles;
760 %base_class_roles = ( roles => $args->{base_class_roles} )
761 if exists $args->{base_class_roles};
763 my %new_style_roles = map { $_ => $args->{$_} }
764 grep { exists $args->{$_} } qw( class_metaroles role_metaroles );
766 return unless %new_style_roles || %old_style_roles || %base_class_roles;
771 $meta_lookup->($opts{for_class});
782 # ABSTRACT: make an import() and unimport() just like Moose.pm
788 package MyApp::Moose;
793 Moose::Exporter->setup_import_methods(
794 with_meta => [ 'has_rw', 'sugar2' ],
795 as_is => [ 'sugar3', \&Some::Random::thing ],
800 my ( $meta, $name, %options ) = @_;
801 $meta->add_attribute(
821 This module encapsulates the exporting of sugar functions in a
822 C<Moose.pm>-like manner. It does this by building custom C<import> and
823 C<unimport> methods for your module, based on a spec you provide.
825 It also lets you "stack" Moose-alike modules so you can export Moose's sugar
826 as well as your own, along with sugar from any random C<MooseX> module, as
827 long as they all use C<Moose::Exporter>. This feature exists to let you bundle
828 a set of MooseX modules into a policy module that developers can use directly
829 instead of using Moose itself.
831 To simplify writing exporter modules, C<Moose::Exporter> also imports
832 C<strict> and C<warnings> into your exporter module, as well as into
837 This module provides two public methods:
841 =item B<< Moose::Exporter->setup_import_methods(...) >>
843 When you call this method, C<Moose::Exporter> builds custom C<import> and
844 C<unimport> methods for your module. The C<import> method
845 will export the functions you specify, and can also re-export functions
846 exported by some other module (like C<Moose.pm>). If you pass any parameters
847 for L<Moose::Util::MetaRole>, the C<import> method will also call
848 C<Moose::Util::MetaRole::apply_metaroles> and
849 C<Moose::Util::MetaRole::apply_base_class_roles> as needed, after making
850 sure the metaclass is initialized.
852 The C<unimport> method cleans the caller's namespace of all the exported
853 functions. This includes any functions you re-export from other
854 packages. However, if the consumer of your package also imports those
855 functions from the original package, they will I<not> be cleaned.
857 Note that if any of these methods already exist, they will not be
858 overridden, you will have to use C<build_import_methods> to get the
859 coderef that would be installed.
861 This method accepts the following parameters:
865 =item * with_meta => [ ... ]
867 This list of function I<names only> will be wrapped and then exported. The
868 wrapper will pass the metaclass object for the caller as its first argument.
870 Many sugar functions will need to use this metaclass object to do something to
873 =item * as_is => [ ... ]
875 This list of function names or sub references will be exported as-is. You can
876 identify a subroutine by reference, which is handy to re-export some other
877 module's functions directly by reference (C<\&Some::Package::function>).
879 If you do export some other package's function, this function will never be
880 removed by the C<unimport> method. The reason for this is we cannot know if
881 the caller I<also> explicitly imported the sub themselves, and therefore wants
884 =item * trait_aliases => [ ... ]
886 This is a list of package names which should have shortened aliases exported,
887 similar to the functionality of L<aliased>. Each element in the list can be
888 either a package name, in which case the export will be named as the last
889 namespace component of the package, or an arrayref, whose first element is the
890 package to alias to, and second element is the alias to export.
892 =item * also => $name or \@names
894 This is a list of modules which contain functions that the caller
895 wants to export. These modules must also use C<Moose::Exporter>. The
896 most common use case will be to export the functions from C<Moose.pm>.
897 Functions specified by C<with_meta> or C<as_is> take precedence over
898 functions exported by modules specified by C<also>, so that a module
899 can selectively override functions exported by another module.
901 C<Moose::Exporter> also makes sure all these functions get removed
902 when C<unimport> is called.
904 =item * meta_lookup => sub { ... }
906 This is a function which will be called to provide the metaclass
907 to be operated upon by the exporter. This is an advanced feature
908 intended for use by package generator modules in the vein of
909 L<MooseX::Role::Parameterized> in order to simplify reusing sugar
910 from other modules that use C<Moose::Exporter>. This function is
911 used, for example, to select the metaclass to bind to functions
912 that are exported using the C<with_meta> option.
914 This function will receive one parameter: the class name into which
915 the sugar is being exported. The default implementation is:
917 sub { Class::MOP::class_of(shift) }
919 Accordingly, this function is expected to return a metaclass.
923 You can also provide parameters for C<Moose::Util::MetaRole::apply_metaroles>
924 and C<Moose::Util::MetaRole::base_class_roles>. Specifically, valid parameters
925 are "class_metaroles", "role_metaroles", and "base_class_roles".
927 =item B<< Moose::Exporter->build_import_methods(...) >>
929 Returns two code refs, one for C<import> and one for C<unimport>.
931 Accepts the additional C<install> option, which accepts an arrayref of method
932 names to install into your exporting package. The valid options are C<import>
933 and C<unimport>. Calling C<setup_import_methods> is equivalent
934 to calling C<build_import_methods> with C<< install => [qw(import unimport)] >>
935 except that it doesn't also return the methods.
937 The C<import> method is built using L<Sub::Exporter>. This means that it can
938 take a hashref of the form C<< { into => $package } >> to specify the package
941 Used by C<setup_import_methods>.
945 =head1 IMPORTING AND init_meta
947 If you want to set an alternative base object class or metaclass class, see
948 above for details on how this module can call L<Moose::Util::MetaRole> for
951 If you want to do something that is not supported by this module, simply
952 define an C<init_meta> method in your class. The C<import> method that
953 C<Moose::Exporter> generates for you will call this method (if it exists). It
954 will always pass the caller to this method via the C<for_class> parameter.
956 Most of the time, your C<init_meta> method will probably just call C<<
957 Moose->init_meta >> to do the real work:
960 shift; # our class name
961 return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
964 =head1 METACLASS TRAITS
966 The C<import> method generated by C<Moose::Exporter> will allow the
967 user of your module to specify metaclass traits in a C<-traits>
968 parameter passed as part of the import:
970 use Moose -traits => 'My::Meta::Trait';
972 use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
974 These traits will be applied to the caller's metaclass
975 instance. Providing traits for an exporting class that does not create
976 a metaclass for the caller is an error.
980 See L<Moose/BUGS> for details on reporting bugs.