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.

6 files changed, 32 insertions, 6 deletions

diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index bbb2453fe2..d59f534940 100644
--- 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 1e16aee73f..caa27c1e69 100644
--- 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 146d4fe47e..4e49b5ad8c 100644
--- 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 4276d3c46b..3c113ac3d2 100644
--- 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 caa1b8b3c5..b033e7405d 100644
--- 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 5e011595e2..7e0008e654 100644
--- 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';