From: Artur Bergman 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;hp=5ca37ce9a896d8d8db4aa0d3ecf10ef4edb561a0;p=p5sagit%2Fp5-mst-13.2.git New attempt to clone callack Message-ID: 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;