X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FExporter.pm;h=da46de8c5cd954c7938546482c995d602ec13a84;hb=c1d8ed59400ff7c4beac6b0266b5e28d6b7b6313;hp=15a918cccde55a7ecf0b5e46e4c4ddb3c6265502;hpb=38bf2a2585e26a47c919fd4c286b7716acb51c00;p=gitmo%2FMoose.git diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm index 15a918c..da46de8 100644 --- a/lib/Moose/Exporter.pm +++ b/lib/Moose/Exporter.pm @@ -3,17 +3,7 @@ package Moose::Exporter; use strict; use warnings; -our $AUTHORITY = 'cpan:STEVAN'; - -use XSLoader; - -BEGIN { - XSLoader::load( - 'Moose', - $Moose::{VERSION} ? $Moose::{VERSION} : () - ); -} - +use Class::Load qw(is_class_loaded); use Class::MOP; use List::MoreUtils qw( first_index uniq ); use Moose::Util::MetaRole; @@ -26,7 +16,7 @@ my %EXPORT_SPEC; sub setup_import_methods { my ( $class, %args ) = @_; - my $exporting_package = $args{exporting_package} ||= caller(); + $args{exporting_package} ||= caller(); $class->build_import_methods( %args, @@ -34,11 +24,17 @@ sub setup_import_methods { ); } +# A reminder to intrepid Moose hackers +# there may be more than one level of exporter +# don't make doy cry. -- perigrin + sub build_import_methods { my ( $class, %args ) = @_; my $exporting_package = $args{exporting_package} ||= caller(); + my $meta_lookup = $args{meta_lookup} || sub { Class::MOP::class_of(shift) }; + $EXPORT_SPEC{$exporting_package} = \%args; my @exports_from = $class->_follow_also($exporting_package); @@ -47,31 +43,39 @@ sub build_import_methods { my $is_reexport = {}; my $exports = $class->_make_sub_exporter_params( - [ @exports_from, $exporting_package ], + [ $exporting_package, @exports_from ], $export_recorder, $is_reexport, + $args{meta_lookup}, # so that we don't pass through the default ); - my $exporter = $class->_make_exporter($exports, $is_reexport); + my $exporter = $class->_make_exporter( + $exports, + $is_reexport, + $meta_lookup, + ); my %methods; $methods{import} = $class->_make_import_sub( $exporting_package, $exporter, \@exports_from, - $is_reexport + $is_reexport, + $meta_lookup, ); $methods{unimport} = $class->_make_unimport_sub( $exporting_package, $exports, $export_recorder, - $is_reexport + $is_reexport, + $meta_lookup, ); $methods{init_meta} = $class->_make_init_meta( $exporting_package, - \%args + \%args, + $meta_lookup, ); my $package = Class::MOP::Package->initialize($exporting_package); @@ -87,7 +91,7 @@ sub build_import_methods { } sub _make_exporter { - my ($class, $exports, $is_reexport) = @_; + my ($class, $exports, $is_reexport, $meta_lookup) = @_; return Sub::Exporter::build_exporter( { @@ -95,7 +99,7 @@ sub _make_exporter { groups => { default => [':all'] }, installer => sub { my ($arg, $to_export) = @_; - my $meta = Class::MOP::class_of($arg->{into}); + my $meta = $meta_lookup->($arg->{into}); goto &Sub::Exporter::default_installer unless $meta; @@ -129,44 +133,71 @@ sub _make_exporter { ); } -{ - my $seen = {}; +sub _follow_also { + my $class = shift; + my $exporting_package = shift; + + _die_if_cycle_found_in_also_list_for_package($exporting_package); - sub _follow_also { - my $class = shift; - my $exporting_package = shift; + return uniq( _follow_also_real($exporting_package) ); +} - local %$seen = ( $exporting_package => 1 ); +sub _follow_also_real { + my $exporting_package = shift; + my @also = _also_list_for_package($exporting_package); - return uniq( _follow_also_real($exporting_package) ); + return map { $_, _follow_also_real($_) } @also; +} + +sub _also_list_for_package { + my $package = shift; + + if ( !exists $EXPORT_SPEC{$package} ) { + my $loaded = is_class_loaded($package); + + die "Package in also ($package) does not seem to " + . "use Moose::Exporter" + . ( $loaded ? "" : " (is it loaded?)" ); } - sub _follow_also_real { - my $exporting_package = shift; + my $also = $EXPORT_SPEC{$package}{also}; - if ( !exists $EXPORT_SPEC{$exporting_package} ) { - my $loaded = Class::MOP::is_class_loaded($exporting_package); + return unless defined $also; - die "Package in also ($exporting_package) does not seem to " - . "use Moose::Exporter" - . ( $loaded ? "" : " (is it loaded?)" ); - } + return ref $also ? @$also : $also; +} + +# this is no Tarjan algorithm, but for the list sizes expected, +# brute force will probably be fine (and more maintainable) +sub _die_if_cycle_found_in_also_list_for_package { + my $package = shift; + _die_if_also_list_cycles_back_to_existing_stack( + [ _also_list_for_package($package) ], + [$package], + ); +} - my $also = $EXPORT_SPEC{$exporting_package}{also}; +sub _die_if_also_list_cycles_back_to_existing_stack { + my ( $also_list, $existing_stack ) = @_; - return unless defined $also; + return unless @$also_list && @$existing_stack; - my @also = ref $also ? @{$also} : $also; + for my $also_member (@$also_list) { + for my $stack_member (@$existing_stack) { + next unless $also_member eq $stack_member; - for my $package (@also) { die - "Circular reference in 'also' parameter to Moose::Exporter between $exporting_package and $package" - if $seen->{$package}; - - $seen->{$package} = 1; + "Circular reference in 'also' parameter to Moose::Exporter between " + . join( + ', ', + @$existing_stack + ) . " and $also_member"; } - return @also, map { _follow_also_real($_) } @also; + _die_if_also_list_cycles_back_to_existing_stack( + [ _also_list_for_package($also_member) ], + [ $also_member, @$existing_stack ], + ); } } @@ -195,17 +226,25 @@ sub _parse_trait_aliases { } sub _make_sub_exporter_params { - my $class = shift; - my $packages = shift; - my $export_recorder = shift; - my $is_reexport = shift; + my $class = shift; + my $packages = shift; + my $export_recorder = shift; + my $is_reexport = shift; + my $meta_lookup_override = shift; my %exports; + my $current_meta_lookup; for my $package ( @{$packages} ) { my $args = $EXPORT_SPEC{$package} or die "The $package package does not use Moose::Exporter\n"; + $current_meta_lookup = $meta_lookup_override || $args->{meta_lookup}; + $meta_lookup_override = $current_meta_lookup; + + my $meta_lookup = $current_meta_lookup + || sub { Class::MOP::class_of(shift) }; + for my $name ( @{ $args->{with_meta} } ) { my $sub = $class->_sub_from_package( $package, $name ) or next; @@ -216,7 +255,8 @@ sub _make_sub_exporter_params { $fq_name, $sub, $export_recorder, - ); + $meta_lookup, + ) unless exists $exports{$name}; } for my $name ( @{ $args->{with_caller} } ) { @@ -229,7 +269,7 @@ sub _make_sub_exporter_params { $fq_name, $sub, $export_recorder, - ); + ) unless exists $exports{$name}; } my @extra_exports = $class->_parse_trait_aliases( @@ -258,7 +298,8 @@ sub _make_sub_exporter_params { $export_recorder->{$sub} = 1; - $exports{$coderef_name} = sub {$sub}; + $exports{$coderef_name} = sub { $sub } + unless exists $exports{$coderef_name}; } } @@ -314,13 +355,14 @@ sub _make_wrapped_sub_with_meta { my $fq_name = shift; my $sub = shift; my $export_recorder = shift; + my $meta_lookup = shift; return sub { my $caller = $CALLER; my $wrapper = $self->_late_curry_wrapper( $sub, $fq_name, - sub { Class::MOP::class_of(shift) } => $caller + $meta_lookup => $caller ); my $sub = subname( $fq_name => $wrapper ); @@ -375,7 +417,8 @@ sub _make_import_sub { my $exporting_package = shift; my $exporter = shift; my $exports_from = shift; - my $is_reexport = shift; + my $is_reexport = shift; + my $meta_lookup = shift; return sub { @@ -430,13 +473,25 @@ sub _make_import_sub { $did_init_meta = 1; } + { + # The metaroles will use Moose::Role, which in turn uses + # Moose::Exporter, which in turn sets $CALLER, so we need + # to protect against that. + local $CALLER = $CALLER; + _apply_metaroles( + $CALLER, + [$class, @$exports_from], + $meta_lookup + ); + } + if ( $did_init_meta && @{$traits} ) { # The traits will use Moose::Role, which in turn uses # Moose::Exporter, which in turn sets $CALLER, so we need # to protect against that. local $CALLER = $CALLER; - _apply_meta_traits( $CALLER, $traits ); + _apply_meta_traits( $CALLER, $traits, $meta_lookup ); } elsif ( @{$traits} ) { require Moose; @@ -496,12 +551,96 @@ sub _strip_meta_name { return ( $meta_name, @_ ); } +sub _apply_metaroles { + my ($class, $exports_from, $meta_lookup) = @_; + + my $metaroles = _collect_metaroles($exports_from); + my $base_class_roles = delete $metaroles->{base_class_roles}; + + my $meta = $meta_lookup->($class); + # for instance, Moose.pm uses Moose::Util::TypeConstraints + return unless $meta; + + Moose::Util::MetaRole::apply_metaroles( + for => $meta, + %$metaroles, + ) if keys %$metaroles; + + Moose::Util::MetaRole::apply_base_class_roles( + for => $meta, + roles => $base_class_roles, + ) if $meta->isa('Class::MOP::Class') + && $base_class_roles && @$base_class_roles; +} + +sub _collect_metaroles { + my ($exports_from) = @_; + + my @old_style_role_types = map { "${_}_roles" } qw( + metaclass + attribute_metaclass + method_metaclass + wrapped_method_metaclass + instance_metaclass + constructor_class + destructor_class + error_class + ); + + my %class_metaroles; + my %role_metaroles; + my @base_class_roles; + my %old_style_roles; + + for my $exporter (@$exports_from) { + my $data = $EXPORT_SPEC{$exporter}; + + if (exists $data->{class_metaroles}) { + for my $type (keys %{ $data->{class_metaroles} }) { + push @{ $class_metaroles{$type} ||= [] }, + @{ $data->{class_metaroles}{$type} }; + } + } + + if (exists $data->{role_metaroles}) { + for my $type (keys %{ $data->{role_metaroles} }) { + push @{ $role_metaroles{$type} ||= [] }, + @{ $data->{role_metaroles}{$type} }; + } + } + + if (exists $data->{base_class_roles}) { + push @base_class_roles, @{ $data->{base_class_roles} }; + } + + for my $type (@old_style_role_types) { + if (exists $data->{$type}) { + push @{ $old_style_roles{$type} ||= [] }, + @{ $data->{$type} }; + } + } + } + + return { + (keys(%class_metaroles) + ? (class_metaroles => \%class_metaroles) + : ()), + (keys(%role_metaroles) + ? (role_metaroles => \%role_metaroles) + : ()), + (@base_class_roles + ? (base_class_roles => \@base_class_roles) + : ()), + %old_style_roles, + }; +} + sub _apply_meta_traits { - my ( $class, $traits ) = @_; + my ( $class, $traits, $meta_lookup ) = @_; return unless @{$traits}; - my $meta = Class::MOP::class_of($class); + my $meta = $meta_lookup->($class); my $type = ( split /::/, ref $meta )[-1] or Moose->throw_error( @@ -546,7 +685,8 @@ sub _make_unimport_sub { my $exporting_package = shift; my $exports = shift; my $export_recorder = shift; - my $is_reexport = shift; + my $is_reexport = shift; + my $meta_lookup = shift; return sub { my $caller = scalar caller(); @@ -564,7 +704,7 @@ sub _remove_keywords { my $package = shift; my $keywords = shift; my $recorded_exports = shift; - my $is_reexport = shift; + my $is_reexport = shift; no strict 'refs'; @@ -588,10 +728,14 @@ sub _remove_keywords { } } +# maintain this for now for backcompat +# make sure to return a sub to install in the same circumstances as previously +# but this functionality now happens at the end of ->import sub _make_init_meta { shift; - my $class = shift; - my $args = shift; + my $class = shift; + my $args = shift; + my $meta_lookup = shift; my %old_style_roles; for my $role ( @@ -622,26 +766,8 @@ sub _make_init_meta { return sub { shift; - my %options = @_; - - return unless Class::MOP::class_of( $options{for_class} ); - - if ( %new_style_roles || %old_style_roles ) { - Moose::Util::MetaRole::apply_metaroles( - for => $options{for_class}, - %new_style_roles, - %old_style_roles, - ); - } - - Moose::Util::MetaRole::apply_base_class_roles( - for_class => $options{for_class}, - %base_class_roles, - ) - if Class::MOP::class_of( $options{for_class} ) - ->isa('Moose::Meta::Class'); - - return Class::MOP::class_of( $options{for_class} ); + my %opts = @_; + $meta_lookup->($opts{for_class}); }; } @@ -692,9 +818,8 @@ __END__ =head1 DESCRIPTION This module encapsulates the exporting of sugar functions in a -C-like manner. It does this by building custom C, -C, and C methods for your module, based on a spec you -provide. +C-like manner. It does this by building custom C and +C methods for your module, based on a spec you provide. It also lets you "stack" Moose-alike modules so you can export Moose's sugar as well as your own, along with sugar from any random C module, as @@ -714,21 +839,20 @@ This module provides two public methods: =item B<< Moose::Exporter->setup_import_methods(...) >> -When you call this method, C builds custom C, -C, and C methods for your module. The C method +When you call this method, C builds custom C and +C methods for your module. The C method will export the functions you specify, and can also re-export functions -exported by some other module (like C). +exported by some other module (like C). If you pass any parameters +for L, the C method will also call +C and +C as needed, after making +sure the metaclass is initialized. The C method cleans the caller's namespace of all the exported functions. This includes any functions you re-export from other packages. However, if the consumer of your package also imports those functions from the original package, they will I be cleaned. -If you pass any parameters for L, this method will -generate an C for you as well (see below for details). This -C will call C and -C as needed. - Note that if any of these methods already exist, they will not be overridden, you will have to use C to get the coderef that would be installed. @@ -776,6 +900,23 @@ can selectively override functions exported by another module. C also makes sure all these functions get removed when C is called. +=item * meta_lookup => sub { ... } + +This is a function which will be called to provide the metaclass +to be operated upon by the exporter. This is an advanced feature +intended for use by package generator modules in the vein of +L in order to simplify reusing sugar +from other modules that use C. This function is +used, for example, to select the metaclass to bind to functions +that are exported using the C option. + +This function will receive one parameter: the class name into which +the sugar is being exported. The default implementation is: + + sub { Class::MOP::class_of(shift) } + +Accordingly, this function is expected to return a metaclass. + =back You can also provide parameters for C @@ -784,15 +925,17 @@ are "class_metaroles", "role_metaroles", and "base_class_roles". =item B<< Moose::Exporter->build_import_methods(...) >> -Returns two or three code refs, one for C, one for -C, and optionally one for C, if the appropriate -options are passed in. +Returns two code refs, one for C and one for C. Accepts the additional C option, which accepts an arrayref of method -names to install into your exporting package. The valid options are C, -C, and C. Calling C is equivalent -to calling C with C<< install => [qw(import unimport -init_meta)] >> except that it doesn't also return the methods. +names to install into your exporting package. The valid options are C +and C. Calling C is equivalent +to calling C with C<< install => [qw(import unimport)] >> +except that it doesn't also return the methods. + +The C method is built using L. This means that it can +take a hashref of the form C<< { into => $package } >> to specify the package +it operates on. Used by C. @@ -817,35 +960,6 @@ Moose->init_meta >> to do the real work: return Moose->init_meta( @_, metaclass => 'My::Metaclass' ); } -Keep in mind that C will return an C -method for you, which you can also call from within your custom -C: - - my ( $import, $unimport, $init_meta ) = - Moose::Exporter->build_import_methods( ... ); - - sub import { - my $class = shift; - - ... - - $class->$import(...); - - ... - } - - sub unimport { goto &$unimport } - - sub init_meta { - my $class = shift; - - ... - - $class->$init_meta(...); - - ... - } - =head1 METACLASS TRAITS The C method generated by C will allow the