segv in pad.c with threads (was: DBD::Oracle and Perl 5.8.2 threads)

Message-ID: <20040107121357.GD82921@dansat.data-plan.com>

Returning a closure from a thread (via join) could mess up because
pointers to PL_sv_undef weren't rejigged to point at the joiner's
version of PL_sv_undef. Also, the closure's CvGV got cloned too
but never freed, since CvGV isn't refcounted.

p4raw-id: //depot/perl@22102

diff --git a/ext/threads/t/problems.t b/ext/threads/t/problems.t
index b2b78df..81e1825 100644 (file)
--- a/ext/threads/t/problems.t
+++ b/ext/threads/t/problems.t
@@ -18,7 +18,7 @@ use threads::shared;
 # call is() from within the DESTROY() function at global destruction time,
 # and parts of Test::* may have already been freed by then
 
-print "1..8\n";
+print "1..9\n";
 
 my $test : shared = 1;
 
@@ -93,4 +93,17 @@ threads->new(
     }
 )->join;
 
+# Returing a closure from a thread caused problems. If the last index in
+# the anon sub's pad wasn't for a lexical, then a core dump could occur.
+# Otherwise, there might be leaked scalars.
+
+sub f {
+    my $x = "foo";
+    sub { $x."bar" };
+}
+
+my $string = threads->new(\&f)->join->();
+print $string eq 'foobar' ?  '' : 'not ', "ok $test - returning closure\n";
+$test++;
+
 1;

diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs
index ba3e488..48530fe 100755 (executable)
--- a/ext/threads/threads.xs
+++ b/ext/threads/threads.xs
@@ -572,12 +572,17 @@ Perl_ithread_join(pTHX_ SV *obj)
        {
          ithread*        current_thread;
          AV* params = (AV*) SvRV(thread->params);      
+         PerlInterpreter *other_perl = thread->interp;
          CLONE_PARAMS clone_params;
          clone_params.stashes = newAV();
          clone_params.flags |= CLONEf_JOIN_IN;
          PL_ptr_table = ptr_table_new();
          current_thread = Perl_ithread_get(aTHX);
          Perl_ithread_set(aTHX_ thread);
+         /* ensure 'meaningful' addresses retain their meaning */
+         ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
+         ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
+         ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
 
 #if 0
          {

diff --git a/sv.c b/sv.c
index 5efd546..995be32 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -10374,7 +10374,10 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
                 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
                 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
        }
-       CvGV(dstr)      = gv_dup(CvGV(sstr), param);
+       /* don't dup if copying back - CvGV isn't refcounted, so the
+        * duped GV may never be freed. A bit of a hack! DAPM */
+       CvGV(dstr)      = (param->flags & CLONEf_JOIN_IN) ?
+               Nullgv : gv_dup(CvGV(sstr), param) ;
        if (param->flags & CLONEf_COPY_STACKS) {
          CvDEPTH(dstr) = CvDEPTH(sstr);
        } else {