Skip to content

Commit

Permalink
Emit experimental::snail_in_signatures warnings on uses of @_ (aka "s…
Browse files Browse the repository at this point in the history 
…nail") in signatured subs
  • Loading branch information
@leonerd
leonerd committed Jan 31, 2022
1 parent 1c547c3 commit 40151a4
Show file tree
Hide file tree
Showing 3 changed files with 164 additions and 2 deletions.
56 changes: 56 additions & 0 deletions op.c
View file
Expand Up @@ -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.
*/
Expand Down Expand Up @@ -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;
}
Expand Down
17 changes: 17 additions & 0 deletions pod/perldiag.pod
View file
Expand Up @@ -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/

Expand Down Expand Up @@ -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
Expand Down
93 changes: 91 additions & 2 deletions t/op/signatures.t
View file
Expand Up @@ -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";
Expand Down Expand Up @@ -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 \@_";
Expand Down Expand Up @@ -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;

0 comments on commit 40151a4

Please sign in to comment.