C<foreach my $x ...> in pseudo-fork()ed process may diddle

parent's memory; fix it by keeping track of the actual pad
offset rather than a raw pointer (this change is probably also
relevant to non-ithreads case to avoid fallout from reallocs of
the pad array, but is currently only enabled for the ithreads
case in the interests of minimal disruption to existing "well
tested" code)

p4raw-id: //depot/perl@7858

11 files changed, 72 insertions, 1 deletions

diff --git a/embed.h b/embed.h
index 1301e3e7fa..14dcbd7d14 100644
--- a/embed.h
+++ b/embed.h
@@ -597,6 +597,7 @@
 #define save_pptr		Perl_save_pptr
 #define save_vptr		Perl_save_vptr
 #define save_re_context		Perl_save_re_context
+#define save_padsv		Perl_save_padsv
 #define save_sptr		Perl_save_sptr
 #define save_svref		Perl_save_svref
 #define save_threadsv		Perl_save_threadsv
@@ -2061,6 +2062,7 @@
 #define save_pptr(a)		Perl_save_pptr(aTHX_ a)
 #define save_vptr(a)		Perl_save_vptr(aTHX_ a)
 #define save_re_context()	Perl_save_re_context(aTHX)
+#define save_padsv(a)		Perl_save_padsv(aTHX_ a)
 #define save_sptr(a)		Perl_save_sptr(aTHX_ a)
 #define save_svref(a)		Perl_save_svref(aTHX_ a)
 #define save_threadsv(a)	Perl_save_threadsv(aTHX_ a)
@@ -4038,6 +4040,8 @@
 #define save_vptr		Perl_save_vptr
 #define Perl_save_re_context	CPerlObj::Perl_save_re_context
 #define save_re_context		Perl_save_re_context
+#define Perl_save_padsv		CPerlObj::Perl_save_padsv
+#define save_padsv		Perl_save_padsv
 #define Perl_save_sptr		CPerlObj::Perl_save_sptr
 #define save_sptr		Perl_save_sptr
 #define Perl_save_svref		CPerlObj::Perl_save_svref
diff --git a/embed.pl b/embed.pl
index b8abef3a58..1d35bf6917 100755
--- a/embed.pl
+++ b/embed.pl
@@ -1933,6 +1933,7 @@ Ap	|SV*	|save_scalar	|GV* gv
 Ap	|void	|save_pptr	|char** pptr
 Ap	|void	|save_vptr	|void* pptr
 Ap	|void	|save_re_context
+Ap	|void	|save_padsv	|PADOFFSET off
 Ap	|void	|save_sptr	|SV** sptr
 Ap	|SV*	|save_svref	|SV** sptr
 Ap	|SV**	|save_threadsv	|PADOFFSET i
diff --git a/global.sym b/global.sym
index c5e527b9bd..b5c367d651 100644
--- a/global.sym
+++ b/global.sym
@@ -358,6 +358,7 @@ Perl_save_scalar
 Perl_save_pptr
 Perl_save_vptr
 Perl_save_re_context
+Perl_save_padsv
 Perl_save_sptr
 Perl_save_svref
 Perl_save_threadsv
diff --git a/objXSUB.h b/objXSUB.h
index 88eb400f69..91dc6df07c 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -1433,6 +1433,10 @@
 #define Perl_save_re_context	pPerl->Perl_save_re_context
 #undef  save_re_context
 #define save_re_context		Perl_save_re_context
+#undef  Perl_save_padsv
+#define Perl_save_padsv		pPerl->Perl_save_padsv
+#undef  save_padsv
+#define save_padsv		Perl_save_padsv
 #undef  Perl_save_sptr
 #define Perl_save_sptr		pPerl->Perl_save_sptr
 #undef  save_sptr
diff --git a/perlapi.c b/perlapi.c
index a2e73e4bd0..02c5aa3bca 100644
--- a/perlapi.c
+++ b/perlapi.c
@@ -2615,6 +2615,13 @@ Perl_save_re_context(pTHXo)
     ((CPerlObj*)pPerl)->Perl_save_re_context();
 }
 
+#undef  Perl_save_padsv
+void
+Perl_save_padsv(pTHXo_ PADOFFSET off)
+{
+    ((CPerlObj*)pPerl)->Perl_save_padsv(off);
+}
+
 #undef  Perl_save_sptr
 void
 Perl_save_sptr(pTHXo_ SV** sptr)
