From 146cf3953cd62c1ca36ad4292c347e52bb2d4387 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Thu, 4 Apr 2019 22:38:40 +0200 Subject: [PATCH 1/3] 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 be 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. --- lib/Class/Method/Modifiers.pm | 35 ++++++++++++-------- t/141-prototype.t | 61 +++++++++++++++++++++++++++++++++++ 2 files changed, 83 insertions(+), 13 deletions(-) create mode 100644 t/141-prototype.t diff --git a/lib/Class/Method/Modifiers.pm b/lib/Class/Method/Modifiers.pm index 87e56c9..90327e7 100644 --- a/lib/Class/Method/Modifiers.pm +++ b/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,20 +198,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..10e06c6 --- /dev/null +++ b/t/141-prototype.t @@ -0,0 +1,61 @@ +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'; +} + +{ + sub bog ($) { scalar @_ } + + my $around; + + my @warn; + { + local $SIG{__WARN__} = sub { push @warn, @_ }; + 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'; + my $warn = join '', @warn; + like $warn, qr/Prototype mismatch/, + 'changing prototype throws warning'; +} + +done_testing; +# vim: set ts=8 sts=4 sw=4 tw=115 et : From 427680549497883e087dcd0308fb6c8d0b13c8e8 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Thu, 4 Apr 2019 23:20:34 +0200 Subject: [PATCH 2/3] report prototype change warnings from correct location --- lib/Class/Method/Modifiers.pm | 15 ++++++++++---- t/141-prototype.t | 37 ++++++++++++++++++++++++++++------- 2 files changed, 41 insertions(+), 11 deletions(-) diff --git a/lib/Class/Method/Modifiers.pm b/lib/Class/Method/Modifiers.pm index 90327e7..bd964f7 100644 --- a/lib/Class/Method/Modifiers.pm +++ b/lib/Class/Method/Modifiers.pm @@ -78,6 +78,10 @@ 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') { @@ -103,8 +107,13 @@ sub install_modifier { my $sig = _sub_sig($cache->{wrapped}); - my $generated = "package $into;\n"; - $generated .= "sub $name $sig {"; + 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; }; } diff --git a/t/141-prototype.t b/t/141-prototype.t index 10e06c6..dd5cf0e 100644 --- a/t/141-prototype.t +++ b/t/141-prototype.t @@ -34,18 +34,21 @@ use Class::Method::Modifiers; } { - sub bog ($) { scalar @_ } - 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, @_ }; - around bog => sub ($$) { - my $orig = shift; - $around = @_; - $orig->(@_); - }; + $warn_line = __LINE__ + 1; + around bog => $wrap_bog; } is eval q{ bog( @{[5, 6]}, @{[10, 11]} ) }, 2, @@ -55,6 +58,26 @@ use Class::Method::Modifiers; 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'; } done_testing; From 52f326b4894749ba3c6d2704e4b26a12b65a0312 Mon Sep 17 00:00:00 2001 From: Roy Storey Date: Wed, 22 Oct 2025 21:18:26 +1300 Subject: [PATCH 3/3] test wrap array prototype --- t/141-prototype.t | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/t/141-prototype.t b/t/141-prototype.t index dd5cf0e..2560180 100644 --- a/t/141-prototype.t +++ b/t/141-prototype.t @@ -80,5 +80,29 @@ use Class::Method::Modifiers; '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 :