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

diff --git a/embed.h b/embed.h
index 1301e3e..14dcbd7 100644 (file)
--- 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 b8abef3..1d35bf6 100755 (executable)
--- 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 c5e527b..b5c367d 100644 (file)
--- 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 88eb400..91dc6df 100644 (file)
--- 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 a2e73e4..02c5aa3 100644 (file)
--- 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 2b217dd..d22f2ef 100644 (file)
--- 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 91b7f86..2a60195 100644 (file)
--- 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 7c904b4..82cd748 100644 (file)
--- 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 9152b39..3e05962 100644 (file)
--- 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 acb0b82..35cef28 100644 (file)
--- 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 93cf673..88b6b4b 100755 (executable)
--- 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";