From 344cc24307a7c37170d4e0f4809bbe0d1085ecd3 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Thu, 4 Apr 2019 22:38:40 +0200 Subject: [PATCH 1/4] 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. --- lib/Class/Method/Modifiers.pm | 33 ++++++++++++-------- t/141-prototype.t | 59 +++++++++++++++++++++++++++++++++++ 2 files changed, 79 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..7ac3d27 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,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 $@; - 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__}; + 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..ba7808a --- /dev/null +++ b/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 : From 5aa8864a3b50aa9949d2cddb1fb4a156aebc76f8 Mon Sep 17 00:00:00 2001 From: Graham Knop Date: Thu, 4 Apr 2019 23:20:34 +0200 Subject: [PATCH 2/4] report prototype change warnings from correct location --- lib/Class/Method/Modifiers.pm | 15 +++++++++++---- t/141-prototype.t | 20 ++++++++++++++++++-- 2 files changed, 29 insertions(+), 6 deletions(-) diff --git a/lib/Class/Method/Modifiers.pm b/lib/Class/Method/Modifiers.pm index 7ac3d27..2c6a515 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 ba7808a..d59cdc1 100644 --- a/t/141-prototype.t +++ b/t/141-prototype.t @@ -1,7 +1,7 @@ use strict; use warnings; use Test::More 0.88; -use Test::Warnings ($ENV{AUTHOR_TESTING} ? () : ':no_end_test'), 'warning'; +use Test::Warnings ($ENV{AUTHOR_TESTING} ? () : ':no_end_test'), 'warnings'; use Test::Fatal; use Class::Method::Modifiers; @@ -39,7 +39,7 @@ use Class::Method::Modifiers; sub bog ($) { scalar @_ } my $around; - my $warn = warning { + my ($warn) = warnings { around bog => sub ($$) { my $orig = shift; $around = @_; @@ -53,6 +53,22 @@ use Class::Method::Modifiers; 'around modifier applied'; like $warn, qr/Prototype mismatch/, 'changing prototype throws warning'; + like $warn, qr/\Q${\__FILE__}\E/, + 'warning is reported from correct location'; +} + +{ + sub brog ($) { scalar @_ } + no warnings; + my @warn = warnings { + around brog => sub ($$) { + my $orig = shift; + $orig->(@_); + }; + }; + + is 0+@warn, 0, + 'warnings controllable via warning pragma'; } done_testing; From 143efa9db0793ca99ec0b73fbb97daeb3e1d6720 Mon Sep 17 00:00:00 2001 From: Roy Storey Date: Wed, 22 Oct 2025 17:01:46 +1300 Subject: [PATCH 3/4] add skips to dist.ini as 141-prototype.t uses Test::{Fatal,Warnings} --- dist.ini | 2 ++ 1 file changed, 2 insertions(+) diff --git a/dist.ini b/dist.ini index 0d00d68..be39704 100644 --- a/dist.ini +++ b/dist.ini @@ -30,4 +30,6 @@ phase = configure phase = build phase = runtime phase = test +skip = Test::Fatal +skip = Test::Warnings check_dual_life_versions = 0 From 40fb28860ee95af95af745753deae13f24780d43 Mon Sep 17 00:00:00 2001 From: Roy Storey Date: Wed, 22 Oct 2025 21:18:26 +1300 Subject: [PATCH 4/4] additional check on warning messages. test wrap array prototype --- t/141-prototype.t | 25 +++++++++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) diff --git a/t/141-prototype.t b/t/141-prototype.t index d59cdc1..75c31f7 100644 --- a/t/141-prototype.t +++ b/t/141-prototype.t @@ -37,7 +37,7 @@ use Class::Method::Modifiers; { sub bog ($) { scalar @_ } - + my $min_lineno = __LINE__; my $around; my ($warn) = warnings { around bog => sub ($$) { @@ -46,7 +46,7 @@ use Class::Method::Modifiers; $orig->(@_); }; }; - + my $max_lineno = __LINE__; is eval q{ bog( @{[5, 6]}, @{[10, 11]} ) }, 2, 'around wrapped lvalue sub takes modifier prototype'; is $around, 2, @@ -55,6 +55,10 @@ use Class::Method::Modifiers; 'changing prototype throws warning'; like $warn, qr/\Q${\__FILE__}\E/, 'warning is reported from correct location'; + + my ($lineno) = ($warn =~ qr/\Q${\__FILE__}\E line ([0-9]+)/); + is !!($min_lineno < $lineno && $lineno < $max_lineno), 1, + 'line no is within range'; } { @@ -71,5 +75,22 @@ use Class::Method::Modifiers; 'warnings controllable via warning pragma'; } +{ + require List::Util; + List::Util->import('sum'); + my $around; + my @warn = warnings { + around sum => sub :prototype(@) { + my $orig = shift; + $around = @_; + return 2 * $orig->(@_); + }; + }; + 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 :