1 package Moose::Exporter;
6 our $VERSION = '0.89_01';
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 if ( !defined(&$sub) ) {
135 "Trying to export undefined sub ${package}::${name}";
139 my $fq_name = $package . '::' . $name;
141 $exports{$name} = $class->_make_wrapped_sub(
147 $is_removable{$name} = 1;
150 for my $name ( @{ $args->{with_meta} } ) {
153 \&{ $package . '::' . $name };
156 if ( !defined(&$sub) ) {
158 "Trying to export undefined sub ${package}::${name}";
162 my $fq_name = $package . '::' . $name;
164 $exports{$name} = $class->_make_wrapped_sub_with_meta(
170 $is_removable{$name} = 1;
173 for my $name ( @{ $args->{as_is} } ) {
174 my ($sub, $coderef_name);
179 # Even though Moose re-exports things from Carp &
180 # Scalar::Util, we don't want to remove those at
181 # unimport time, because the importing package may
182 # have imported them explicitly ala
184 # use Carp qw( confess );
186 # This is a hack. Since we can't know whether they
187 # really want to keep these subs or not, we err on the
188 # safe side and leave them in.
190 ( $coderef_pkg, $coderef_name )
191 = Class::MOP::get_code_info($name);
193 $is_removable{$coderef_name} = $coderef_pkg eq $package ? 1 : 0;
198 \&{ $package . '::' . $name };
201 if ( !defined(&$sub) ) {
203 "Trying to export undefined sub ${package}::${name}";
207 $is_removable{$name} = 1;
208 $coderef_name = $name;
211 $export_recorder->{$sub} = 1;
213 $exports{$coderef_name} = sub {$sub};
216 for my $name ( keys %{ $args->{groups} } ) {
217 my $group = $args->{groups}{$name};
219 if (ref $group eq 'CODE') {
220 $groups{$name} = $class->_make_wrapped_group(
228 elsif (ref $group eq 'ARRAY') {
229 $groups{$name} = $group;
234 return ( \%exports, \%is_removable, \%groups );
239 sub _make_wrapped_sub {
243 my $export_recorder = shift;
245 # We need to set the package at import time, so that when
246 # package Foo imports has(), we capture "Foo" as the
247 # package. This lets other packages call Foo::has() and get
248 # the right package. This is done for backwards compatibility
249 # with existing production code, not because this is a good
252 my $caller = $CALLER;
254 my $wrapper = $self->_curry_wrapper($sub, $fq_name, $caller);
256 my $sub = subname($fq_name => $wrapper);
258 $export_recorder->{$sub} = 1;
264 sub _make_wrapped_sub_with_meta {
268 my $export_recorder = shift;
271 my $caller = $CALLER;
273 my $wrapper = $self->_late_curry_wrapper($sub, $fq_name,
274 sub { Class::MOP::class_of(shift) } => $caller);
276 my $sub = subname($fq_name => $wrapper);
278 $export_recorder->{$sub} = 1;
284 sub _make_wrapped_group {
286 my $package = shift; # package calling use Moose::Exporter
288 my $export_recorder = shift;
289 my $keywords = shift;
290 my $is_removable = shift;
293 my $caller = $CALLER; # package calling use PackageUsingMooseExporter -group => {args}
295 # there are plenty of ways to deal with telling the code which
296 # package it lives in. the last arg (collector hashref) is
297 # otherwise unused, so we'll stick the original package in
298 # there and act like 'with_caller' by putting the calling
299 # package name as the first arg
301 $_[3]{from} = $package;
303 my $named_code = $sub->(@_);
306 # send invalid return value error up to Sub::Exporter
307 unless (ref $named_code eq 'HASH') {
311 for my $name (keys %$named_code) {
312 my $code = $named_code->{$name};
314 my $fq_name = $package . '::' . $name;
315 my $wrapper = $class->_curry_wrapper(
321 my $sub = subname( $fq_name => $wrapper );
322 $named_code->{$name} = $sub;
324 # mark each coderef as ours
325 $keywords->{$name} = 1;
326 $is_removable->{$name} = 1;
327 $export_recorder->{$sub} = 1;
340 my $wrapper = sub { $sub->(@extra, @_) };
341 if (my $proto = prototype $sub) {
342 # XXX - Perl's prototype sucks. Use & to make set_prototype
343 # ignore the fact that we're passing "private variables"
344 &Scalar::Util::set_prototype($wrapper, $proto);
349 sub _late_curry_wrapper {
357 # resolve curried arguments at runtime via this closure
358 my @curry = ( $extra->( @ex_args ) );
359 return $sub->(@curry, @_);
362 if (my $proto = prototype $sub) {
363 # XXX - Perl's prototype sucks. Use & to make set_prototype
364 # ignore the fact that we're passing "private variables"
365 &Scalar::Util::set_prototype($wrapper, $proto);
370 sub _make_import_sub {
372 my $exporting_package = shift;
373 my $exporter = shift;
374 my $exports_from = shift;
375 my $export_to_main = shift;
379 # I think we could use Sub::Exporter's collector feature
380 # to do this, but that would be rather gross, since that
381 # feature isn't really designed to return a value to the
382 # caller of the exporter sub.
384 # Also, this makes sure we preserve backwards compat for
385 # _get_caller, so it always sees the arguments in the
388 ( $traits, @_ ) = _strip_traits(@_);
391 ( $metaclass, @_ ) = _strip_metaclass(@_);
392 $metaclass = Moose::Util::resolve_metaclass_alias(
393 'Class' => $metaclass
394 ) if defined $metaclass && length $metaclass;
396 # Normally we could look at $_[0], but in some weird cases
397 # (involving goto &Moose::import), $_[0] ends as something
398 # else (like Squirrel).
399 my $class = $exporting_package;
401 $CALLER = _get_caller(@_);
403 # this works because both pragmas set $^H (see perldoc
404 # perlvar) which affects the current compilation -
405 # i.e. the file who use'd us - which is why we don't need
406 # to do anything special to make it affect that file
407 # rather than this one (which is already compiled)
412 # we should never export to main
413 if ( $CALLER eq 'main' && !$export_to_main ) {
415 qq{$class does not export its sugar to the 'main' package.\n};
420 for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
421 # init_meta can apply a role, which when loaded uses
422 # Moose::Exporter, which in turn sets $CALLER, so we need
423 # to protect against that.
424 local $CALLER = $CALLER;
425 $c->init_meta( for_class => $CALLER, metaclass => $metaclass );
429 if ( $did_init_meta && @{$traits} ) {
430 # The traits will use Moose::Role, which in turn uses
431 # Moose::Exporter, which in turn sets $CALLER, so we need
432 # to protect against that.
433 local $CALLER = $CALLER;
434 _apply_meta_traits( $CALLER, $traits );
436 elsif ( @{$traits} ) {
439 "Cannot provide traits when $class does not have an init_meta() method"
449 my $idx = first_index { $_ eq '-traits' } @_;
451 return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
453 my $traits = $_[ $idx + 1 ];
457 $traits = [ $traits ] unless ref $traits;
459 return ( $traits, @_ );
462 sub _strip_metaclass {
463 my $idx = first_index { $_ eq '-metaclass' } @_;
465 return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
467 my $metaclass = $_[ $idx + 1 ];
471 return ( $metaclass, @_ );
474 sub _apply_meta_traits {
475 my ( $class, $traits ) = @_;
477 return unless @{$traits};
479 my $meta = Class::MOP::class_of($class);
481 my $type = ( split /::/, ref $meta )[-1]
482 or Moose->throw_error(
483 'Cannot determine metaclass type for trait application . Meta isa '
488 ref $_ ? $_ : Moose::Util::resolve_metatrait_alias( $type => $_ )
492 return unless @resolved_traits;
494 Moose::Util::MetaRole::apply_metaclass_roles(
496 metaclass_roles => \@resolved_traits,
501 # 1 extra level because it's called by import so there's a layer
506 ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
507 : ( ref $_[1] && defined $_[1]->{into_level} )
508 ? caller( $offset + $_[1]->{into_level} )
512 sub _make_unimport_sub {
514 my $exporting_package = shift;
516 my $is_removable = shift;
517 my $export_recorder = shift;
520 my $caller = scalar caller();
521 Moose::Exporter->_remove_keywords(
523 [ keys %{$exports} ],
530 sub _remove_keywords {
533 my $keywords = shift;
534 my $is_removable = shift;
535 my $recorded_exports = shift;
539 foreach my $name ( @{ $keywords } ) {
540 next unless $is_removable->{$name};
542 if ( defined &{ $package . '::' . $name } ) {
543 my $sub = \&{ $package . '::' . $name };
545 # make sure it is from us
546 next unless $recorded_exports->{$sub};
548 # and if it is from us, then undef the slot
549 delete ${ $package . '::' }{$name};
565 Moose::Exporter - make an import() and unimport() just like Moose.pm
569 package MyApp::Moose;
574 Moose::Exporter->setup_import_methods(
575 with_caller => [ 'has_rw', 'sugar2' ],
576 as_is => [ 'sugar3', \&Some::Random::thing ],
581 my ($caller, $name, %options) = @_;
582 Class::MOP::class_of($caller)->add_attribute($name,
601 This module encapsulates the exporting of sugar functions in a
602 C<Moose.pm>-like manner. It does this by building custom C<import> and
603 C<unimport> methods for your module, based on a spec you provide.
605 It also lets you "stack" Moose-alike modules so you can export
606 Moose's sugar as well as your own, along with sugar from any random
607 C<MooseX> module, as long as they all use C<Moose::Exporter>.
609 To simplify writing exporter modules, C<Moose::Exporter> also imports
610 C<strict> and C<warnings> into your exporter module, as well as into
615 This module provides two public methods:
619 =item B<< Moose::Exporter->setup_import_methods(...) >>
621 When you call this method, C<Moose::Exporter> build custom C<import>
622 and C<unimport> methods for your module. The import method will export
623 the functions you specify, and you can also tell it to export
624 functions exported by some other module (like C<Moose.pm>).
626 The C<unimport> method cleans the callers namespace of all the
629 This method accepts the following parameters:
633 =item * with_caller => [ ... ]
635 This a list of function I<names only> to be exported wrapped and then
636 exported. The wrapper will pass the name of the calling package as the
637 first argument to the function. Many sugar functions need to know
638 their caller so they can get the calling package's metaclass object.
640 =item * as_is => [ ... ]
642 This a list of function names or sub references to be exported
643 as-is. You can identify a subroutine by reference, which is handy to
644 re-export some other module's functions directly by reference
645 (C<\&Some::Package::function>).
647 If you do export some other packages function, this function will
648 never be removed by the C<unimport> method. The reason for this is we
649 cannot know if the caller I<also> explicitly imported the sub
650 themselves, and therefore wants to keep it.
652 =item * also => $name or \@names
654 This is a list of modules which contain functions that the caller
655 wants to export. These modules must also use C<Moose::Exporter>. The
656 most common use case will be to export the functions from C<Moose.pm>.
657 Functions specified by C<with_caller> or C<as_is> take precedence over
658 functions exported by modules specified by C<also>, so that a module
659 can selectively override functions exported by another module.
661 C<Moose::Exporter> also makes sure all these functions get removed
662 when C<unimport> is called.
666 =item B<< Moose::Exporter->build_import_methods(...) >>
668 Returns two code refs, one for import and one for unimport.
670 Used by C<setup_import_methods>.
674 =head1 IMPORTING AND init_meta
676 If you want to set an alternative base object class or metaclass
677 class, simply define an C<init_meta> method in your class. The
678 C<import> method that C<Moose::Exporter> generates for you will call
679 this method (if it exists). It will always pass the caller to this
680 method via the C<for_class> parameter.
682 Most of the time, your C<init_meta> method will probably just call C<<
683 Moose->init_meta >> to do the real work:
686 shift; # our class name
687 return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
690 =head1 METACLASS TRAITS
692 The C<import> method generated by C<Moose::Exporter> will allow the
693 user of your module to specify metaclass traits in a C<-traits>
694 parameter passed as part of the import:
696 use Moose -traits => 'My::Meta::Trait';
698 use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
700 These traits will be applied to the caller's metaclass
701 instance. Providing traits for an exporting class that does not create
702 a metaclass for the caller is an error.
706 Dave Rolsky E<lt>autarch@urth.orgE<gt>
708 This is largely a reworking of code in Moose.pm originally written by
709 Stevan Little and others.
711 =head1 COPYRIGHT AND LICENSE
713 Copyright 2009 by Infinity Interactive, Inc.
715 L<http://www.iinteractive.com>
717 This library is free software; you can redistribute it and/or modify
718 it under the same terms as Perl itself.