From: Dave Mitchell <davem@fdisolutions.com>
Date: Sat, 27 Mar 2004 01:54:09 +0000 (+0000)
Subject: [perl #24200] string corruption with lvalue sub
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=781e754729fc501417aaa89f25dc83f904a17c5c;p=p5sagit%2Fp5-mst-13.2.git

[perl #24200] string corruption with lvalue sub
Depending on the context, the same substr OP may want to return
a PVLV or an LV on subsequent invcations. If TARG is the wrong
type, use a mortal instead.

p4raw-id: //depot/perl@22599
---

diff --git a/pp.c b/pp.c
index 4c3e377..0bf02fa 100644
--- a/pp.c
+++ b/pp.c
@@ -3038,6 +3038,19 @@ PP(pp_substr)
 	if (utf8_curlen)
 	    sv_pos_u2b(sv, &pos, &rem);
 	tmps += pos;
+	/* we either return a PV or an LV. If the TARG hasn't been used
+	 * before, or is of that type, reuse it; otherwise use a mortal
+	 * instead. Note that LVs can have an extended lifetime, so also
+	 * dont reuse if refcount > 1 (bug #20933) */
+	if (SvTYPE(TARG) > SVt_NULL) {
+	    if ( (SvTYPE(TARG) == SVt_PVLV)
+		    ? (!lvalue || SvREFCNT(TARG) > 1)
+		    : lvalue)
+	    {
+		TARG = sv_newmortal();
+	    }
+	}
+
 	sv_setpvn(TARG, tmps, rem);
 #ifdef USE_LOCALE_COLLATE
 	sv_unmagic(TARG, PERL_MAGIC_collxfrm);
@@ -3074,8 +3087,6 @@ PP(pp_substr)
 		    sv_setpvn(sv,"",0);	/* avoid lexical reincarnation */
 	    }
 
-	    if (SvREFCNT(TARG) > 1)	/* don't share the TARG (#20933) */
-		TARG = sv_newmortal();
 	    if (SvTYPE(TARG) < SVt_PVLV) {
 		sv_upgrade(TARG, SVt_PVLV);
 		sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
diff --git a/t/op/substr.t b/t/op/substr.t
index ad35dce..681ac6d 100755
--- a/t/op/substr.t
+++ b/t/op/substr.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..186\n";
+print "1..188\n";
 
 #P = start of string  Q = start of substr  R = end of substr  S = end of string
 
@@ -629,3 +629,14 @@ ok 174, $x eq "\x{100}\x{200}\xFFb";
 	ok 186, $x eq 'aYYYYef';
     }
 }
+
+# [perl #24200] string corruption with lvalue sub
+
+{
+    my $foo = "a";
+    sub bar: lvalue { substr $foo, 0 }
+    bar = "XXX";
+    ok 187, bar eq 'XXX';
+    $foo = '123456789';
+    ok 188, bar eq '123456789';
+}