From: Artur Bergman <sky@nanisky.com>
Date: Thu, 7 Jun 2001 11:52:16 +0000 (+0200)
Subject: New attempt to clone callack
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4a09accc6c4d5aaf9842ce7a2c4ad0d7c9824951;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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
--- 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
--- 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;