support wrapping subs with prototypes

While Class::Method::Modifiers is primarily meant to wrap methods, it
can also be used to wrap functions.  Functions may have prototypes, so
it would be better if they could maintained in the wrapper.

This works similarly to the lvalue attribute.  If a before or after is
applied, the wrapper takes its prototype from the sub being wrapped.  If
an around is applied, the modifier sub's prototype is used.  This is
rather strange for arounds, as the parameters it is passed will still
include the wrapped sub as the first parameter, so the parameters won't
match the prototype exactly.  Even with that oddness, it still seems to
be the best option.  This also means an around could change the
prototype, which will throw warnings.

Author: haarg

lib/Class/Method/Modifiers.pm

@@ -82,11 +82,11 @@ sub install_modifier {
         # the Moose equivalent. :)
         if ($type eq 'around') {
             my $method = $cache->{wrapped};
-            my $attrs = _sub_attrs($code);
+            my $sig = _sub_sig($code);
             # a bare "sub :lvalue {...}" will be parsed as a label and an
             # indirect method call. force it to be treated as an expression
             # using +
-            $cache->{wrapped} = eval "package $into; +sub $attrs { \$code->(\$method, \@_); };";
+            $cache->{wrapped} = eval "package $into; +sub $sig { \$code->(\$method, \@_); };";
         }
 
         # install our new method which dispatches the modifiers, but only
@@ -101,10 +101,10 @@ sub install_modifier {
             # to take a reference to it. better a deref than a hash lookup
             my $wrapped = \$cache->{"wrapped"};
 
-            my $attrs = _sub_attrs($cache->{wrapped});
+            my $sig = _sub_sig($cache->{wrapped});
 
             my $generated = "package $into;\n";
-            $generated .= "sub $name $attrs {";
+            $generated .= "sub $name $sig {";
 
             # before is easy, it doesn't affect the return value(s)
             if (@$before) {
@@ -198,17 +198,27 @@ sub _fresh {
         }
         else {
             no warnings 'closure'; # for 5.8.x
-            my $attrs = _sub_attrs($code);
-            eval "package $into; sub $name $attrs { \$code->(\@_) }";
+            my $sig = _sub_sig($code);
+            eval "package $into; sub $name $sig { \$code->(\@_) }";
         }
     }
 }
 
-sub _sub_attrs {
+sub _sub_sig {
     my ($coderef) = @_;
-    local *_sub = $coderef;
-    local $@;
-    (eval 'return 1; &_sub = 1') ? ':lvalue' : '';
+    my @sig;
+    if (defined(my $proto = prototype($coderef))) {
+        push @sig, "($proto)";
+    }
+    if (do {
+        local *_sub = $coderef;
+        local $@;
+        local $SIG{__DIE__};
+        eval 'return 1; &_sub = 1';
+    }) {
+        push @sig, ':lvalue';
+    }
+    join ' ', @sig;
 }
 
 sub _is_in_package {

t/141-prototype.t

@@ -0,0 +1,59 @@
+use strict;
+use warnings;
+use Test::More 0.88;
+use Test::Warnings ($ENV{AUTHOR_TESTING} ? () : ':no_end_test'), 'warning';
+use Test::Fatal;
+
+use Class::Method::Modifiers;
+
+{
+    sub foo ($) { scalar @_ }
+
+    my $after;
+    after foo => sub { $after = @_ };
+
+    is eval q{ foo( @{[10, 20]} ) }, 1,
+        'after wrapped sub maintains prototype';
+    is $after, 1,
+        'after modifier applied';
+}
+
+{
+    my $bar;
+    my $guff;
+    sub bar ($) :lvalue { $guff = @_; $bar }
+
+    my $after;
+    after bar => sub { $after = @_ };
+
+    eval q{ bar( @{[10, 20]} ) = 5 };
+    is $guff, 1,
+        'after wrapped lvalue sub maintains prototype';
+    is $bar, 5,
+        'after wrapped lvalue sub maintains lvalue';
+    is $after, 1,
+        'after modifier applied';
+}
+
+{
+    sub bog ($) { scalar @_ }
+
+    my $around;
+    my $warn = warning {
+        around bog => sub ($$) {
+            my $orig = shift;
+            $around = @_;
+            $orig->(@_);
+        };
+    };
+
+    is eval q{ bog( @{[5, 6]}, @{[10, 11]} ) }, 2,
+        'around wrapped lvalue sub takes modifier prototype';
+    is $around, 2,
+        'around modifier applied';
+    like $warn, qr/Prototype mismatch/,
+        'changing prototype throws warning';
+}
+
+done_testing;
+# vim: set ts=8 sts=4 sw=4 tw=115 et :