From: Father Chrysostomos <sprout@cpan.org>
Date: Thu, 16 Jun 2011 13:27:50 +0000 (-0700)
Subject: [perl #81944] Non-lvalue subs do not copy return values
X-Git-Tag: v5.15.0~53
X-Git-Url: https://perl5.git.perl.org/perl5.git/commitdiff_plain/3ed94dc04bd73c956fbfa66348a55f94c8a2268b

[perl #81944] Non-lvalue subs do not copy return values

return and leavesub see if they can cheat by not copying anything
marked TEMP, since presumably nothing else is using it.  That means
the return values of delete() and shift() are not copied.  Since @_
aliases to the caller’s variables, sometimes what is returned *is*
used elsewhere and still marked TEMP.  So cases like sub { return
delete $_[0] } ->($x) end up returning $x unchanged, instead of
copying it.

As mentioned in the ticket, the solution is to copy only if the refer-
ence count is 1.

This also allows me to simplify the lvalue-returning code without
spreading this bug further.  (pp_leavesublv currently avoids calling
sv_2mortal, in order not to set the TEMP flag.)
---

diff --git a/pp_ctl.c b/pp_ctl.c
index c600a91..303e356 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2352,7 +2352,7 @@ PP(pp_return)
 	if (MARK < SP) {
 	    if (popsub2) {
 		if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
-		    if (SvTEMP(TOPs)) {
+		    if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
 			*++newsp = SvREFCNT_inc(*SP);
 			FREETMPS;
 			sv_2mortal(*newsp);
@@ -2365,7 +2365,7 @@ PP(pp_return)
 			if (gmagic) SvGETMAGIC(sv);
 		    }
 		}
-		else if (SvTEMP(*SP)) {
+		else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) {
 		    *++newsp = *SP;
 		    if (gmagic) SvGETMAGIC(*SP);
 		}
@@ -2380,7 +2380,7 @@ PP(pp_return)
       }
       else if (gimme == G_ARRAY) {
 	while (++MARK <= SP) {
-	    *++newsp = popsub2 && SvTEMP(*MARK)
+	    *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
 			? *MARK : sv_mortalcopy(*MARK);
 	    TAINT_NOT;		/* Each item is independent */
 	}
diff --git a/pp_hot.c b/pp_hot.c
index f1c4977..b2970d8 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2611,7 +2611,7 @@ PP(pp_leavesub)
 	MARK = newsp + 1;
 	if (MARK <= SP) {
 	    if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
-		if (SvTEMP(TOPs)) {
+		if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
 		    *MARK = SvREFCNT_inc(TOPs);
 		    FREETMPS;
 		    sv_2mortal(*MARK);
@@ -2624,7 +2624,7 @@ PP(pp_leavesub)
 		    SvREFCNT_dec(sv);
 		}
 	    }
-	    else if (SvTEMP(TOPs)) {
+	    else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
 		*MARK = TOPs;
 		if (gmagic) SvGETMAGIC(TOPs);
 	    }
@@ -2639,7 +2639,7 @@ PP(pp_leavesub)
     }
     else if (gimme == G_ARRAY) {
 	for (MARK = newsp + 1; MARK <= SP; MARK++) {
-	    if (!SvTEMP(*MARK)) {
+	    if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1) {
 		*MARK = sv_mortalcopy(*MARK);
 		TAINT_NOT;	/* Each item is independent */
 	    }
diff --git a/t/op/sub.t b/t/op/sub.t
index 5bd4508..b8e514d 100644
--- a/t/op/sub.t
+++ b/t/op/sub.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan( tests => 8 );
+plan( tests => 14 );
 
 sub empty_sub {}
 
@@ -40,3 +40,27 @@ is(scalar(@test), 0, 'Didnt return anything');
     push @a, 34, 35, &{$x == $x};
     ok(eq_array(\@a, [34,35]), "yes without args");
 }
+
+# [perl #81944] return should always copy
+{
+    $foo{bar} = 7;
+    for my $x ($foo{bar}) {
+	# Pity test.pl doesnt have isn't.
+	isnt \sub { delete $foo{bar} }->(), \$x,
+	   'result of delete(helem) is copied when returned';
+    }
+    $foo{bar} = 7;
+    for my $x ($foo{bar}) {
+	isnt \sub { return delete $foo{bar} }->(), \$x,
+	   'result of delete(helem) is copied when explicitly returned';
+    }
+    my $x;
+    isnt \sub { delete $_[0] }->($x), \$x,
+      'result of delete(aelem) is copied when returned';
+    isnt \sub { return delete $_[0] }->($x), \$x,
+      'result of delete(aelem) is copied when explicitly returned';
+    isnt \sub { ()=\@_; shift }->($x), \$x,
+      'result of shift is copied when returned';
+    isnt \sub { ()=\@_; return shift }->($x), \$x,
+      'result of shift is copied when explicitly returned';
+}