Stop split from mangling constants

At compile time, if split occurs on the right-hand side of an assign-
ment to a list of scalars, if the limit argument is a constant con-
taining the number 0 then it is modified in place to hold one more
than the number of scalars.

This means ‘constants’ can change their values, if they happen to be
in the wrong place at the wrong time:

$ ./perl -Ilib -le 'use constant NULL => 0; ($a,$b,$c) = split //, $foo, NULL; print NULL'
4

I considered checking the reference count on the SV, but since XS code
could create its own const ops with weak references to the same cons-
tants elsewhere, the safest way to avoid modifying someone else’s SV
is to mark the split op in ck_split so we know the SV belongs to that
split op alone.

Also, to be on the safe side, turn off the read-only flag before modi-
fying the SV, instead of relying on the special case for compile time
in sv_force_normal.

diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index bbb2453..d59f534 100644 (file)
--- a/dist/B-Deparse/Deparse.pm
+++ b/dist/B-Deparse/Deparse.pm
@@ -2957,14 +2957,14 @@ sub pp_list {
        # OPs that store things other than flags in their op_private,
        # like OP_AELEMFAST, won't be immediate children of a list.
        #
-       # OP_ENTERSUB can break this logic, so check for it.
+       # OP_ENTERSUB and OP_SPLIT can break this logic, so check for them.
        # I suspect that open and exit can too.
+       # XXX This really needs to be rewritten to accept only those ops
+       #     known to take the OPpLVAL_INTRO flag.
 
        if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
                or $lop->name eq "undef")
-           or $lop->name eq "entersub"
-           or $lop->name eq "exit"
-           or $lop->name eq "open")
+           or $lop->name =~ /^(?:entersub|exit|open|split)\z/)
        {
            $local = ""; # or not
            last;

diff --git a/dump.c b/dump.c
index 1e16aee..caa27c1 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -791,6 +791,7 @@ OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
+OP_PRIVATE_ONCE(op_split, OPpSPLIT_IMPLIM, ",IMPLIM");
 
 struct op_private_by_op {
     U16 op_type;
@@ -818,6 +819,7 @@ const struct op_private_by_op op_private_names[] = {
     {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
     {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
     {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
+    {OP_SPLIT, C_ARRAY_LENGTH(op_split_names), op_split_names },
     {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
 };
 

diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 146d4fe..4e49b5a 100644 (file)
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -663,6 +663,7 @@ for ("mapwhile", "mapstart", "grepwhile", "grepstart");
 $priv{$_}{128} = '+1' for qw "caller wantarray runcv";
 @{$priv{coreargs}}{1,2,64,128} = ('DREF1','DREF2','$MOD','MARK');
 $priv{$_}{128} = 'UTF' for qw "last redo next goto dump";
+$priv{split}{128} = 'IMPLIM';
 
 our %hints; # used to display each COP's op_hints values
 

diff --git a/op.c b/op.c
index 4276d3c..3c113ac 100644 (file)
--- a/op.c
+++ b/op.c
@@ -5646,9 +5646,22 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
                      ((LISTOP*)right)->op_last->op_type == OP_CONST)
                    {
-                       SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
+                       SV ** const svp =
+                           &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
+                       SV * const sv = *svp;
                        if (SvIOK(sv) && SvIVX(sv) == 0)
+                       {
+                         if (right->op_private & OPpSPLIT_IMPLIM) {
+                           /* our own SV, created in ck_split */
+                           SvREADONLY_off(sv);
                            sv_setiv(sv, PL_modcount+1);
+                         }
+                         else {
+                           /* SV may belong to someone else */
+                           SvREFCNT_dec(sv);
+                           *svp = newSViv(PL_modcount+1);
+                         }
+                       }
                    }
                }
            }
@@ -9834,7 +9847,10 @@ Perl_ck_split(pTHX_ OP *o)
     scalar(kid);
 
     if (!kid->op_sibling)
+    {
        op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
+       o->op_private |= OPpSPLIT_IMPLIM;
+    }
     assert(kid->op_sibling);
 
     kid = kid->op_sibling;

diff --git a/op.h b/op.h
index caa1b8b..b033e74 100644 (file)
--- a/op.h
+++ b/op.h
@@ -324,6 +324,9 @@ Deprecated.  Use C<GIMME_V> instead.
 /* Private for OP_(LAST|REDO|NEXT|GOTO|DUMP) */
 #define OPpPV_IS_UTF8          128     /* label is in UTF8 */
 
+/* Private for OP_SPLIT */
+#define OPpSPLIT_IMPLIM                128     /* implicit limit */
+
 struct op {
     BASEOP
 };

diff --git a/t/op/split.t b/t/op/split.t
index 5e01159..7e0008e 100644 (file)
--- a/t/op/split.t
+++ b/t/op/split.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 118;
+plan tests => 119;
 
 $FS = ':';
 
@@ -488,3 +488,7 @@ is($cnt, scalar(@ary));
         "RT #116086: split on string of single hex-20: first element is non-empty; multiple contiguous space characters";
 }
 
+# Nasty interaction between split and use constant
+use constant nought => 0;
+($a,$b,$c) = split //, $foo, nought;
+is nought, 0, 'split does not mangle 0 constants';