X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FExporter.pm;h=9d4d64ceddd47bd90c3ef8326445e3ad20ec4875;hb=f8a5a70e3ae839c559ea3ae0f921c0eb734a94f4;hp=3b9058438d8df6a8a394b9a10396a8c7f2f5c0b9;hpb=42ade26968f2f4298bd25f449752ef483f6fb479;p=gitmo%2FMoose.git diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm index 3b90584..9d4d64c 100644 --- a/lib/Moose/Exporter.pm +++ b/lib/Moose/Exporter.pm @@ -3,25 +3,37 @@ package Moose::Exporter; use strict; use warnings; +use Carp qw( confess ); use Class::MOP; -use List::MoreUtils qw( uniq ); +use List::MoreUtils qw( first_index uniq ); use Sub::Exporter; my %EXPORT_SPEC; +sub setup_import_methods { + my ( $class, %args ) = @_; + + my $exporting_package = $args{exporting_package} ||= caller(); + + my ( $import, $unimport ) = $class->build_import_methods(%args); + + no strict 'refs'; + *{ $exporting_package . '::import' } = $import; + *{ $exporting_package . '::unimport' } = $unimport; +} + sub build_import_methods { - my $class = shift; - my %args = @_; + my ( $class, %args ) = @_; - my $exporting_package = caller(); + my $exporting_package = $args{exporting_package} ||= caller(); $EXPORT_SPEC{$exporting_package} = \%args; my @exports_from = $class->_follow_also( $exporting_package ); my $exports - = $class->_process_exports( $exporting_package, @exports_from ); + = $class->_make_sub_exporter_params( $exporting_package, @exports_from ); my $exporter = Sub::Exporter::build_exporter( { @@ -30,23 +42,27 @@ sub build_import_methods { } ); - my $import = $class->_make_import_sub( $exporter, \@exports_from ); + # $args{_export_to_main} exists for backwards compat, because + # Moose::Util::TypeConstraints did export to main (unlike Moose & + # Moose::Role). + my $import = $class->_make_import_sub( $exporting_package, $exporter, + \@exports_from, $args{_export_to_main} ); - my $unimport = $class->_make_unimport_sub( \@exports_from, [ keys %{$exports} ] ); + my $unimport + = $class->_make_unimport_sub( $exporting_package, \@exports_from, + [ keys %{$exports} ] ); - no strict 'refs'; - *{ $exporting_package . '::import' } = $import; - *{ $exporting_package . '::unimport' } = $unimport; + return ( $import, $unimport ) } { - my %seen; + my $seen = {}; sub _follow_also { my $class = shift; my $exporting_package = shift; - %seen = ( $exporting_package => 1 ); + local %$seen = ( $exporting_package => 1 ); return uniq( _follow_also_real($exporting_package) ); } @@ -66,16 +82,16 @@ sub build_import_methods { for my $package (@also) { die "Circular reference in also parameter to MooseX::Exporter between $exporting_package and $package" - if $seen{$package}; + if $seen->{$package}; - $seen{$package} = 1; + $seen->{$package} = 1; } return @also, map { _follow_also_real($_) } @also; } } -sub _process_exports { +sub _make_sub_exporter_params { my $class = shift; my @packages = @_; @@ -152,14 +168,27 @@ sub _process_exports { sub _make_import_sub { shift; - my $exporter = shift; - my $exports_from = shift; + my $exporting_package = shift; + my $exporter = shift; + my $exports_from = shift; + my $export_to_main = shift; return sub { - - # It's important to leave @_ as-is for the benefit of - # Sub::Exporter. - my $class = $_[0]; + # I think we could use Sub::Exporter's collector feature + # to do this, but that would be rather gross, since that + # feature isn't really designed to return a value to the + # caller of the exporter sub. + # + # Also, this makes sure we preserve backwards compat for + # _get_caller, so it always sees the arguments in the + # expected order. + my $traits; + ($traits, @_) = Moose::Exporter::_strip_traits(@_); + + # Normally we could look at $_[0], but in some weird cases + # (involving goto &Moose::import), $_[0] ends as something + # else (like Squirrel). + my $class = $exporting_package; $CALLER = Moose::Exporter::_get_caller(@_); @@ -173,15 +202,25 @@ sub _process_exports { warnings->import; # we should never export to main - if ( $CALLER eq 'main' ) { + if ( $CALLER eq 'main' && ! $export_to_main ) { warn qq{$class does not export its sugar to the 'main' package.\n}; return; } - for my $c (grep { $_->can('init_meta') } $class, @{$exports_from} ) { + my $did_init_meta; + for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) { $c->init_meta( for_class => $CALLER ); + $did_init_meta = 1; + } + + if ($did_init_meta) { + _apply_meta_traits( $CALLER, $traits ); + } + elsif ( $traits && @{$traits} ) { + confess + "Cannot provide traits when $class does not have an init_meta() method"; } goto $exporter; @@ -189,6 +228,50 @@ sub _process_exports { } } +sub _strip_traits { + my $idx = first_index { $_ eq '-traits' } @_; + + return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1; + + my $traits = $_[ $idx + 1 ]; + + splice @_, $idx, 2; + + $traits = [ $traits ] unless ref $traits; + + return ( $traits, @_ ); +} + +sub _apply_meta_traits { + my ( $class, $traits ) = @_; + + return + unless $traits && @$traits; + + my $meta = $class->meta(); + + my $type = ( split /::/, ref $meta )[-1] + or confess + 'Cannot determine metaclass type for trait application . Meta isa ' + . ref $meta; + + # We can only call does_role() on Moose::Meta::Class objects, and + # we can only do that on $meta->meta() if it has already had at + # least one trait applied to it. By default $meta->meta() returns + # a Class::MOP::Class object (not a Moose::Meta::Class). + my @traits = grep { + $meta->meta()->can('does_role') + ? not $meta->meta()->does_role($_) + : 1 + } + map { Moose::Util::resolve_metatrait_alias( $type => $_ ) } @$traits; + + return unless @traits; + + Moose::Util::apply_all_roles_with_method( $meta, + 'apply_to_metaclass_instance', \@traits ); +} + sub _get_caller { # 1 extra level because it's called by import so there's a layer # of indirection @@ -203,15 +286,15 @@ sub _get_caller { sub _make_unimport_sub { shift; - my $sources = shift; - my $keywords = shift; + my $exporting_package = shift; + my $sources = shift; + my $keywords = shift; return sub { - my $class = shift; my $caller = scalar caller(); Moose::Exporter->_remove_keywords( $caller, - [ $class, @{$sources} ], + [ $exporting_package, @{$sources} ], $keywords ); }; @@ -262,9 +345,10 @@ Moose::Exporter - make an import() and unimport() just like Moose.pm use Moose (); use Moose::Exporter; - Moose::Exporter->build_export_methods( - export => [ 'sugar1', 'sugar2', \&Some::Random::thing ], - init_meta_args => { metaclass_class => 'MyApp::Meta::Class' ], + Moose::Exporter->setup_import_methods( + with_caller => [ 'sugar1', 'sugar2' ], + as_is => [ 'sugar3', \&Some::Random::thing ], + also => 'Moose', ); # then later ... @@ -290,9 +374,9 @@ C module, as long as they all use C. =head1 METHODS -This module provides exactly one public method: +This module provides two public methods: -=head2 Moose::Exporter->build_import_methods(...) +=head2 Moose::Exporter->setup_import_methods(...) When you call this method, C build custom C and C methods for your module. The import method will export @@ -331,6 +415,12 @@ when C is called. =back +=head2 Moose::Exporter->build_import_methods(...) + +Returns two code refs, one for import and one for unimport. + +Used by C. + =head1 IMPORTING AND init_meta If you want to set an alternative base object class or metaclass @@ -347,6 +437,20 @@ Moose->init_meta >> to do the real work: return Moose->init_meta( @_, metaclass => 'My::Metaclass' ); } +=head1 METACLASS TRAITS + +The C method generated by C will allow the +user of your module to specify metaclass traits in a C<-traits> +parameter passed as part of the import: + + use Moose -traits => 'My::Meta::Trait'; + + use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ]; + +These traits will be applied to the caller's metaclass +instance. Providing traits for an exporting class that does not create +a metaclass for the caller is an error. + =head1 AUTHOR Dave Rolsky Eautarch@urth.orgE