Skip to content

Commit

Permalink
[perl #86136] Downgrade sort {my $a} to a warning
Browse files Browse the repository at this point in the history 
The code in toke.c for detecting lexical $a or $b used in a comparison
in a sort block was simply horrible.  If the last-used named list or
unary op (PL_last_lop_op) was sort, then it would scan for <=> or cmp
anywhere on the current line of code.  That meant that, although this
would die:

    my $a; sort { $a <=> $b } ()

This would do the wrong thing without complaint:

    my $a; sort { print; $a <=> $b } ()

And this would die, completely gratuitously:

    my $a; sort @t; $a + $cmp;

Since perl is only guessing that lexical $a or $b *might* have
been used accidentally, this should be a warning, and certainly
not an error.

Also, scanning the source code like that for <=> (even inside a
string!) can never work.  One would have to parse it and examine the
resulting op tree.

In fact, since we *are* parsing it anyway, we *can* examine
the op tree.

So that’s exactly what this commit does.  Based on the existing behav-
iour, but with far fewer false positives, it checks for a cmp or <=>
op as the last statement of a sort block and warns about any operand
that is a lexical $a or $b.
  • Loading branch information
Father Chrysostomos committed Jul 4, 2012
1 parent 449d128 commit 271c8bd
Show file tree
Hide file tree
Showing 4 changed files with 151 additions and 29 deletions.
41 changes: 38 additions & 3 deletions op.c
View file
Expand Up @@ -9315,7 +9315,17 @@ S_simplify_sort(pTHX_ OP *o)
GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
kid = kUNOP->op_first; /* get past null */
if (kid->op_type != OP_SCOPE)
{
if (kid->op_type != OP_LEAVE) return;
kid = kLISTOP->op_last;
switch(kid->op_type) {
case OP_NCMP:
case OP_I_NCMP:
case OP_SCMP:
goto padkids;
}
return;
}
kid = kLISTOP->op_last; /* get past scope */
switch(kid->op_type) {
case OP_NCMP:
Expand All @@ -9326,8 +9336,34 @@ S_simplify_sort(pTHX_ OP *o)
return;
}
k = kid; /* remember this node*/
if (kBINOP->op_first->op_type != OP_RV2SV)
if (kBINOP->op_first->op_type != OP_RV2SV
|| kBINOP->op_last ->op_type != OP_RV2SV)
{
/*
Warn about my($a) or my($b) in a sort block, *if* $a or $b is
then used in a comparison. This catches most, but not
all cases. For instance, it catches
sort { my($a); $a <=> $b }
but not
sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
(although why you'd do that is anyone's guess).
*/

padkids:
if (!ckWARN(WARN_SYNTAX)) return;
kid = kBINOP->op_first;
do {
if (kid->op_type == OP_PADSV) {
SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
if (SvCUR(name) == 2 && *SvPVX(name) == '$'
&& (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"\"my %s\" used in sort comparison",
SvPVX(name));
}
} while ((kid = kid->op_sibling));
return;
}
kid = kBINOP->op_first; /* get past cmp */
if (kUNOP->op_first->op_type != OP_GV)
return;
Expand All @@ -9344,8 +9380,7 @@ S_simplify_sort(pTHX_ OP *o)
return;

kid = k; /* back to cmp */
if (kBINOP->op_last->op_type != OP_RV2SV)
return;
/* already checked above that it is rv2sv */
kid = kBINOP->op_last; /* down to 2nd arg */
if (kUNOP->op_first->op_type != OP_GV)
return;
Expand Down
8 changes: 8 additions & 0 deletions pod/perldiag.pod
View file
Expand Up @@ -3308,6 +3308,14 @@ the meantime, try using scientific notation (e.g. "1e6" instead of
a number. This happens, for example with C<\o{}>, with no number between
the braces.

=item "my %s" used in sort comparison

(W syntax) The package variables $a and $b are used for sort comparisons.
You used $a or $b in as an operand to the C<< <=> >> or C<cmp> operator inside a
sort comparison block, and the variable had earlier been declared as a
lexical variable. Either qualify the sort variable with the package
name, or rename the lexical variable.

=item Octal number > 037777777777 non-portable

(W portable) The octal number you specified is larger than 2**32-1
Expand Down
105 changes: 105 additions & 0 deletions t/lib/warnings/op
View file
Expand Up @@ -73,6 +73,8 @@
(Maybe you should just omit the defined()?)
my %h ; defined %h ;

"my %s" used in sort comparison

$[ used in comparison (did you mean $] ?)

length() used on @array (did you mean "scalar(@array)"?)
Expand Down Expand Up @@ -928,6 +930,109 @@ Prototype mismatch: sub main::fred () vs ($) at - line 4.
Prototype mismatch: sub main::freD () vs ($) at - line 11.
Prototype mismatch: sub main::FRED () vs ($) at - line 14.
########
# op.c [S_simplify_sort]
# [perl #86136]
my @tests = split /^/, '
sort {$a <=> $b} @a;
sort {$a cmp $b} @a;
{ use integer; sort {$a <=> $b} @a}
sort {$b <=> $a} @a;
sort {$b cmp $a} @a;
{ use integer; sort {$b <=> $a} @a}
';
for my $pragma ('use warnings "syntax";', '') {
for my $vars ('', 'my $a;', 'my $b;', 'my ($a,$b);') {
for my $inner_stmt ('', 'print;', 'func();') {
eval "#line " . ++$line . "01 -\n$pragma\n$vars"
. join "", map s/sort \{\K/$inner_stmt/r, @tests;
$@ and die;
}
}
}
sub func{}
use warnings 'syntax';
my $a;
# These used to be errors!
sort { ; } $a <=> $b;
sort { ; } $a, "<=>";
sort { ; } $a, $cmp;
sort $a, $b if $cmpany_name;
sort if $a + $cmp;
sort @t; $a + $cmp;
EXPECT
"my $a" used in sort comparison at - line 403.
"my $a" used in sort comparison at - line 404.
"my $a" used in sort comparison at - line 405.
"my $a" used in sort comparison at - line 406.
"my $a" used in sort comparison at - line 407.
"my $a" used in sort comparison at - line 408.
"my $a" used in sort comparison at - line 503.
"my $a" used in sort comparison at - line 504.
"my $a" used in sort comparison at - line 505.
"my $a" used in sort comparison at - line 506.
"my $a" used in sort comparison at - line 507.
"my $a" used in sort comparison at - line 508.
"my $a" used in sort comparison at - line 603.
"my $a" used in sort comparison at - line 604.
"my $a" used in sort comparison at - line 605.
"my $a" used in sort comparison at - line 606.
"my $a" used in sort comparison at - line 607.
"my $a" used in sort comparison at - line 608.
"my $b" used in sort comparison at - line 703.
"my $b" used in sort comparison at - line 704.
"my $b" used in sort comparison at - line 705.
"my $b" used in sort comparison at - line 706.
"my $b" used in sort comparison at - line 707.
"my $b" used in sort comparison at - line 708.
"my $b" used in sort comparison at - line 803.
"my $b" used in sort comparison at - line 804.
"my $b" used in sort comparison at - line 805.
"my $b" used in sort comparison at - line 806.
"my $b" used in sort comparison at - line 807.
"my $b" used in sort comparison at - line 808.
"my $b" used in sort comparison at - line 903.
"my $b" used in sort comparison at - line 904.
"my $b" used in sort comparison at - line 905.
"my $b" used in sort comparison at - line 906.
"my $b" used in sort comparison at - line 907.
"my $b" used in sort comparison at - line 908.
"my $a" used in sort comparison at - line 1003.
"my $b" used in sort comparison at - line 1003.
"my $a" used in sort comparison at - line 1004.
"my $b" used in sort comparison at - line 1004.
"my $a" used in sort comparison at - line 1005.
"my $b" used in sort comparison at - line 1005.
"my $b" used in sort comparison at - line 1006.
"my $a" used in sort comparison at - line 1006.
"my $b" used in sort comparison at - line 1007.
"my $a" used in sort comparison at - line 1007.
"my $b" used in sort comparison at - line 1008.
"my $a" used in sort comparison at - line 1008.
"my $a" used in sort comparison at - line 1103.
"my $b" used in sort comparison at - line 1103.
"my $a" used in sort comparison at - line 1104.
"my $b" used in sort comparison at - line 1104.
"my $a" used in sort comparison at - line 1105.
"my $b" used in sort comparison at - line 1105.
"my $b" used in sort comparison at - line 1106.
"my $a" used in sort comparison at - line 1106.
"my $b" used in sort comparison at - line 1107.
"my $a" used in sort comparison at - line 1107.
"my $b" used in sort comparison at - line 1108.
"my $a" used in sort comparison at - line 1108.
"my $a" used in sort comparison at - line 1203.
"my $b" used in sort comparison at - line 1203.
"my $a" used in sort comparison at - line 1204.
"my $b" used in sort comparison at - line 1204.
"my $a" used in sort comparison at - line 1205.
"my $b" used in sort comparison at - line 1205.
"my $b" used in sort comparison at - line 1206.
"my $a" used in sort comparison at - line 1206.
"my $b" used in sort comparison at - line 1207.
"my $a" used in sort comparison at - line 1207.
"my $b" used in sort comparison at - line 1208.
"my $a" used in sort comparison at - line 1208.
########
# op.c [Perl_ck_cmp]
use warnings 'syntax' ;
no warnings 'deprecated';
Expand Down
26 changes: 0 additions & 26 deletions toke.c
View file
Expand Up @@ -8498,7 +8498,6 @@ static int
S_pending_ident(pTHX)
{
dVAR;
register char *d;
PADOFFSET tmp = 0;
/* pit holds the identifier we read and pending_ident is reset */
char pit = PL_pending_ident;
Expand Down Expand Up @@ -8540,14 +8539,6 @@ S_pending_ident(pTHX)

/*
build the ops for accesses to a my() variable.
Deny my($a) or my($b) in a sort block, *if* $a or $b is
then used in a comparison. This catches most, but not
all cases. For instance, it catches
sort { my($a); $a <=> $b }
but not
sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
(although why you'd do that is anyone's guess).
*/

if (!has_colon) {
Expand Down Expand Up @@ -8576,23 +8567,6 @@ S_pending_ident(pTHX)
return WORD;
}

/* if it's a sort block and they're naming $a or $b */
if (PL_last_lop_op == OP_SORT &&
PL_tokenbuf[0] == '$' &&
(PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
&& !PL_tokenbuf[2])
{
for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
d < PL_bufend && *d != '\n';
d++)
{
if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
PL_tokenbuf);
}
}
}

pl_yylval.opval = newOP(OP_PADANY, 0);
pl_yylval.opval->op_targ = tmp;
return PRIVATEREF;
Expand Down

0 comments on commit 271c8bd

Please sign in to comment.