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 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, $groups )
42 = $class->_make_sub_exporter_params(
43 [ @exports_from, $exporting_package ], $export_recorder );
45 my $exporter = Sub::Exporter::build_exporter(
48 groups => { default => [':all'], %$groups }
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;
114 for my $package ( @{$packages} ) {
115 my $args = $EXPORT_SPEC{$package}
116 or die "The $package package does not use Moose::Exporter\n";
118 # one group for each 'also' package
119 $groups{$package} = [
120 @{ $args->{with_caller} || [] },
121 @{ $args->{with_meta} || [] },
122 @{ $args->{as_is} || [] },
124 keys %{ $args->{groups} || {} }
127 for my $name ( @{ $args->{with_caller} } ) {
130 \&{ $package . '::' . $name };
133 my $fq_name = $package . '::' . $name;
135 $exports{$name} = $class->_make_wrapped_sub(
141 $is_removable{$name} = 1;
144 for my $name ( @{ $args->{with_meta} } ) {
147 \&{ $package . '::' . $name };
150 my $fq_name = $package . '::' . $name;
152 $exports{$name} = $class->_make_wrapped_sub_with_meta(
158 $is_removable{$name} = 1;
161 for my $name ( @{ $args->{as_is} } ) {
167 # Even though Moose re-exports things from Carp &
168 # Scalar::Util, we don't want to remove those at
169 # unimport time, because the importing package may
170 # have imported them explicitly ala
172 # use Carp qw( confess );
174 # This is a hack. Since we can't know whether they
175 # really want to keep these subs or not, we err on the
176 # safe side and leave them in.
178 ( $coderef_pkg, $name ) = Class::MOP::get_code_info($name);
180 $is_removable{$name} = $coderef_pkg eq $package ? 1 : 0;
185 \&{ $package . '::' . $name };
188 $is_removable{$name} = 1;
191 $export_recorder->{$sub} = 1;
193 $exports{$name} = sub {$sub};
196 for my $name ( keys %{ $args->{groups} } ) {
197 my $group = $args->{groups}{$name};
199 if (ref $group eq 'CODE') {
200 $groups{$name} = $class->_make_wrapped_group(
208 elsif (ref $group eq 'ARRAY') {
209 $groups{$name} = $group;
214 return ( \%exports, \%is_removable, \%groups );
219 sub _make_wrapped_sub {
223 my $export_recorder = shift;
225 # We need to set the package at import time, so that when
226 # package Foo imports has(), we capture "Foo" as the
227 # package. This lets other packages call Foo::has() and get
228 # the right package. This is done for backwards compatibility
229 # with existing production code, not because this is a good
232 my $caller = $CALLER;
234 my $wrapper = $self->_curry_wrapper($sub, $fq_name, $caller);
236 my $sub = subname($fq_name => $wrapper);
238 $export_recorder->{$sub} = 1;
244 sub _make_wrapped_sub_with_meta {
248 my $export_recorder = shift;
251 my $caller = $CALLER;
253 my $wrapper = $self->_late_curry_wrapper($sub, $fq_name,
254 sub { Class::MOP::class_of(shift) } => $caller);
256 my $sub = subname($fq_name => $wrapper);
258 $export_recorder->{$sub} = 1;
264 sub _make_wrapped_group {
266 my $package = shift; # package calling use Moose::Exporter
268 my $export_recorder = shift;
269 my $keywords = shift;
270 my $is_removable = shift;
273 my $caller = $CALLER; # package calling use PackageUsingMooseExporter -group => {args}
275 # there are plenty of ways to deal with telling the code which
276 # package it lives in. the last arg (collector hashref) is
277 # otherwise unused, so we'll stick the original package in
278 # there and act like 'with_caller' by putting the calling
279 # package name as the first arg
281 $_[3]{from} = $package;
283 my $named_code = $sub->(@_);
286 # send invalid return value error up to Sub::Exporter
287 unless (ref $named_code eq 'HASH') {
291 for my $name (keys %$named_code) {
292 my $code = $named_code->{$name};
294 my $fq_name = $package . '::' . $name;
295 my $wrapper = $class->_curry_wrapper(
301 my $sub = subname( $fq_name => $wrapper );
302 $named_code->{$name} = $sub;
304 # mark each coderef as ours
305 $keywords->{$name} = 1;
306 $is_removable->{$name} = 1;
307 $export_recorder->{$sub} = 1;
320 my $wrapper = sub { $sub->(@extra, @_) };
321 if (my $proto = prototype $sub) {
322 # XXX - Perl's prototype sucks. Use & to make set_prototype
323 # ignore the fact that we're passing "private variables"
324 &Scalar::Util::set_prototype($wrapper, $proto);
329 sub _late_curry_wrapper {
337 # resolve curried arguments at runtime via this closure
338 my @curry = ( $extra->( @ex_args ) );
339 return $sub->(@curry, @_);
342 if (my $proto = prototype $sub) {
343 # XXX - Perl's prototype sucks. Use & to make set_prototype
344 # ignore the fact that we're passing "private variables"
345 &Scalar::Util::set_prototype($wrapper, $proto);
350 sub _make_import_sub {
352 my $exporting_package = shift;
353 my $exporter = shift;
354 my $exports_from = shift;
355 my $export_to_main = shift;
359 # I think we could use Sub::Exporter's collector feature
360 # to do this, but that would be rather gross, since that
361 # feature isn't really designed to return a value to the
362 # caller of the exporter sub.
364 # Also, this makes sure we preserve backwards compat for
365 # _get_caller, so it always sees the arguments in the
368 ( $traits, @_ ) = _strip_traits(@_);
371 ( $metaclass, @_ ) = _strip_metaclass(@_);
372 $metaclass = Moose::Util::resolve_metaclass_alias(
373 'Class' => $metaclass
374 ) if defined $metaclass && length $metaclass;
377 ( $superclasses, @_ ) = _strip_extends(@_);
379 # Normally we could look at $_[0], but in some weird cases
380 # (involving goto &Moose::import), $_[0] ends as something
381 # else (like Squirrel).
382 my $class = $exporting_package;
384 $CALLER = _get_caller(@_);
386 # this works because both pragmas set $^H (see perldoc
387 # perlvar) which affects the current compilation -
388 # i.e. the file who use'd us - which is why we don't need
389 # to do anything special to make it affect that file
390 # rather than this one (which is already compiled)
395 # we should never export to main
396 if ( $CALLER eq 'main' && !$export_to_main ) {
398 qq{$class does not export its sugar to the 'main' package.\n};
403 for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
404 # init_meta can apply a role, which when loaded uses
405 # Moose::Exporter, which in turn sets $CALLER, so we need
406 # to protect against that.
407 local $CALLER = $CALLER;
408 $c->init_meta( for_class => $CALLER, metaclass => $metaclass );
412 if(@{$superclasses}){
414 $CALLER->meta->superclasses(@{$superclasses});
418 Moose->throw_error("Cannot provide -extends when $class does not have an init_meta() method");
422 if ( $did_init_meta && @{$traits} ) {
423 # The traits will use Moose::Role, which in turn uses
424 # Moose::Exporter, which in turn sets $CALLER, so we need
425 # to protect against that.
426 local $CALLER = $CALLER;
427 _apply_meta_traits( $CALLER, $traits );
429 elsif ( @{$traits} ) {
432 "Cannot provide traits when $class does not have an init_meta() method"
442 my $idx = first_index { $_ eq '-traits' } @_;
444 return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
446 my $traits = $_[ $idx + 1 ];
450 $traits = [ $traits ] unless ref $traits;
452 return ( $traits, @_ );
455 sub _strip_metaclass {
456 my $idx = first_index { $_ eq '-metaclass' } @_;
458 return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
460 my $metaclass = $_[ $idx + 1 ];
464 return ( $metaclass, @_ );
468 my $idx = first_index { $_ eq '-extends' } @_;
470 return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
472 my $superclasses = $_[ $idx + 1 ];
476 $superclasses = [ $superclasses ] unless ref $superclasses;
478 return ( $superclasses, @_ );
481 sub _apply_meta_traits {
482 my ( $class, $traits ) = @_;
484 return unless @{$traits};
486 my $meta = Class::MOP::class_of($class);
488 my $type = ( split /::/, ref $meta )[-1]
489 or Moose->throw_error(
490 'Cannot determine metaclass type for trait application . Meta isa '
495 ref $_ ? $_ : Moose::Util::resolve_metatrait_alias( $type => $_ )
499 return unless @resolved_traits;
501 Moose::Util::MetaRole::apply_metaclass_roles(
503 metaclass_roles => \@resolved_traits,
508 # 1 extra level because it's called by import so there's a layer
513 ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
514 : ( ref $_[1] && defined $_[1]->{into_level} )
515 ? caller( $offset + $_[1]->{into_level} )
519 sub _make_unimport_sub {
521 my $exporting_package = shift;
523 my $is_removable = shift;
524 my $export_recorder = shift;
527 my $caller = scalar caller();
528 Moose::Exporter->_remove_keywords(
530 [ keys %{$exports} ],
537 sub _remove_keywords {
540 my $keywords = shift;
541 my $is_removable = shift;
542 my $recorded_exports = shift;
546 foreach my $name ( @{ $keywords } ) {
547 next unless $is_removable->{$name};
549 if ( defined &{ $package . '::' . $name } ) {
550 my $sub = \&{ $package . '::' . $name };
552 # make sure it is from us
553 next unless $recorded_exports->{$sub};
555 # and if it is from us, then undef the slot
556 delete ${ $package . '::' }{$name};
572 Moose::Exporter - make an import() and unimport() just like Moose.pm
576 package MyApp::Moose;
581 Moose::Exporter->setup_import_methods(
582 with_caller => [ 'has_rw', 'sugar2' ],
583 as_is => [ 'sugar3', \&Some::Random::thing ],
588 my ($caller, $name, %options) = @_;
589 Class::MOP::class_of($caller)->add_attribute($name,
608 This module encapsulates the exporting of sugar functions in a
609 C<Moose.pm>-like manner. It does this by building custom C<import> and
610 C<unimport> methods for your module, based on a spec you provide.
612 It also lets you "stack" Moose-alike modules so you can export
613 Moose's sugar as well as your own, along with sugar from any random
614 C<MooseX> module, as long as they all use C<Moose::Exporter>.
616 To simplify writing exporter modules, C<Moose::Exporter> also imports
617 C<strict> and C<warnings> into your exporter module, as well as into
622 This module provides two public methods:
626 =item B<< Moose::Exporter->setup_import_methods(...) >>
628 When you call this method, C<Moose::Exporter> build custom C<import>
629 and C<unimport> methods for your module. The import method will export
630 the functions you specify, and you can also tell it to export
631 functions exported by some other module (like C<Moose.pm>).
633 The C<unimport> method cleans the callers namespace of all the
636 This method accepts the following parameters:
640 =item * with_caller => [ ... ]
642 This a list of function I<names only> to be exported wrapped and then
643 exported. The wrapper will pass the name of the calling package as the
644 first argument to the function. Many sugar functions need to know
645 their caller so they can get the calling package's metaclass object.
647 =item * as_is => [ ... ]
649 This a list of function names or sub references to be exported
650 as-is. You can identify a subroutine by reference, which is handy to
651 re-export some other module's functions directly by reference
652 (C<\&Some::Package::function>).
654 If you do export some other packages function, this function will
655 never be removed by the C<unimport> method. The reason for this is we
656 cannot know if the caller I<also> explicitly imported the sub
657 themselves, and therefore wants to keep it.
659 =item * also => $name or \@names
661 This is a list of modules which contain functions that the caller
662 wants to export. These modules must also use C<Moose::Exporter>. The
663 most common use case will be to export the functions from C<Moose.pm>.
664 Functions specified by C<with_caller> or C<as_is> take precedence over
665 functions exported by modules specified by C<also>, so that a module
666 can selectively override functions exported by another module.
668 C<Moose::Exporter> also makes sure all these functions get removed
669 when C<unimport> is called.
673 =item B<< Moose::Exporter->build_import_methods(...) >>
675 Returns two code refs, one for import and one for unimport.
677 Used by C<setup_import_methods>.
681 =head1 IMPORTING AND init_meta
683 If you want to set an alternative base object class or metaclass
684 class, simply define an C<init_meta> method in your class. The
685 C<import> method that C<Moose::Exporter> generates for you will call
686 this method (if it exists). It will always pass the caller to this
687 method via the C<for_class> parameter.
689 Most of the time, your C<init_meta> method will probably just call C<<
690 Moose->init_meta >> to do the real work:
693 shift; # our class name
694 return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
697 =head1 METACLASS TRAITS
699 The C<import> method generated by C<Moose::Exporter> will allow the
700 user of your module to specify metaclass traits in a C<-traits>
701 parameter passed as part of the import:
703 use Moose -traits => 'My::Meta::Trait';
705 use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
707 These traits will be applied to the caller's metaclass
708 instance. Providing traits for an exporting class that does not create
709 a metaclass for the caller is an error.
713 Dave Rolsky E<lt>autarch@urth.orgE<gt>
715 This is largely a reworking of code in Moose.pm originally written by
716 Stevan Little and others.
718 =head1 COPYRIGHT AND LICENSE
720 Copyright 2009 by Infinity Interactive, Inc.
722 L<http://www.iinteractive.com>
724 This library is free software; you can redistribute it and/or modify
725 it under the same terms as Perl itself.