X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FExporter.pm;h=6a4014d6824c70c7aa416caeb90cd83ceb242f64;hb=5ef36adde3d619733607b9f5f1136524a00848df;hp=8151e6db2cca18e39ac2e1d8ee299ef89408be20;hpb=e6ab9ca5a4c8fad570cf70bc6722d06e18542331;p=gitmo%2FMoose.git

diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm
index 8151e6d..6a4014d 100644
--- a/lib/Moose/Exporter.pm
+++ b/lib/Moose/Exporter.pm
@@ -3,14 +3,14 @@ package Moose::Exporter;
 use strict;
 use warnings;
 
-our $VERSION   = '0.83';
+our $VERSION   = '0.85';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
 use Class::MOP;
 use List::MoreUtils qw( first_index uniq );
 use Moose::Util::MetaRole;
-use Sub::Exporter;
+use Sub::Exporter 0.980;
 use Sub::Name qw(subname);
 
 my %EXPORT_SPEC;
@@ -38,14 +38,14 @@ sub build_import_methods {
 
     my $export_recorder = {};
 
-    my ( $exports, $is_removable )
+    my ( $exports, $is_removable, $groups )
         = $class->_make_sub_exporter_params(
         [ @exports_from, $exporting_package ], $export_recorder );
 
     my $exporter = Sub::Exporter::build_exporter(
         {
             exports => $exports,
-            groups  => { default => [':all'] }
+            groups  => { default => [':all'], %$groups }
         }
     );
 
@@ -107,6 +107,7 @@ sub _make_sub_exporter_params {
     my $packages          = shift;
     my $export_recorder   = shift;
 
+    my %groups;
     my %exports;
     my %is_removable;
 
@@ -114,6 +115,15 @@ sub _make_sub_exporter_params {
         my $args = $EXPORT_SPEC{$package}
             or die "The $package package does not use Moose::Exporter\n";
 
+        # one group for each 'also' package
+        $groups{$package} = [
+            @{ $args->{with_caller} || [] },
+            @{ $args->{with_meta}   || [] },
+            @{ $args->{as_is}       || [] },
+            map ":$_",
+            keys %{ $args->{groups} || {} }
+        ];
+
         for my $name ( @{ $args->{with_caller} } ) {
             my $sub = do {
                 no strict 'refs';
@@ -131,6 +141,23 @@ sub _make_sub_exporter_params {
             $is_removable{$name} = 1;
         }
 
+        for my $name ( @{ $args->{with_meta} } ) {
+            my $sub = do {
+                no strict 'refs';
+                \&{ $package . '::' . $name };
+            };
+
+            my $fq_name = $package . '::' . $name;
+
+            $exports{$name} = $class->_make_wrapped_sub_with_meta(
+                $fq_name,
+                $sub,
+                $export_recorder,
+            );
+
+            $is_removable{$name} = 1;
+        }
+
         for my $name ( @{ $args->{as_is} } ) {
             my $sub;
 
@@ -165,9 +192,26 @@ sub _make_sub_exporter_params {
 
             $exports{$name} = sub {$sub};
         }
+
+        for my $name ( keys %{ $args->{groups} } ) {
+            my $group = $args->{groups}{$name};
+
+            if (ref $group eq 'CODE') {
+                $groups{$name} = $class->_make_wrapped_group(
+                    $package,
+                    $group,
+                    $export_recorder,
+                    \%exports,
+                    \%is_removable
+                );
+            }
+            elsif (ref $group eq 'ARRAY') {
+                $groups{$name} = $group;
+            }
+        }
     }
 
-    return ( \%exports, \%is_removable );
+    return ( \%exports, \%is_removable, \%groups );
 }
 
 our $CALLER;
@@ -197,6 +241,76 @@ sub _make_wrapped_sub {
     };
 }
 
+sub _make_wrapped_sub_with_meta {
+    my $self            = shift;
+    my $fq_name         = shift;
+    my $sub             = shift;
+    my $export_recorder = shift;
+
+    return sub {
+        my $caller = $CALLER;
+
+        my $wrapper = $self->_late_curry_wrapper($sub, $fq_name,
+            sub { Class::MOP::class_of(shift) } => $caller);
+
+        my $sub = subname($fq_name => $wrapper);
+
+        $export_recorder->{$sub} = 1;
+
+        return $sub;
+    };
+}
+
+sub _make_wrapped_group {
+    my $class           = shift;
+    my $package         = shift; # package calling use Moose::Exporter
+    my $sub             = shift;
+    my $export_recorder = shift;
+    my $keywords        = shift;
+    my $is_removable    = shift;
+
+    return sub {
+        my $caller = $CALLER; # package calling use PackageUsingMooseExporter -group => {args}
+
+        # there are plenty of ways to deal with telling the code which
+        # package it lives in. the last arg (collector hashref) is
+        # otherwise unused, so we'll stick the original package in
+        # there and act like 'with_caller' by putting the calling
+        # package name as the first arg
+        $_[0] = $caller;
+        $_[3]{from} = $package;
+
+        my $named_code = $sub->(@_);
+        $named_code ||= { };
+
+        # send invalid return value error up to Sub::Exporter
+        unless (ref $named_code eq 'HASH') {
+            return $named_code;
+        }
+
+        for my $name (keys %$named_code) {
+            my $code = $named_code->{$name};
+
+            my $fq_name = $package . '::' . $name;
+            my $wrapper = $class->_curry_wrapper(
+                $code,
+                $fq_name,
+                $caller
+            );
+
+            my $sub = subname( $fq_name => $wrapper );
+            $named_code->{$name} = $sub;
+
+            # mark each coderef as ours
+            $keywords->{$name} = 1;
+            $is_removable->{$name} = 1;
+            $export_recorder->{$sub} = 1;
+        }
+
+        return $named_code;
+    };
+}
+
 sub _curry_wrapper {
     my $class   = shift;
     my $sub     = shift;
@@ -212,6 +326,27 @@ sub _curry_wrapper {
     return $wrapper;
 }
 
+sub _late_curry_wrapper {
+    my $class   = shift;
+    my $sub     = shift;
+    my $fq_name = shift;
+    my $extra   = shift;
+    my @ex_args = @_;
+
+    my $wrapper = sub {
+        # resolve curried arguments at runtime via this closure
+        my @curry = ( $extra->( @ex_args ) );
+        return $sub->(@curry, @_);
+    };
+
+    if (my $proto = prototype $sub) {
+        # XXX - Perl's prototype sucks. Use & to make set_prototype
+        # ignore the fact that we're passing "private variables"
+        &Scalar::Util::set_prototype($wrapper, $proto);
+    }
+    return $wrapper;
+}
+
 sub _make_import_sub {
     shift;
     my $exporting_package = shift;