[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.)

3 files changed, 31 insertions, 7 deletions

diff --git a/pp_ctl.c b/pp_ctl.c
index c600a9137d..303e3565d6 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 f1c4977cd2..b2970d88c6 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 5bd4508ce4..b8e514dd88 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';
+}