[perl #78194] Make sub calls copy pad tmps

before aliasing them to elements of @_.
Perl · Jul 26, 2013 · b479c9f · b479c9f
1 parent f62e563
commit b479c9f
Show file tree

Hide file tree

Showing 4 changed files with 12 additions and 4 deletions.
diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t
@@ -153,7 +153,8 @@ my $type = do_test('result of addition',
         $c + $d,
 'SV = ([NI])V\\($ADDR\\) at $ADDR
   REFCNT = 1
-  FLAGS = \\(PADTMP,\1OK,p\1OK\\)
+  FLAGS = \\(PADTMP,\1OK,p\1OK\\)		# $] < 5.019002
+  FLAGS = \\(\1OK,p\1OK\\)			# $] >=5.019002
   \1V = 456');
 
 ($d = "789") += 0.1;

diff --git a/pp_hot.c b/pp_hot.c
@@ -2702,7 +2702,6 @@ PP(pp_entersub)
     }
 
     ENTER;
-    SAVETMPS;
 
   retry:
     if (CvCLONE(cv) && ! CvCLONED(cv))
@@ -2802,12 +2801,18 @@ PP(pp_entersub)
 	    Copy(MARK,AvARRAY(av),items,SV*);
 	    AvFILLp(av) = items - 1;
 
+	    MARK = AvARRAY(av);
 	    while (items--) {
 		if (*MARK)
+		{
+		    if (SvPADTMP(*MARK) && !IS_PADGV(*MARK))
+			*MARK = sv_mortalcopy(*MARK);
 		    SvTEMP_off(*MARK);
+		}
 		MARK++;
 	    }
 	}
+	SAVETMPS;
 	if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
 	    !CvLVALUE(cv))
 	    DIE(aTHX_ "Can't modify non-lvalue subroutine call");
@@ -2823,6 +2828,7 @@ PP(pp_entersub)
     else {
 	I32 markix = TOPMARK;
 
+	SAVETMPS;
 	PUTBACK;
 
 	if (((PL_op->op_private

diff --git a/t/op/sub.t b/t/op/sub.t
@@ -108,8 +108,8 @@ require Config;
 $::TODO = "not fixed yet" if $Config::Config{useithreads};
 is "@scratch", "main road road main",
    'recursive calls do not share shared-hash-key TARGs';
+undef $::TODO;
 
-$::TODO = "not fixed yet";
 # [perl #78194] @_ aliasing op return values
 sub { is \$_[0], \$_[0],
         '[perl #78194] \$_[0] == \$_[0] when @_ aliases "$x"' }
@@ -119,6 +119,7 @@ sub { is \$_[0], \$_[0],
 sub not_constant () {        42 }
 sub not_constantr() { return 42 }
 eval { ${\not_constant}++ };
+$::TODO = "not fixed yet";
 is $@, "", 'sub (){42} returns a mutable value';
 undef $::TODO;
 eval { ${\not_constantr}++ };

diff --git a/t/op/tie.t b/t/op/tie.t
@@ -1370,7 +1370,7 @@ no
 no
 ########
 
-# TODO [perl #78194] Passing op return values to tie constructors
+# [perl #78194] Passing op return values to tie constructors
 sub TIEARRAY{
     print \$_[1] == \$_[1] ? "ok\n" : "not ok\n";
 };