diff --git a/lib/Class/Method/Modifiers.pm b/lib/Class/Method/Modifiers.pm index 87e56c9..bd964f7 100644 --- a/lib/Class/Method/Modifiers.pm +++ b/lib/Class/Method/Modifiers.pm @@ -78,15 +78,19 @@ sub install_modifier { unshift @{ $cache->{$type} }, $code; } + require Carp; + my $loc = Carp::short_error_loc(); + my ($file, $line, $warnmask) = (caller($loc))[1,2,9]; + # wrap the method with another layer of around. much simpler than # 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 +105,15 @@ 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 {"; + my $generated + = "BEGIN { \${^WARNING_BITS} = \$warnmask }\n" + . "no warnings 'redefine';\n" + . "no warnings 'closure';\n" + . "package $into;\n" + . "#line $line \"$file\"\n" + . "sub $name $sig {"; # before is easy, it doesn't affect the return value(s) if (@$before) { @@ -143,8 +152,6 @@ sub install_modifier { $generated .= '}'; no strict 'refs'; - no warnings 'redefine'; - no warnings 'closure'; eval $generated; }; } @@ -198,20 +205,29 @@ 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 $@; - local $SIG{__DIE__}; - # this assignment will fail to compile if it isn't an lvalue sub. we - # never want to actually call the sub though, so we return early. - (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__}; + # this assignment will fail to compile if it isn't an lvalue sub. we + # never want to actually call the sub though, so we return early. + eval 'return 1; &_sub = 1'; + }) { + push @sig, ':lvalue'; + } + join ' ', @sig; } sub _is_in_package { diff --git a/t/141-prototype.t b/t/141-prototype.t new file mode 100644 index 0000000..2560180 --- /dev/null +++ b/t/141-prototype.t @@ -0,0 +1,108 @@ +use strict; +use warnings; +use Test::More 0.88; + +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'; +} + +{ + my $around; + + sub bog ($) { scalar @_ } + my $wrap_bog = sub ($$) { + my $orig = shift; + $around = @_; + $orig->(@_); + }; + + my $warn_line; + my @warn; + { + local $SIG{__WARN__} = sub { push @warn, @_ }; + $warn_line = __LINE__ + 1; + around bog => $wrap_bog; + } + + is eval q{ bog( @{[5, 6]}, @{[10, 11]} ) }, 2, + 'around wrapped lvalue sub takes modifier prototype'; + is $around, 2, + 'around modifier applied'; + my $warn = join '', @warn; + like $warn, qr/Prototype mismatch/, + 'changing prototype throws warning'; + like $warn, qr/\Q${\__FILE__}\E line $warn_line\b/, + 'warning is reported from correct location'; +} + +{ + sub brog ($) { scalar @_ } + my $wrap_brog = sub ($$) { + my $orig = shift; + $orig->(@_); + }; + + my @warn; + { + local $SIG{__WARN__} = sub { push @warn, @_ }; + no warnings; + around brog => $wrap_brog; + } + + is 0+@warn, 0, + 'warnings controllable via warning pragma'; +} + +{ + my $around; + + require List::Util; + List::Util->import('sum'); + my $wrap_sum = sub :prototype(@) { + my $orig = shift; + $around = @_; + return 2 * $orig->(@_); + }; + + + my @warn; + { + local $SIG{__WARN__} = sub { push @warn, @_ }; + around sum => $wrap_sum; + } + + is eval q{sum(11, 1, 4, 5, 9)}, 60, + 'result from around xs function'; + is $around, 5, 'prototype @ wrapped'; + is 0+@warn, 0, 'no warnings'; +} + +done_testing; +# vim: set ts=8 sts=4 sw=4 tw=115 et :