diff options
| -rw-r--r-- | op.c | 56 | ||||
| -rw-r--r-- | pod/perldiag.pod | 17 | ||||
| -rw-r--r-- | t/op/signatures.t | 93 |
3 files changed, 164 insertions, 2 deletions
@@ -3732,6 +3732,21 @@ Perl_optimize_optree(pTHX_ OP* o) } +#define warn_implicit_snail_cvsig(o) S_warn_implicit_snail_cvsig(aTHX_ o) +static void +S_warn_implicit_snail_cvsig(pTHX_ OP *o) +{ + CV *cv = PL_compcv; + while(cv && CvEVAL(cv)) + cv = CvOUTSIDE(cv); + + if(cv && CvSIGNATURE(cv)) + Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__ARGS_ARRAY_WITH_SIGNATURES), + "Implicit use of @_ in %s with signatured subroutine is experimental", OP_DESC(o)); +} + +#define OP_ZOOM(o) (OP_TYPE_IS(o, OP_NULL) ? cUNOPx(o)->op_first : (o)) + /* helper for optimize_optree() which optimises one op then recurses * to optimise any children. */ @@ -3775,6 +3790,47 @@ S_optimize_op(pTHX_ OP* o) } break; + case OP_RV2AV: + { + OP *first = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL; + CV *cv = PL_compcv; + while(cv && CvEVAL(cv)) + cv = CvOUTSIDE(cv); + + if(cv && CvSIGNATURE(cv) && + OP_TYPE_IS(first, OP_GV) && cGVOPx_gv(first) == PL_defgv) { + OP *parent = op_parent(o); + while(OP_TYPE_IS(parent, OP_NULL)) + parent = op_parent(parent); + + Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__ARGS_ARRAY_WITH_SIGNATURES), + "Use of @_ in %s with signatured subroutine is experimental", OP_DESC(parent)); + } + break; + } + + case OP_SHIFT: + case OP_POP: + if(!CvUNIQUE(PL_compcv) && !(o->op_flags & OPf_KIDS)) + warn_implicit_snail_cvsig(o); + break; + + case OP_ENTERSUB: + if(!(o->op_flags & OPf_STACKED)) + warn_implicit_snail_cvsig(o); + break; + + case OP_GOTO: + { + OP *first = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL; + OP *ffirst; + if(OP_TYPE_IS(first, OP_SREFGEN) && + (ffirst = OP_ZOOM(cUNOPx(first)->op_first)) && + OP_TYPE_IS(ffirst, OP_RV2CV)) + warn_implicit_snail_cvsig(o); + break; + } + default: break; } diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 07b1166703..62dca08f27 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -2824,6 +2824,15 @@ would otherwise result in the same message being repeated. Failure of user callbacks dispatched using the C<G_KEEPERR> flag could also result in this warning. See L<perlcall/G_KEEPERR>. +=item Implicit use of @_ in %s with signatured subroutine is experimental + +(S experimental::args_array_with_signatures) An expression that implicitly +involves the C<@_> arguments array was found in a subroutine that uses a +signature. This is experimental because the interaction between the +arguments array and parameter handling via signatures is not guaranteed +to remain stable in any future version of Perl, and such code should be +avoided. + =item Incomplete expression within '(?[ ])' in regex; marked by S<<-- HERE> in m/%s/ @@ -7252,6 +7261,14 @@ you can write it as C<push(@tied_array,())> to avoid this warning. (F) The "use" keyword is recognized and executed at compile time, and returns no useful value. See L<perlmod>. +=item Use of @_ in %s with signatured subroutine is experimental + +(S experimental::args_array_with_signatures) An expression involving the +C<@_> arguments array was found in a subroutine that uses a signature. +This is experimental because the interaction between the arguments +array and parameter handling via signatures is not guaranteed to remain +stable in any future version of Perl, and such code should be avoided. + =item Use of bare << to mean <<"" is forbidden (F) You are now required to use the explicitly quoted form if you wish diff --git a/t/op/signatures.t b/t/op/signatures.t index d22d11b517..e70215afca 100644 --- a/t/op/signatures.t +++ b/t/op/signatures.t @@ -434,7 +434,10 @@ like $@, _create_flexible_mismatch_regexp('main::t128', 3, 2); is $a, 123; sub t130 { join(",", @_).";".scalar(@_) } -sub t131 ($a = 222, $b = goto &t130) { "$a/$b" } +{ + no warnings 'experimental::args_array_with_signatures'; + sub t131 ($a = 222, $b = goto &t130) { "$a/$b" } +} is prototype(\&t131), undef; is eval("t131()"), ";0"; is eval("t131(0)"), "0;1"; @@ -1380,13 +1383,15 @@ is scalar(t145()), undef; } is ref(t149()), "ARRAY", "t149: closure can make new lexical a ref"; + # Quiet the 'use of @_ is experimental' warnings + no warnings 'experimental::args_array_with_signatures'; + sub t150 ($a = do {@_ = qw(a b c); 1}, $b = 2) { is $a, 1, "t150: a: growing \@_"; is $b, "b", "t150: b: growing \@_"; } t150(); - sub t151 ($a = do {tie @_, 'Tie::StdArray'; @_ = qw(a b c); 1}, $b = 2) { is $a, 1, "t151: a: tied \@_"; is $b, "b", "t151: b: tied \@_"; @@ -1608,6 +1613,90 @@ while(<$kh>) { 'f($1)'; } +# check that various uses of @_ inside signatured subs causes "experimental" +# warnings at compiletime +{ + sub warnings_from { + my ($code, $run) = @_; + my $warnings = ""; + local $SIG{__WARN__} = sub { $warnings .= join "", @_ }; + my $cv = eval qq{ sub(\$x) { $code }} or die "Cannot eval() - $@"; + $run and $cv->(123); + return $warnings; + } + + sub snailwarns_ok { + my ($opname, $code) = @_; + my $warnings = warnings_from $code; + ok($warnings =~ m/[Uu]se of \@_ in $opname with signatured subroutine is experimental at \(eval /, + "`$code` warns of experimental \@_") or + diag("Warnings were:\n$warnings"); + } + + sub snailwarns_runtime_ok { + my ($opname, $code) = @_; + my $warnings = warnings_from $code, 1; + ok($warnings =~ m/[Uu]se of \@_ in $opname with signatured subroutine is experimental at \(eval /, + "`$code` warns of experimental \@_") or + diag("Warnings were:\n$warnings"); + } + + sub not_snailwarns_ok { + my ($code) = @_; + my $warnings = warnings_from $code; + ok($warnings !~ m/[Uu]se of \@_ in .* with signatured subroutine is experimental at \(eval /, + "`$code` warns of experimental \@_") or + diag("Warnings were:\n$warnings"); + } + + # implicit @_ + snailwarns_ok 'shift', 'shift'; + snailwarns_ok 'pop', 'pop'; + snailwarns_ok 'goto', 'goto &SUB'; # tail-call + snailwarns_ok 'subroutine entry', '&SUB'; # perl4-style + + # explicit @_ + snailwarns_ok 'shift', 'shift @_'; + snailwarns_ok 'pop', 'pop @_'; + snailwarns_ok 'array element', '$_[0]'; + snailwarns_ok 'array element', 'my $one = 1; $_[$one]'; + snailwarns_ok 'push', 'push @_, 1'; + snailwarns_ok 'unshift', 'unshift @_, 9'; + snailwarns_ok 'splice', 'splice @_, 1, 2, 3'; + snailwarns_ok 'keys on array', 'keys @_'; + snailwarns_ok 'values on array', 'values @_'; + snailwarns_ok 'each on array', 'each @_'; + snailwarns_ok 'print', 'print "a", @_, "z"'; + snailwarns_ok 'subroutine entry', 'func("a", @_, "z")'; + + # Also warns about @_ inside the signature params + like(warnings_from('sub ($x = shift) { }'), + qr/^Implicit use of \@_ in shift with signatured subroutine is experimental at \(eval /, + 'Warns of experimental @_ in param default'); + like(warnings_from('sub ($x = $_[0]) { }'), + qr/^Use of \@_ in array element with signatured subroutine is experimental at \(eval /, + 'Warns of experimental @_ in param default'); + + # Inside eval() still counts, at runtime + snailwarns_runtime_ok 'array element', 'eval q( $_[0] )'; + + # still permitted without warning + not_snailwarns_ok 'my $f = sub { my $y = shift; }'; + not_snailwarns_ok 'my $f = sub { my $y = $_[0]; }'; + not_snailwarns_ok '\&SUB'; +} + +# Warnings can be disabled +{ + my $warnings = ""; + local $SIG{__WARN__} = sub { $warnings .= join "", @_ }; + eval q{ + no warnings 'experimental::snail_in_signatures'; + sub($x) { @_ = (1,2,3) } + }; + is($warnings, "", 'No warnings emitted within scope of no warnings "experimental"'); +} + done_testing; 1; |