New attempt to clone callack

Message-ID: <B7451B6F.12B7%artur@contiller.se>

p4raw-id: //depot/perl@10486

diff --git a/embedvar.h b/embedvar.h
index a77a273..42b51e0 100644 (file)
--- a/embedvar.h
+++ b/embedvar.h
@@ -200,6 +200,7 @@
 #define PL_bufend              (PERL_GET_INTERP->Ibufend)
 #define PL_bufptr              (PERL_GET_INTERP->Ibufptr)
 #define PL_checkav             (PERL_GET_INTERP->Icheckav)
+#define PL_clone_callbacks     (PERL_GET_INTERP->Iclone_callbacks)
 #define PL_collation_ix                (PERL_GET_INTERP->Icollation_ix)
 #define PL_collation_name      (PERL_GET_INTERP->Icollation_name)
 #define PL_collation_standard  (PERL_GET_INTERP->Icollation_standard)
@@ -482,6 +483,7 @@
 #define PL_bufend              (vTHX->Ibufend)
 #define PL_bufptr              (vTHX->Ibufptr)
 #define PL_checkav             (vTHX->Icheckav)
+#define PL_clone_callbacks     (vTHX->Iclone_callbacks)
 #define PL_collation_ix                (vTHX->Icollation_ix)
 #define PL_collation_name      (vTHX->Icollation_name)
 #define PL_collation_standard  (vTHX->Icollation_standard)
@@ -900,6 +902,7 @@
 #define PL_bufend              (aTHXo->interp.Ibufend)
 #define PL_bufptr              (aTHXo->interp.Ibufptr)
 #define PL_checkav             (aTHXo->interp.Icheckav)
+#define PL_clone_callbacks     (aTHXo->interp.Iclone_callbacks)
 #define PL_collation_ix                (aTHXo->interp.Icollation_ix)
 #define PL_collation_name      (aTHXo->interp.Icollation_name)
 #define PL_collation_standard  (aTHXo->interp.Icollation_standard)
@@ -1183,6 +1186,7 @@
 #define PL_Ibufend             PL_bufend
 #define PL_Ibufptr             PL_bufptr
 #define PL_Icheckav            PL_checkav
+#define PL_Iclone_callbacks    PL_clone_callbacks
 #define PL_Icollation_ix       PL_collation_ix
 #define PL_Icollation_name     PL_collation_name
 #define PL_Icollation_standard PL_collation_standard

diff --git a/intrpvar.h b/intrpvar.h
index d2f8e73..f84f384 100644 (file)
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -478,3 +478,8 @@ PERLVAR(Inumeric_radix_sv,  SV *)   /* The radix separator if not '.' */
 /* New variables must be added to the very end for binary compatibility.
  * XSUB.h provides wrapper functions via perlapi.h that make this
  * irrelevant, but not all code may be expected to #include XSUB.h. */
+
+#if defined(USE_ITHREADS)
+PERLVAR(Iclone_callbacks, AV*)  /* used for collecting callbacks during perl_clone*/
+#endif
+

diff --git a/perlapi.h b/perlapi.h
index 7085e74..93f015c 100644 (file)
--- a/perlapi.h
+++ b/perlapi.h
@@ -140,6 +140,8 @@ START_EXTERN_C
 #define PL_bufptr              (*Perl_Ibufptr_ptr(aTHXo))
 #undef  PL_checkav
 #define PL_checkav             (*Perl_Icheckav_ptr(aTHXo))
+#undef  PL_clone_callbacks
+#define PL_clone_callbacks     (*Perl_Iclone_callbacks_ptr(aTHXo))
 #undef  PL_collation_ix
 #define PL_collation_ix                (*Perl_Icollation_ix_ptr(aTHXo))
 #undef  PL_collation_name

diff --git a/sv.c b/sv.c
index f39f305..aeb471d 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -8341,6 +8341,8 @@ Perl_sv_dup(pTHX_ SV *sstr)
        }
        HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
        HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
+    if(HvNAME((HV*)dstr))
+        av_push(PL_clone_callbacks,dstr);
        break;
     case SVt_PVFM:
        SvANY(dstr)     = new_XPVFM();
@@ -8975,6 +8977,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     while (i-- > 0) {
        PL_origargv[i]  = SAVEPV(proto_perl->Iorigargv[i]);
     }
+    PL_clone_callbacks = newAV();   /* Setup array of objects to callbackon */
     PL_envgv           = gv_dup(proto_perl->Ienvgv);
     PL_incgv           = gv_dup(proto_perl->Iincgv);
     PL_hintgv          = gv_dup(proto_perl->Ihintgv);
@@ -9485,6 +9488,24 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
         ptr_table_free(PL_ptr_table);
         PL_ptr_table = NULL;
     }
+    
+    while(av_len(PL_clone_callbacks) != -1) {
+        HV* stash = (HV*) av_shift(PL_clone_callbacks);
+        CV* cloner = (CV*) gv_fetchmethod_autoload(stash,"CLONE",0);
+        if(cloner) {
+            dSP;
+            cloner = GvCV(cloner);
+            ENTER;
+            SAVETMPS;
+            PUSHMARK(SP);
+            XPUSHs(newSVpv(HvNAME(stash),0));
+            PUTBACK;
+            call_sv((SV*)cloner, G_DISCARD);
+            FREETMPS;
+            LEAVE;
+            
+        }
+    }
 
 #ifdef PERL_OBJECT
     return (PerlInterpreter*)pPerl;