diff --git a/pp_ctl.c b/pp_ctl.c
index 2b217dd059..d22f2efc0f 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1776,9 +1776,11 @@ PP(pp_enteriter)
     else
 #endif /* USE_THREADS */
     if (PL_op->op_targ) {
+#ifndef USE_ITHREADS
 	svp = &PL_curpad[PL_op->op_targ];		/* "my" variable */
 	SAVESPTR(*svp);
-#ifdef USE_ITHREADS
+#else
+	SAVEPADSV(PL_op->op_targ);
 	iterdata = (void*)PL_op->op_targ;
 	cxtype |= CXp_PADVAR;
 #endif
diff --git a/proto.h b/proto.h
index 91b7f86d10..2a601956f9 100644
--- a/proto.h
+++ b/proto.h
@@ -669,6 +669,7 @@ PERL_CALLCONV SV*	Perl_save_scalar(pTHX_ GV* gv);
 PERL_CALLCONV void	Perl_save_pptr(pTHX_ char** pptr);
 PERL_CALLCONV void	Perl_save_vptr(pTHX_ void* pptr);
 PERL_CALLCONV void	Perl_save_re_context(pTHX);
+PERL_CALLCONV void	Perl_save_padsv(pTHX_ PADOFFSET off);
 PERL_CALLCONV void	Perl_save_sptr(pTHX_ SV** sptr);
 PERL_CALLCONV SV*	Perl_save_svref(pTHX_ SV** sptr);
 PERL_CALLCONV SV**	Perl_save_threadsv(pTHX_ PADOFFSET i);
diff --git a/scope.c b/scope.c
index 7c904b433f..82cd748274 100644
--- a/scope.c
+++ b/scope.c
@@ -470,6 +470,17 @@ Perl_save_sptr(pTHX_ SV **sptr)
     SSPUSHINT(SAVEt_SPTR);
 }
 
+void
+Perl_save_padsv(pTHX_ PADOFFSET off)
+{
+    dTHR;
+    SSCHECK(4);
+    SSPUSHPTR(PL_curpad[off]);
+    SSPUSHPTR(PL_curpad);
+    SSPUSHLONG((long)off);
+    SSPUSHINT(SAVEt_PADSV);
+}
+
 SV **
 Perl_save_threadsv(pTHX_ PADOFFSET i)
 {
@@ -961,6 +972,14 @@ Perl_leave_scope(pTHX_ I32 base)
 	    else
 		PL_curpad = Null(SV**);
 	    break;
+	case SAVEt_PADSV:
+	    {
+		PADOFFSET off = (PADOFFSET)SSPOPLONG;
+		ptr = SSPOPPTR;
+		if (ptr)
+		    ((SV**)ptr)[off] = (SV*)SSPOPPTR;
+	    }
+	    break;
 	default:
 	    Perl_croak(aTHX_ "panic: leave_scope inconsistency");
 	}
diff --git a/scope.h b/scope.h
index 9152b397e7..3e05962e68 100644
--- a/scope.h
+++ b/scope.h
@@ -33,6 +33,7 @@
 #define SAVEt_I8		32
 #define SAVEt_COMPPAD		33
 #define SAVEt_GENERIC_PVREF	34
+#define SAVEt_PADSV		35
 
 #define SSCHECK(need) if (PL_savestack_ix + need > PL_savestack_max) savestack_grow()
 #define SSPUSHINT(i) (PL_savestack[PL_savestack_ix++].any_i32 = (I32)(i))
@@ -101,6 +102,7 @@ Closing bracket on a callback.  See C<ENTER> and L<perlcall>.
 #define SAVESPTR(s)	save_sptr((SV**)&(s))
 #define SAVEPPTR(s)	save_pptr(SOFT_CAST(char**)&(s))
 #define SAVEVPTR(s)	save_vptr((void*)&(s))
+#define SAVEPADSV(s)	save_padsv(s)
 #define SAVEFREESV(s)	save_freesv((SV*)(s))
 #define SAVEFREEOP(o)	save_freeop(SOFT_CAST(OP*)(o))
 #define SAVEFREEPV(p)	save_freepv(SOFT_CAST(char*)(p))
diff --git a/sv.c b/sv.c
index acb0b82efe..35cef28dbc 100644
--- a/sv.c
+++ b/sv.c
@@ -7656,6 +7656,14 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
 	    av = (AV*)POPPTR(ss,ix);
 	    TOPPTR(nss,ix) = av_dup(av);
 	    break;
+	case SAVEt_PADSV:
+	    longval = (long)POPLONG(ss,ix);
+	    TOPLONG(nss,ix) = longval;
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+	    sv = (SV*)POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = sv_dup(sv);
+	    break;
 	default:
 	    Perl_croak(aTHX_ "panic: ss_dup inconsistency");
 	}
diff --git a/t/op/fork.t b/t/op/fork.t
index 93cf673228..88b6b4b74c 100755
--- a/t/op/fork.t
+++ b/t/op/fork.t
@@ -184,6 +184,28 @@ child 3
 [1] -2- -3-
 -1- -2- -3-
 ########
+$| = 1;
+foreach my $c (1,2,3) {
+    if (fork) {
+	print "parent $c\n";
+    }
+    else {
+	print "child $c\n";
+	exit;
+    }
+}
+while (wait() != -1) { print "waited\n" }
+EXPECT
+child 1
+child 2
+child 3
+parent 1
+parent 2
+parent 3
+waited
+waited
+waited
+########
 use Config;
 $| = 1;
 $\ = "\n";