New attempt to clone callack
authorArtur Bergman <sky@nanisky.com>
Thu, 7 Jun 2001 11:52:16 +0000 (13:52 +0200)
committerJarkko Hietaniemi <jhi@iki.fi>
Sat, 9 Jun 2001 16:11:51 +0000 (16:11 +0000)
Message-ID: <B7451B6F.12B7%artur@contiller.se>

p4raw-id: //depot/perl@10486

embedvar.h
intrpvar.h
perlapi.h
sv.c

index a77a2738a3b3e883a75adf071057afca75c06d8b..42b51e03140d909f4fd4189d5131d6108eabd0cd 100644 (file)
 #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)
 #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)
 #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)
 #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
index d2f8e73c2bd158e4839722355ea2db1aa4ddbc46..f84f3841b4c9985c2cd9e21401397bbdeb4b0680 100644 (file)
@@ -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
+
index 7085e74adcabed53321a43cb605586c89593133b..93f015c628b31ec38d1bfda80c20321a158e3806 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 f39f3058de155af802f5965838dd276fbef89bda..aeb471d1ae009446e336dd8f0f811e0301d26a14 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;