X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FExporter.pm;h=19fd187681a0921d7864252a61f57a2d6cc7143e;hb=72042ad72c251a1ae589675e696b31e0b47e8287;hp=4e87db85c465c91583e3a72be265d6ca76f8bc6e;hpb=f88cfe7c09baf4da7359f8f0fe93851aa4fae9d0;p=gitmo%2FMoose.git diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm index 4e87db8..19fd187 100644 --- a/lib/Moose/Exporter.pm +++ b/lib/Moose/Exporter.pm @@ -3,29 +3,28 @@ package Moose::Exporter; use strict; use warnings; -our $VERSION = '1.14'; -our $XS_VERSION = $VERSION; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; +use XSLoader; + +BEGIN { + XSLoader::load( + 'Moose', + $Moose::Exporter::{VERSION} ? ${ $Moose::Exporter::{VERSION} } : () + ); +} 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, @@ -51,12 +50,7 @@ sub build_import_methods { $is_reexport, ); - my $exporter = Sub::Exporter::build_exporter( - { - exports => $exports, - groups => { default => [':all'] } - } - ); + my $exporter = $class->_make_exporter($exports, $is_reexport); my %methods; $methods{import} = $class->_make_import_sub( @@ -90,6 +84,49 @@ sub build_import_methods { return ( $methods{import}, $methods{unimport}, $methods{init_meta} ); } +sub _make_exporter { + my ($class, $exports, $is_reexport) = @_; + + return Sub::Exporter::build_exporter( + { + exports => $exports, + groups => { default => [':all'] }, + installer => sub { + my ($arg, $to_export) = @_; + my $meta = Class::MOP::class_of($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 = {}; @@ -99,7 +136,7 @@ sub build_import_methods { local %$seen = ( $exporting_package => 1 ); - return uniq( _follow_also_real($exporting_package) ); + return reverse uniq( _follow_also_real($exporting_package) ); } sub _follow_also_real { @@ -159,7 +196,7 @@ sub _make_sub_exporter_params { my $class = shift; my $packages = shift; my $export_recorder = shift; - my $is_reexport = shift; + my $is_reexport = shift; my %exports; @@ -336,7 +373,7 @@ sub _make_import_sub { my $exporting_package = shift; my $exporter = shift; my $exports_from = shift; - my $is_reexport = shift; + my $is_reexport = shift; return sub { @@ -357,6 +394,9 @@ sub _make_import_sub { = Moose::Util::resolve_metaclass_alias( 'Class' => $metaclass ) if defined $metaclass && length $metaclass; + my $meta_name; + ( $meta_name, @_ ) = _strip_meta_name(@_); + # Normally we could look at $_[0], but in some weird cases # (involving goto &Moose::import), $_[0] ends as something # else (like Squirrel). @@ -380,7 +420,11 @@ sub _make_import_sub { # Moose::Exporter, which in turn sets $CALLER, so we need # to protect against that. local $CALLER = $CALLER; - $c->init_meta( for_class => $CALLER, metaclass => $metaclass ); + $c->init_meta( + for_class => $CALLER, + metaclass => $metaclass, + meta_name => $meta_name, + ); $did_init_meta = 1; } @@ -409,17 +453,11 @@ 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 } ); - } }; } sub _strip_traits { - my $idx = first_index { $_ eq '-traits' } @_; + my $idx = first_index { ( $_ || '' ) eq '-traits' } @_; return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1; @@ -433,7 +471,7 @@ sub _strip_traits { } sub _strip_metaclass { - my $idx = first_index { $_ eq '-metaclass' } @_; + my $idx = first_index { ( $_ || '' ) eq '-metaclass' } @_; return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1; @@ -444,6 +482,18 @@ sub _strip_metaclass { return ( $metaclass, @_ ); } +sub _strip_meta_name { + my $idx = first_index { ( $_ || '' ) eq '-meta_name' } @_; + + return ( 'meta', @_ ) unless $idx >= 0 && $#_ >= $idx + 1; + + my $meta_name = $_[ $idx + 1 ]; + + splice @_, $idx, 2; + + return ( $meta_name, @_ ); +} + sub _apply_meta_traits { my ( $class, $traits ) = @_; @@ -494,7 +544,7 @@ sub _make_unimport_sub { my $exporting_package = shift; my $exports = shift; my $export_recorder = shift; - my $is_reexport = shift; + my $is_reexport = shift; return sub { my $caller = scalar caller(); @@ -512,7 +562,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'; @@ -600,11 +650,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 @@ -708,7 +756,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 @@ -814,20 +862,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