[perl #86136] Downgrade sort {my $a} to a warning

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.

diff --git a/op.c b/op.c
index a831831..b3a3a59 100644 (file)
--- a/op.c
+++ b/op.c
@@ -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:
@@ -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;
@@ -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;

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 8aed54e..11b5e34 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -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

diff --git a/t/lib/warnings/op b/t/lib/warnings/op
index ef83756..f74b720 100644 (file)
--- a/t/lib/warnings/op
+++ b/t/lib/warnings/op
@@ -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)"?)
@@ -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';

diff --git a/toke.c b/toke.c
index c0375ae..ddd4319 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -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;
@@ -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) {
@@ -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;