X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FExporter.pm;h=dcdef3cbeba1afb3805b1685e46e0e324944d31c;hb=ef487af73b144341c8fd2e4640b93d395dc414ed;hp=aca3f3a1086af367322c2af70959d6940c40605a;hpb=efa728b4984ddf1611bc9931fbc209438459652c;p=gitmo%2FMoose.git diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm index aca3f3a..dcdef3c 100644 --- a/lib/Moose/Exporter.pm +++ b/lib/Moose/Exporter.pm @@ -3,29 +3,20 @@ package Moose::Exporter; use strict; use warnings; -our $VERSION = '1.15'; -our $XS_VERSION = $VERSION; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; - +use Class::Load qw(is_class_loaded); use Class::MOP; use List::MoreUtils qw( first_index uniq ); -use Moose::Deprecated; use Moose::Util::MetaRole; use Scalar::Util qw(reftype); use Sub::Exporter 0.980; use Sub::Name qw(subname); -use XSLoader; - -XSLoader::load( 'Moose', $XS_VERSION ); - 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, @@ -38,6 +29,8 @@ sub build_import_methods { 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); @@ -46,16 +39,16 @@ 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 = Sub::Exporter::build_exporter( - { - exports => $exports, - groups => { default => [':all'] } - } + my $exporter = $class->_make_exporter( + $exports, + $is_reexport, + $meta_lookup, ); my %methods; @@ -63,19 +56,22 @@ sub build_import_methods { $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); @@ -90,6 +86,49 @@ sub build_import_methods { return ( $methods{import}, $methods{unimport}, $methods{init_meta} ); } +sub _make_exporter { + my ($class, $exports, $is_reexport, $meta_lookup) = @_; + + return Sub::Exporter::build_exporter( + { + exports => $exports, + groups => { default => [':all'] }, + installer => sub { + my ($arg, $to_export) = @_; + my $meta = $meta_lookup->($arg->{into}); + + goto &Sub::Exporter::default_installer unless $meta; + + # don't overwrite existing symbols with our magically flagged + # version of it if we would install the same sub that's already + # in the importer + + my @filtered_to_export; + my %installed; + for (my $i = 0; $i < @{ $to_export }; $i += 2) { + my ($as, $cv) = @{ $to_export }[$i, $i + 1]; + + next if !ref($as) + && $meta->has_package_symbol('&' . $as) + && $meta->get_package_symbol('&' . $as) == $cv; + + push @filtered_to_export, $as, $cv; + $installed{$as} = 1 unless ref $as; + } + + Sub::Exporter::default_installer($arg, \@filtered_to_export); + + for my $name ( keys %{$is_reexport} ) { + no strict 'refs'; + no warnings 'once'; + next unless exists $installed{$name}; + _flag_as_reexport( \*{ join q{::}, $arg->{into}, $name } ); + } + }, + } + ); +} + { my $seen = {}; @@ -106,7 +145,7 @@ sub build_import_methods { my $exporting_package = shift; if ( !exists $EXPORT_SPEC{$exporting_package} ) { - my $loaded = Class::MOP::is_class_loaded($exporting_package); + my $loaded = is_class_loaded($exporting_package); die "Package in also ($exporting_package) does not seem to " . "use Moose::Exporter" @@ -156,17 +195,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; @@ -177,7 +224,8 @@ sub _make_sub_exporter_params { $fq_name, $sub, $export_recorder, - ); + $meta_lookup, + ) unless exists $exports{$name}; } for my $name ( @{ $args->{with_caller} } ) { @@ -190,7 +238,7 @@ sub _make_sub_exporter_params { $fq_name, $sub, $export_recorder, - ); + ) unless exists $exports{$name}; } my @extra_exports = $class->_parse_trait_aliases( @@ -219,7 +267,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}; } } @@ -275,13 +324,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 ); @@ -336,7 +386,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 { @@ -397,7 +448,7 @@ sub _make_import_sub { # 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; @@ -416,12 +467,6 @@ sub _make_import_sub { } $class->$exporter( $extra, @args ); - - for my $name ( keys %{$is_reexport} ) { - no strict 'refs'; - no warnings 'once'; - _flag_as_reexport( \*{ join q{::}, $CALLER, $name } ); - } }; } @@ -464,11 +509,11 @@ sub _strip_meta_name { } 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( @@ -513,7 +558,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(); @@ -531,7 +577,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'; @@ -557,8 +603,9 @@ sub _remove_keywords { 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 ( @@ -591,7 +638,7 @@ sub _make_init_meta { shift; my %options = @_; - return unless Class::MOP::class_of( $options{for_class} ); + return unless $meta_lookup->( $options{for_class} ); if ( %new_style_roles || %old_style_roles ) { Moose::Util::MetaRole::apply_metaroles( @@ -605,10 +652,10 @@ sub _make_init_meta { for_class => $options{for_class}, %base_class_roles, ) - if Class::MOP::class_of( $options{for_class} ) + if $meta_lookup->( $options{for_class} ) ->isa('Moose::Meta::Class'); - return Class::MOP::class_of( $options{for_class} ); + return $meta_lookup->( $options{for_class} ); }; } @@ -619,11 +666,9 @@ sub import { 1; -__END__ - -=head1 NAME +# ABSTRACT: make an import() and unimport() just like Moose.pm -Moose::Exporter - make an import() and unimport() just like Moose.pm +__END__ =head1 SYNOPSIS @@ -727,7 +772,7 @@ to keep it. =item * trait_aliases => [ ... ] -This is a list of package names which should have shortened alias exported, +This is a list of package names which should have shortened aliases exported, similar to the functionality of L. Each element in the list can be either a package name, in which case the export will be named as the last namespace component of the package, or an arrayref, whose first element is the @@ -745,6 +790,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 @@ -763,6 +825,10 @@ 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. +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. =back @@ -790,29 +856,32 @@ 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( ... ); + my ( $import, $unimport, $init_meta ) + = Moose::Exporter->build_import_methods(...); sub import { - my $class = shift; + my $class = shift; - ... + ... - $class->$import(...); + # You can either pass an explicit package to import into ... + $class->$import( { into => scalar(caller) }, ... ); - ... + ...; } + # ... or you can use 'goto' to provide the correct caller info to the + # generated method sub unimport { goto &$unimport } sub init_meta { - my $class = shift; + my $class = shift; - ... + ... - $class->$init_meta(...); + $class->$init_meta(...); - ... + ... } =head1 METACLASS TRAITS @@ -833,20 +902,4 @@ a metaclass for the caller is an error. See L for details on reporting bugs. -=head1 AUTHOR - -Dave Rolsky Eautarch@urth.orgE - -This is largely a reworking of code in Moose.pm originally written by -Stevan Little and others. - -=head1 COPYRIGHT AND LICENSE - -Copyright 2009 by Infinity Interactive, Inc. - -L - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - =cut