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;
13 use Sub::Exporter 0.980;
14 use Sub::Name qw(subname);
18 sub setup_import_methods {
19 my ( $class, %args ) = @_;
21 my $exporting_package = $args{exporting_package} ||= caller();
23 $class->build_import_methods(
25 install => [qw(import unimport init_meta)]
29 sub build_import_methods {
30 my ( $class, %args ) = @_;
32 my $exporting_package = $args{exporting_package} ||= caller();
34 $EXPORT_SPEC{$exporting_package} = \%args;
36 my @exports_from = $class->_follow_also( $exporting_package );
38 my $export_recorder = {};
40 my ( $exports, $is_removable )
41 = $class->_make_sub_exporter_params(
42 [ @exports_from, $exporting_package ], $export_recorder );
44 my $exporter = Sub::Exporter::build_exporter(
47 groups => { default => [':all'] }
52 # $args{_export_to_main} exists for backwards compat, because
53 # Moose::Util::TypeConstraints did export to main (unlike Moose &
55 $methods{import} = $class->_make_import_sub( $exporting_package,
56 $exporter, \@exports_from, $args{_export_to_main} );
58 $methods{unimport} = $class->_make_unimport_sub( $exporting_package,
59 $exports, $is_removable, $export_recorder );
61 $methods{init_meta} = $class->_make_init_meta( $exporting_package,
64 my $package = Class::MOP::Package->initialize($exporting_package);
65 for my $to_install ( @{ $args{install} || [] } ) {
66 my $symbol = '&' . $to_install;
68 unless $methods{$to_install}
69 && !$package->has_package_symbol($symbol);
70 $package->add_package_symbol( $symbol, $methods{$to_install} );
73 return ( $methods{import}, $methods{unimport}, $methods{init_meta} )
81 my $exporting_package = shift;
83 local %$seen = ( $exporting_package => 1 );
85 return uniq( _follow_also_real($exporting_package) );
88 sub _follow_also_real {
89 my $exporting_package = shift;
91 if (!exists $EXPORT_SPEC{$exporting_package}) {
92 my $loaded = Class::MOP::is_class_loaded($exporting_package);
94 die "Package in also ($exporting_package) does not seem to "
95 . "use Moose::Exporter"
96 . ($loaded ? "" : " (is it loaded?)");
99 my $also = $EXPORT_SPEC{$exporting_package}{also};
101 return unless defined $also;
103 my @also = ref $also ? @{$also} : $also;
105 for my $package (@also)
107 die "Circular reference in 'also' parameter to Moose::Exporter between $exporting_package and $package"
108 if $seen->{$package};
110 $seen->{$package} = 1;
113 return @also, map { _follow_also_real($_) } @also;
117 sub _make_sub_exporter_params {
119 my $packages = shift;
120 my $export_recorder = shift;
125 for my $package ( @{$packages} ) {
126 my $args = $EXPORT_SPEC{$package}
127 or die "The $package package does not use Moose::Exporter\n";
129 for my $name ( @{ $args->{with_meta} } ) {
130 my $sub = $class->_sub_from_package( $package, $name )
133 my $fq_name = $package . '::' . $name;
135 $exports{$name} = $class->_make_wrapped_sub_with_meta(
141 $is_removable{$name} = 1;
144 for my $name ( @{ $args->{with_caller} } ) {
145 my $sub = $class->_sub_from_package( $package, $name )
148 my $fq_name = $package . '::' . $name;
150 $exports{$name} = $class->_make_wrapped_sub(
156 $is_removable{$name} = 1;
159 for my $name ( @{ $args->{as_is} } ) {
160 my ($sub, $coderef_name);
165 # Even though Moose re-exports things from Carp &
166 # Scalar::Util, we don't want to remove those at
167 # unimport time, because the importing package may
168 # have imported them explicitly ala
170 # use Carp qw( confess );
172 # This is a hack. Since we can't know whether they
173 # really want to keep these subs or not, we err on the
174 # safe side and leave them in.
176 ( $coderef_pkg, $coderef_name )
177 = Class::MOP::get_code_info($name);
179 $is_removable{$coderef_name} = $coderef_pkg eq $package ? 1 : 0;
182 $sub = $class->_sub_from_package( $package, $name )
185 $is_removable{$name} = 1;
186 $coderef_name = $name;
189 $export_recorder->{$sub} = 1;
191 $exports{$coderef_name} = sub {$sub};
195 return ( \%exports, \%is_removable );
198 sub _sub_from_package {
205 \&{ $package . '::' . $name };
208 return $sub if defined &$sub;
211 "Trying to export undefined sub ${package}::${name}";
218 sub _make_wrapped_sub {
222 my $export_recorder = shift;
224 # We need to set the package at import time, so that when
225 # package Foo imports has(), we capture "Foo" as the
226 # package. This lets other packages call Foo::has() and get
227 # the right package. This is done for backwards compatibility
228 # with existing production code, not because this is a good
231 my $caller = $CALLER;
233 my $wrapper = $self->_curry_wrapper($sub, $fq_name, $caller);
235 my $sub = subname($fq_name => $wrapper);
237 $export_recorder->{$sub} = 1;
243 sub _make_wrapped_sub_with_meta {
247 my $export_recorder = shift;
250 my $caller = $CALLER;
252 my $wrapper = $self->_late_curry_wrapper($sub, $fq_name,
253 sub { Class::MOP::class_of(shift) } => $caller);
255 my $sub = subname($fq_name => $wrapper);
257 $export_recorder->{$sub} = 1;
269 my $wrapper = sub { $sub->(@extra, @_) };
270 if (my $proto = prototype $sub) {
271 # XXX - Perl's prototype sucks. Use & to make set_prototype
272 # ignore the fact that we're passing "private variables"
273 &Scalar::Util::set_prototype($wrapper, $proto);
278 sub _late_curry_wrapper {
286 # resolve curried arguments at runtime via this closure
287 my @curry = ( $extra->( @ex_args ) );
288 return $sub->(@curry, @_);
291 if (my $proto = prototype $sub) {
292 # XXX - Perl's prototype sucks. Use & to make set_prototype
293 # ignore the fact that we're passing "private variables"
294 &Scalar::Util::set_prototype($wrapper, $proto);
299 sub _make_import_sub {
301 my $exporting_package = shift;
302 my $exporter = shift;
303 my $exports_from = shift;
304 my $export_to_main = shift;
308 # I think we could use Sub::Exporter's collector feature
309 # to do this, but that would be rather gross, since that
310 # feature isn't really designed to return a value to the
311 # caller of the exporter sub.
313 # Also, this makes sure we preserve backwards compat for
314 # _get_caller, so it always sees the arguments in the
317 ( $traits, @_ ) = _strip_traits(@_);
320 ( $metaclass, @_ ) = _strip_metaclass(@_);
321 $metaclass = Moose::Util::resolve_metaclass_alias(
322 'Class' => $metaclass
323 ) if defined $metaclass && length $metaclass;
325 # Normally we could look at $_[0], but in some weird cases
326 # (involving goto &Moose::import), $_[0] ends as something
327 # else (like Squirrel).
328 my $class = $exporting_package;
330 $CALLER = _get_caller(@_);
332 # this works because both pragmas set $^H (see perldoc
333 # perlvar) which affects the current compilation -
334 # i.e. the file who use'd us - which is why we don't need
335 # to do anything special to make it affect that file
336 # rather than this one (which is already compiled)
341 # we should never export to main
342 if ( $CALLER eq 'main' && !$export_to_main ) {
344 qq{$class does not export its sugar to the 'main' package.\n};
349 for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
350 # init_meta can apply a role, which when loaded uses
351 # Moose::Exporter, which in turn sets $CALLER, so we need
352 # to protect against that.
353 local $CALLER = $CALLER;
354 $c->init_meta( for_class => $CALLER, metaclass => $metaclass );
358 if ( $did_init_meta && @{$traits} ) {
359 # The traits will use Moose::Role, which in turn uses
360 # Moose::Exporter, which in turn sets $CALLER, so we need
361 # to protect against that.
362 local $CALLER = $CALLER;
363 _apply_meta_traits( $CALLER, $traits );
365 elsif ( @{$traits} ) {
368 "Cannot provide traits when $class does not have an init_meta() method"
378 my $idx = first_index { $_ eq '-traits' } @_;
380 return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
382 my $traits = $_[ $idx + 1 ];
386 $traits = [ $traits ] unless ref $traits;
388 return ( $traits, @_ );
391 sub _strip_metaclass {
392 my $idx = first_index { $_ eq '-metaclass' } @_;
394 return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
396 my $metaclass = $_[ $idx + 1 ];
400 return ( $metaclass, @_ );
403 sub _apply_meta_traits {
404 my ( $class, $traits ) = @_;
406 return unless @{$traits};
408 my $meta = Class::MOP::class_of($class);
410 my $type = ( split /::/, ref $meta )[-1]
411 or Moose->throw_error(
412 'Cannot determine metaclass type for trait application . Meta isa '
417 ref $_ ? $_ : Moose::Util::resolve_metatrait_alias( $type => $_ )
421 return unless @resolved_traits;
423 Moose::Util::MetaRole::apply_metaclass_roles(
425 metaclass_roles => \@resolved_traits,
430 # 1 extra level because it's called by import so there's a layer
435 ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
436 : ( ref $_[1] && defined $_[1]->{into_level} )
437 ? caller( $offset + $_[1]->{into_level} )
441 sub _make_unimport_sub {
443 my $exporting_package = shift;
445 my $is_removable = shift;
446 my $export_recorder = shift;
449 my $caller = scalar caller();
450 Moose::Exporter->_remove_keywords(
452 [ keys %{$exports} ],
459 sub _remove_keywords {
462 my $keywords = shift;
463 my $is_removable = shift;
464 my $recorded_exports = shift;
468 foreach my $name ( @{ $keywords } ) {
469 next unless $is_removable->{$name};
471 if ( defined &{ $package . '::' . $name } ) {
472 my $sub = \&{ $package . '::' . $name };
474 # make sure it is from us
475 next unless $recorded_exports->{$sub};
477 # and if it is from us, then undef the slot
478 delete ${ $package . '::' }{$name};
483 sub _make_init_meta {
494 wrapped_method_metaclass
499 application_to_class_class
500 application_to_role_class
501 application_to_instance_class)
503 $metaclass_roles{$role} = $args->{$role} if exists $args->{$role};
506 my %base_class_roles;
507 %base_class_roles = ( roles => $args->{base_class_roles} )
508 if exists $args->{base_class_roles};
510 return unless %metaclass_roles || %base_class_roles;
516 return unless Class::MOP::class_of( $options{for_class} );
518 Moose::Util::MetaRole::apply_metaclass_roles(
519 for_class => $options{for_class},
523 Moose::Util::MetaRole::apply_base_class_roles(
524 for_class => $options{for_class},
527 if Class::MOP::class_of( $options{for_class} )
528 ->isa('Moose::Meta::Class');
530 return Class::MOP::class_of( $options{for_class} );
545 Moose::Exporter - make an import() and unimport() just like Moose.pm
549 package MyApp::Moose;
554 Moose::Exporter->setup_import_methods(
555 with_meta => [ 'has_rw', 'sugar2' ],
556 as_is => [ 'sugar3', \&Some::Random::thing ],
561 my ( $meta, $name, %options ) = @_;
562 $meta->add_attribute(
582 This module encapsulates the exporting of sugar functions in a
583 C<Moose.pm>-like manner. It does this by building custom C<import>,
584 C<unimport>, and C<init_meta> methods for your module, based on a spec you
587 It also lets you "stack" Moose-alike modules so you can export Moose's sugar
588 as well as your own, along with sugar from any random C<MooseX> module, as
589 long as they all use C<Moose::Exporter>. This feature exists to let you bundle
590 a set of MooseX modules into a policy module that developers can use directly
591 instead of using Moose itself.
593 To simplify writing exporter modules, C<Moose::Exporter> also imports
594 C<strict> and C<warnings> into your exporter module, as well as into
599 This module provides two public methods:
603 =item B<< Moose::Exporter->setup_import_methods(...) >>
605 When you call this method, C<Moose::Exporter> builds custom C<import>,
606 C<unimport>, and C<init_meta> methods for your module. The C<import> method
607 will export the functions you specify, and can also re-export functions
608 exported by some other module (like C<Moose.pm>).
610 The C<unimport> method cleans the caller's namespace of all the exported
613 If you pass any parameters for L<Moose::Util::MetaRole>, this method will
614 generate an C<init_meta> for you as well (see below for details). This
615 C<init_meta> will call C<Moose::Util::MetaRole::apply_metaclass_roles> and
616 C<Moose::Util::MetaRole::apply_base_class_roles> as needed.
618 Note that if any of these methods already exist, they will not be
619 overridden, you will have to use C<build_import_methods> to get the
620 coderef that would be installed.
622 This method accepts the following parameters:
626 =item * with_meta => [ ... ]
628 This list of function I<names only> will be wrapped and then exported. The
629 wrapper will pass the metaclass object for the caller as its first argument.
631 Many sugar functions will need to use this metaclass object to do something to
634 =item * as_is => [ ... ]
636 This list of function names or sub references will be exported as-is. You can
637 identify a subroutine by reference, which is handy to re-export some other
638 module's functions directly by reference (C<\&Some::Package::function>).
640 If you do export some other package's function, this function will never be
641 removed by the C<unimport> method. The reason for this is we cannot know if
642 the caller I<also> explicitly imported the sub themselves, and therefore wants
645 =item * also => $name or \@names
647 This is a list of modules which contain functions that the caller
648 wants to export. These modules must also use C<Moose::Exporter>. The
649 most common use case will be to export the functions from C<Moose.pm>.
650 Functions specified by C<with_meta> or C<as_is> take precedence over
651 functions exported by modules specified by C<also>, so that a module
652 can selectively override functions exported by another module.
654 C<Moose::Exporter> also makes sure all these functions get removed
655 when C<unimport> is called.
659 Any of the C<*_roles> options for
660 C<Moose::Util::MetaRole::apply_metaclass_roles> and
661 C<Moose::Util::MetaRole::base_class_roles> are also acceptable.
663 =item B<< Moose::Exporter->build_import_methods(...) >>
665 Returns two or three code refs, one for C<import>, one for
666 C<unimport>, and optionally one for C<init_meta>, if the appropriate
667 options are passed in.
669 Accepts the additional C<install> option, which accepts an arrayref of method
670 names to install into your exporting package. The valid options are C<import>,
671 C<unimport>, and C<init_meta>. Calling C<setup_import_methods> is equivalent
672 to calling C<build_import_methods> with C<< install => [qw(import unimport
673 init_meta)] >> except that it doesn't also return the methods.
675 Used by C<setup_import_methods>.
679 =head1 IMPORTING AND init_meta
681 If you want to set an alternative base object class or metaclass class, see
682 above for details on how this module can call L<Moose::Util::MetaRole> for
685 If you want to do something that is not supported by this module, simply
686 define an C<init_meta> method in your class. The C<import> method that
687 C<Moose::Exporter> generates for you will call this method (if it exists). It
688 will always pass the caller to this method via the C<for_class> parameter.
690 Most of the time, your C<init_meta> method will probably just call C<<
691 Moose->init_meta >> to do the real work:
694 shift; # our class name
695 return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
698 Keep in mind that C<build_import_methods> will return an C<init_meta>
699 method for you, which you can also call from within your custom
702 my ( $import, $unimport, $init_meta ) =
703 Moose::Exporter->build_import_methods( ... );
710 $class->$import(...);
715 sub unimport { goto &$unimport }
722 $class->$init_meta(...);
727 =head1 METACLASS TRAITS
729 The C<import> method generated by C<Moose::Exporter> will allow the
730 user of your module to specify metaclass traits in a C<-traits>
731 parameter passed as part of the import:
733 use Moose -traits => 'My::Meta::Trait';
735 use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
737 These traits will be applied to the caller's metaclass
738 instance. Providing traits for an exporting class that does not create
739 a metaclass for the caller is an error.
743 Dave Rolsky E<lt>autarch@urth.orgE<gt>
745 This is largely a reworking of code in Moose.pm originally written by
746 Stevan Little and others.
748 =head1 COPYRIGHT AND LICENSE
750 Copyright 2009 by Infinity Interactive, Inc.
752 L<http://www.iinteractive.com>
754 This library is free software; you can redistribute it and/or modify
755 it under the same terms as Perl itself.