Always copy return values when exiting scope

v5.14.0-642-g3ed94dc fixed certain instances where returning from a sub
incorrectly returned the actual value rather than a copy, e.g.

    sub f { delete $foo{bar} }

This was because if the value(s) being returned had SvTEMP set, copying
was skipped. That commit added an extra condition to the skip test,
SvREFCNT(sv) == 1.

However, this applies equally well to other scope exits, for example

    do { ...; delete $foo{bar} }

So this commits adds the RC==1 test to S_leave_common() too, which handles
all the non-sub scope exits. As well as adding a test to do.t, it adds an
additional test to sub.t, since the original tests, although they
*detected* a non-copied return, didn't actually demonstrate a case where
it was actually harmful.

Note that S_leave_common() also sometimes skips on PADTMPs as well as
TEMPs, so this commit as a side-effect also makes it copy PADTMPs unless
their RC ==1. But since their RC should in fact almost always be 1 anyway,
in practice it makes no difference.

diff --git a/pp_ctl.c b/pp_ctl.c
index 82189bb..d1229af 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2047,12 +2047,15 @@ S_leave_common(pTHX_ SV **newsp, SV **mark, I32 gimme,
 
     TAINT_NOT;
     if (gimme == G_SCALAR) {
-       if (MARK < SP)
-           *++newsp = (SvFLAGS(*SP) & flags)
-                           ? *SP
+       if (MARK < SP) {
+            SV *sv = *SP;
+
+           *++newsp = ((SvFLAGS(sv) & flags) && SvREFCNT(sv) == 1)
+                           ? sv 
                            : lvalue
-                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
-                               : sv_mortalcopy(*SP);
+                               ? sv_2mortal(SvREFCNT_inc_simple_NN(sv))
+                               : sv_mortalcopy(sv);
+        }
        else {
            EXTEND(newsp, 1);
            *++newsp = &PL_sv_undef;
@@ -2061,12 +2064,13 @@ S_leave_common(pTHX_ SV **newsp, SV **mark, I32 gimme,
     else if (gimme == G_ARRAY) {
        /* in case LEAVE wipes old return values */
        while (++MARK <= SP) {
-           if (SvFLAGS(*MARK) & flags)
-               *++newsp = *MARK;
+            SV *sv = *MARK;
+           if ((SvFLAGS(sv) & flags) && SvREFCNT(sv) == 1)
+               *++newsp = sv;
            else {
                *++newsp = lvalue
-                           ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
-                           : sv_mortalcopy(*MARK);
+                           ? sv_2mortal(SvREFCNT_inc_simple_NN(sv))
+                           : sv_mortalcopy(sv);
                TAINT_NOT;      /* Each item is independent */
            }
        }

diff --git a/t/op/do.t b/t/op/do.t
index 49c0de3..3cc4eae 100644 (file)
--- a/t/op/do.t
+++ b/t/op/do.t
@@ -280,4 +280,17 @@ SKIP: {
     }
 }
 
+{
+    # follow-up to [perl #91844]: a do should always return a copy,
+    # not the original
+
+    my %foo;
+    $foo{bar} = 7;
+    my $r = \$foo{bar};
+    sub {
+        $$r++;
+        isnt($_[0], $$r, "result of delete(helem) is copied: practical test");
+    }->(do { 1; delete $foo{bar} });
+}
+
 done_testing();

diff --git a/t/op/sub.t b/t/op/sub.t
index 7c3fc5c..380334b 100644 (file)
--- a/t/op/sub.t
+++ b/t/op/sub.t
@@ -6,7 +6,7 @@ BEGIN {
     set_up_inc('../lib');
 }
 
-plan(tests => 59);
+plan(tests => 60);
 
 sub empty_sub {}
 
@@ -63,6 +63,13 @@ is(scalar(@test), 0, 'Didnt return anything');
       'result of shift is copied when returned';
     isnt \sub { ()=\@_; return shift }->($x), \$x,
       'result of shift is copied when explicitly returned';
+
+    $foo{bar} = 7;
+    my $r = \$foo{bar};
+    sub {
+        $$r++;
+        isnt($_[0], $$r, "result of delete(helem) is copied: practical test");
+    }->(sub { delete $foo{bar} }->());
 }
 
 fresh_perl_is