From: Daisuke Maki (lestrrat) <daisuke@endeworks.jp>
Date: Wed, 11 Mar 2009 03:16:24 +0000 (+0900)
Subject: export functions with prototype
X-Git-Tag: 0.72_01~77
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=badbc5282ddc18a41f09405dfe824a69f6edca41;p=gitmo%2FMoose.git

export functions with prototype
---

diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm
index 3a35c4c..a3295e6 100644
--- a/lib/Moose/Exporter.pm
+++ b/lib/Moose/Exporter.pm
@@ -156,6 +156,8 @@ sub _make_sub_exporter_params {
                 $is_removable{$name} = 1;
             }
 
+            $class->_make_prototyped_sub($sub);
+
             $export_recorder->{$sub} = 1;
 
             $exports{$name} = sub {$sub};
@@ -192,13 +194,36 @@ sub _make_wrapped_sub {
     };
 }
 
-sub _make_wrapper {
+sub _make_prototyped_sub {
     shift;
+    my $sub = shift;
+
+    # If I use Scalar::Util::set_prototype, this will forever be bound to XS.
+    # And it's hard to use anyway (it requires a BLOCK or a sub{} declaration
+    # as its first argument)
+    if (my $proto = prototype $sub) {
+        $sub = eval "sub ($proto) { \$sub->(\@_) }";
+        Carp::confess if $@;
+    }
+    return $sub;
+}
+
+sub _make_wrapper {
+    my $class   = shift;
     my $caller  = shift;
     my $sub     = shift;
     my $fq_name = shift;
 
-    return sub { $sub->($caller, @_) };
+    # XXX optimization: since we're building a new sub anyways, we
+    # unroll _make_prototyped_sub here
+    my $wrapper;
+    if (my $proto = prototype $sub) {
+        $wrapper = eval "sub ($proto) { \$sub->(\$caller, \@_) }";
+        Carp::confess if $@;
+    } else {
+        $wrapper = sub { $sub->($caller, @_) };
+    }
+    return $wrapper;
 }
 
 sub _make_import_sub {
diff --git a/t/050_metaclasses/021_export_with_prototype.t b/t/050_metaclasses/021_export_with_prototype.t
new file mode 100644
index 0000000..531f4c7
--- /dev/null
+++ b/t/050_metaclasses/021_export_with_prototype.t
@@ -0,0 +1,20 @@
+use lib "t/lib";
+package MyExporter::User;
+use MyExporter;
+
+use Test::More (tests => 4);
+use Test::Exception;
+
+lives_and {
+    with_prototype {
+        my $caller = caller(0);
+        is($caller, 'MyExporter', "With_caller prototype code gets called from MyMooseX");
+    };
+} "check function with prototype";
+
+lives_and {
+    as_is_prototype {
+        my $caller = caller(0);
+        is($caller, 'MyExporter', "As-is prototype code gets called from MyMooseX");
+    };
+} "check function with prototype";
diff --git a/t/lib/MyExporter.pm b/t/lib/MyExporter.pm
new file mode 100644
index 0000000..78836e0
--- /dev/null
+++ b/t/lib/MyExporter.pm
@@ -0,0 +1,24 @@
+
+
+package MyExporter;
+use Moose::Exporter;
+use Test::More;
+
+Moose::Exporter->setup_import_methods(
+    with_caller => [ qw(with_prototype) ],
+    as_is       => [ qw(as_is_prototype) ],
+);
+
+sub with_prototype (&) {
+    my ($class, $code) = @_;
+    isa_ok($code, 'CODE', 'with_prototype received a coderef');
+    $code->();
+}
+
+sub as_is_prototype (&) {
+    my ($code) = @_;
+    isa_ok($code, 'CODE', 'as_is_prototype received a coderef');
+    $code->();
+}
+
+1;
\ No newline at end of file