X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FExporter.pm;h=ad952fcf3fffe6b1a37f995f943a75a678e0edb6;hb=bb09ad9144e7ee7b2cad8a90725267f591346406;hp=be1a3c864543b41cd2fd4bfa0cdce5dfae4ba8da;hpb=15851b8777a9824a8b5fcaeac17caa7f7f5e9fc2;p=gitmo%2FMoose.git

diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm
index be1a3c8..ad952fc 100644
--- a/lib/Moose/Exporter.pm
+++ b/lib/Moose/Exporter.pm
@@ -3,7 +3,7 @@ package Moose::Exporter;
 use strict;
 use warnings;
 
-our $VERSION = '1.08';
+our $VERSION = '1.17';
 our $XS_VERSION = $VERSION;
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
@@ -11,6 +11,7 @@ our $AUTHORITY = 'cpan:STEVAN';
 use Class::MOP;
 use List::MoreUtils qw( first_index uniq );
 use Moose::Util::MetaRole;
+use Scalar::Util qw(reftype);
 use Sub::Exporter 0.980;
 use Sub::Name qw(subname);
 
@@ -49,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(
@@ -88,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 = {};
 
@@ -129,6 +168,30 @@ sub build_import_methods {
     }
 }
 
+sub _parse_trait_aliases {
+    my $class   = shift;
+    my ($package, $aliases) = @_;
+
+    my @ret;
+    for my $alias (@$aliases) {
+        my $name;
+        if (ref($alias)) {
+            reftype($alias) eq 'ARRAY'
+                or Moose->throw_error(reftype($alias) . " references are not "
+                                    . "valid arguments to the 'trait_aliases' "
+                                    . "option");
+
+            ($alias, $name) = @$alias;
+        }
+        else {
+            ($name = $alias) =~ s/.*:://;
+        }
+        push @ret, subname "${package}::${name}" => sub () { $alias };
+    }
+
+    return @ret;
+}
+
 sub _make_sub_exporter_params {
     my $class           = shift;
     my $packages        = shift;
@@ -167,7 +230,10 @@ sub _make_sub_exporter_params {
             );
         }
 
-        for my $name ( @{ $args->{as_is} } ) {
+        my @extra_exports = $class->_parse_trait_aliases(
+            $package, $args->{trait_aliases},
+        );
+        for my $name ( @{ $args->{as_is} }, @extra_exports ) {
             my ( $sub, $coderef_name );
 
             if ( ref $name ) {
@@ -328,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).
@@ -351,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;
         }
 
@@ -380,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;
 
@@ -404,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;
 
@@ -415,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 ) = @_;
 
@@ -545,11 +624,13 @@ sub _make_init_meta {
 
         return unless Class::MOP::class_of( $options{for_class} );
 
-        Moose::Util::MetaRole::apply_metaroles(
-            for => $options{for_class},
-            %new_style_roles,
-            %old_style_roles,
-        );
+        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},
@@ -645,7 +726,7 @@ functions from the original package, they will I<not> be cleaned.
 
 If you pass any parameters for L<Moose::Util::MetaRole>, this method will
 generate an C<init_meta> for you as well (see below for details). This
-C<init_meta> will call C<Moose::Util::MetaRole::apply_metaclass_roles> and
+C<init_meta> will call C<Moose::Util::MetaRole::apply_metaroles> and
 C<Moose::Util::MetaRole::apply_base_class_roles> as needed.
 
 Note that if any of these methods already exist, they will not be
@@ -675,6 +756,14 @@ removed by the C<unimport> method. The reason for this is we cannot know if
 the caller I<also> explicitly imported the sub themselves, and therefore wants
 to keep it.
 
+=item * trait_aliases => [ ... ]
+
+This is a list of package names which should have shortened aliases exported,
+similar to the functionality of L<aliased>. 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
+package to alias to, and second element is the alias to export.
+
 =item * also => $name or \@names
 
 This is a list of modules which contain functions that the caller