From: Gurusamy Sarathy Date: Mon, 8 Nov 1999 11:25:49 +0000 (+0000) Subject: preliminary support for perl_clone() (still needs work in X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d18c61170a30691556a1da7413e13241a92f4e0a;p=p5sagit%2Fp5-mst-13.2.git preliminary support for perl_clone() (still needs work in the following areas: SVOPs must indirect via pad; context stack, scope stack, and runlevels must be cloned; must hook up the virtualized pseudo-process support provided by "host"; ...) p4raw-id: //depot/perl@4538 --- diff --git a/av.h b/av.h index f537d9e..14e8765 100644 --- a/av.h +++ b/av.h @@ -10,7 +10,7 @@ struct xpvav { char* xav_array; /* pointer to first array element */ SSize_t xav_fill; /* Index of last element present */ - SSize_t xav_max; /* Number of elements for which array has space */ + SSize_t xav_max; /* max index for which array has space */ IV xof_off; /* ptr is incremented by offset */ NV xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* magic for scalar array */ diff --git a/embed.h b/embed.h index 1622da2..781a539 100644 --- a/embed.h +++ b/embed.h @@ -762,6 +762,22 @@ #define newMYSUB Perl_newMYSUB #define my_attrs Perl_my_attrs #define boot_core_xsutils Perl_boot_core_xsutils +#if defined(USE_ITHREADS) +#define he_dup Perl_he_dup +#define re_dup Perl_re_dup +#define fp_dup Perl_fp_dup +#define dirp_dup Perl_dirp_dup +#define gp_dup Perl_gp_dup +#define mg_dup Perl_mg_dup +#define sv_dup Perl_sv_dup +#if defined(HAVE_INTERP_INTERN) +#define sys_intern_dup Perl_sys_intern_dup +#endif +#define sv_table_new Perl_sv_table_new +#define sv_table_fetch Perl_sv_table_fetch +#define sv_table_store Perl_sv_table_store +#define sv_table_split Perl_sv_table_split +#endif #if defined(PERL_OBJECT) #endif #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) @@ -2113,6 +2129,22 @@ #define newMYSUB(a,b,c,d,e) Perl_newMYSUB(aTHX_ a,b,c,d,e) #define my_attrs(a,b) Perl_my_attrs(aTHX_ a,b) #define boot_core_xsutils() Perl_boot_core_xsutils(aTHX) +#if defined(USE_ITHREADS) +#define he_dup(a,b) Perl_he_dup(aTHX_ a,b) +#define re_dup(a) Perl_re_dup(aTHX_ a) +#define fp_dup(a,b) Perl_fp_dup(aTHX_ a,b) +#define dirp_dup(a) Perl_dirp_dup(aTHX_ a) +#define gp_dup(a) Perl_gp_dup(aTHX_ a) +#define mg_dup(a) Perl_mg_dup(aTHX_ a) +#define sv_dup(a) Perl_sv_dup(aTHX_ a) +#if defined(HAVE_INTERP_INTERN) +#define sys_intern_dup(a,b) Perl_sys_intern_dup(aTHX_ a,b) +#endif +#define sv_table_new() Perl_sv_table_new(aTHX) +#define sv_table_fetch(a,b) Perl_sv_table_fetch(aTHX_ a,b) +#define sv_table_store(a,b,c) Perl_sv_table_store(aTHX_ a,b,c) +#define sv_table_split(a) Perl_sv_table_split(aTHX_ a) +#endif #if defined(PERL_OBJECT) #endif #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) @@ -4165,6 +4197,34 @@ #define my_attrs Perl_my_attrs #define Perl_boot_core_xsutils CPerlObj::Perl_boot_core_xsutils #define boot_core_xsutils Perl_boot_core_xsutils +#if defined(USE_ITHREADS) +#define Perl_he_dup CPerlObj::Perl_he_dup +#define he_dup Perl_he_dup +#define Perl_re_dup CPerlObj::Perl_re_dup +#define re_dup Perl_re_dup +#define Perl_fp_dup CPerlObj::Perl_fp_dup +#define fp_dup Perl_fp_dup +#define Perl_dirp_dup CPerlObj::Perl_dirp_dup +#define dirp_dup Perl_dirp_dup +#define Perl_gp_dup CPerlObj::Perl_gp_dup +#define gp_dup Perl_gp_dup +#define Perl_mg_dup CPerlObj::Perl_mg_dup +#define mg_dup Perl_mg_dup +#define Perl_sv_dup CPerlObj::Perl_sv_dup +#define sv_dup Perl_sv_dup +#if defined(HAVE_INTERP_INTERN) +#define Perl_sys_intern_dup CPerlObj::Perl_sys_intern_dup +#define sys_intern_dup Perl_sys_intern_dup +#endif +#define Perl_sv_table_new CPerlObj::Perl_sv_table_new +#define sv_table_new Perl_sv_table_new +#define Perl_sv_table_fetch CPerlObj::Perl_sv_table_fetch +#define sv_table_fetch Perl_sv_table_fetch +#define Perl_sv_table_store CPerlObj::Perl_sv_table_store +#define sv_table_store Perl_sv_table_store +#define Perl_sv_table_split CPerlObj::Perl_sv_table_split +#define sv_table_split Perl_sv_table_split +#endif #if defined(PERL_OBJECT) #endif #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) diff --git a/embed.pl b/embed.pl index 71e9406..514ba82 100755 --- a/embed.pl +++ b/embed.pl @@ -1771,6 +1771,23 @@ p |CV* |newATTRSUB |I32 floor|OP *o|OP *proto|OP *attrs|OP *block p |void |newMYSUB |I32 floor|OP *o|OP *proto|OP *attrs|OP *block p |OP * |my_attrs |OP *o|OP *attrs p |void |boot_core_xsutils +#if defined(USE_ITHREADS) +p |HE* |he_dup |HE* e|bool shared +p |REGEXP*|re_dup |REGEXP* r +p |PerlIO*|fp_dup |PerlIO* fp|char type +p |DIR* |dirp_dup |DIR* dp +p |GP* |gp_dup |GP* gp +p |MAGIC* |mg_dup |MAGIC* mg +p |SV* |sv_dup |SV* sstr +#if defined(HAVE_INTERP_INTERN) +p |void |sys_intern_dup |struct interp_intern* src \ + |struct interp_intern* dst +#endif +p |SVTBL* |sv_table_new +p |SV* |sv_table_fetch |SVTBL *tbl|SV *sv +p |void |sv_table_store |SVTBL *tbl|SV *oldsv|SV *newsv +p |void |sv_table_split |SVTBL *tbl +#endif #if defined(PERL_OBJECT) protected: diff --git a/embedvar.h b/embedvar.h index 556e4d0..566483b 100644 --- a/embedvar.h +++ b/embedvar.h @@ -376,6 +376,7 @@ #define PL_sv_no (PERL_GET_INTERP->Isv_no) #define PL_sv_objcount (PERL_GET_INTERP->Isv_objcount) #define PL_sv_root (PERL_GET_INTERP->Isv_root) +#define PL_sv_table (PERL_GET_INTERP->Isv_table) #define PL_sv_undef (PERL_GET_INTERP->Isv_undef) #define PL_sv_yes (PERL_GET_INTERP->Isv_yes) #define PL_svref_mutex (PERL_GET_INTERP->Isvref_mutex) @@ -636,6 +637,7 @@ #define PL_sv_no (vTHX->Isv_no) #define PL_sv_objcount (vTHX->Isv_objcount) #define PL_sv_root (vTHX->Isv_root) +#define PL_sv_table (vTHX->Isv_table) #define PL_sv_undef (vTHX->Isv_undef) #define PL_sv_yes (vTHX->Isv_yes) #define PL_svref_mutex (vTHX->Isvref_mutex) @@ -898,6 +900,7 @@ #define PL_Isv_no PL_sv_no #define PL_Isv_objcount PL_sv_objcount #define PL_Isv_root PL_sv_root +#define PL_Isv_table PL_sv_table #define PL_Isv_undef PL_sv_undef #define PL_Isv_yes PL_sv_yes #define PL_Isvref_mutex PL_svref_mutex diff --git a/global.sym b/global.sym index 26561d3..add1fe9 100644 --- a/global.sym +++ b/global.sym @@ -674,3 +674,15 @@ Perl_newATTRSUB Perl_newMYSUB Perl_my_attrs Perl_boot_core_xsutils +Perl_he_dup +Perl_re_dup +Perl_fp_dup +Perl_dirp_dup +Perl_gp_dup +Perl_mg_dup +Perl_sv_dup +Perl_sys_intern_dup +Perl_sv_table_new +Perl_sv_table_fetch +Perl_sv_table_store +Perl_sv_table_split diff --git a/hv.c b/hv.c index 857bd70..e38c785 100644 --- a/hv.c +++ b/hv.c @@ -15,15 +15,6 @@ #define PERL_IN_HV_C #include "perl.h" -#if defined(STRANGE_MALLOC) || defined(MYMALLOC) -# define ARRAY_ALLOC_BYTES(size) ( (size)*sizeof(HE*) ) -#else -# define MALLOC_OVERHEAD 16 -# define ARRAY_ALLOC_BYTES(size) ( ((size) < 64) \ - ? (size)*sizeof(HE*) \ - : (size)*sizeof(HE*)*2 - MALLOC_OVERHEAD ) -#endif - STATIC HE* S_new_he(pTHX) { @@ -82,6 +73,27 @@ Perl_unshare_hek(pTHX_ HEK *hek) unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek)); } +#if defined(USE_ITHREADS) +HE * +Perl_he_dup(pTHX_ HE *e, bool shared) +{ + HE *ret; + + if (!e) + return Nullhe; + ret = new_he(); + HeNEXT(ret) = (HE*)NULL; + if (HeKLEN(e) == HEf_SVKEY) + HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e))); + else if (shared) + HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN(e), HeHASH(e)); + else + HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN(e), HeHASH(e)); + HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e))); + return ret; +} +#endif /* USE_ITHREADS */ + /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot * contains an SV* */ @@ -126,7 +138,8 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval) || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) #endif ) - Newz(503,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char); + Newz(503, xhv->xhv_array, + PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char); else return 0; } @@ -214,7 +227,8 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) #endif ) - Newz(503,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char); + Newz(503, xhv->xhv_array, + PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char); else return 0; } @@ -304,7 +318,8 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 has PERL_HASH(hash, key, klen); if (!xhv->xhv_array) - Newz(505, xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char); + Newz(505, xhv->xhv_array, + PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char); oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; i = 1; @@ -385,7 +400,8 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash) PERL_HASH(hash, key, klen); if (!xhv->xhv_array) - Newz(505, xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char); + Newz(505, xhv->xhv_array, + PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char); oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; i = 1; @@ -714,21 +730,21 @@ S_hsplit(pTHX_ HV *hv) PL_nomemok = TRUE; #if defined(STRANGE_MALLOC) || defined(MYMALLOC) - Renew(a, ARRAY_ALLOC_BYTES(newsize), char); + Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); if (!a) { PL_nomemok = FALSE; return; } #else #define MALLOC_OVERHEAD 16 - New(2, a, ARRAY_ALLOC_BYTES(newsize), char); + New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); if (!a) { PL_nomemok = FALSE; return; } Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char); if (oldsize >= 64) { - offer_nice_chunk(xhv->xhv_array, ARRAY_ALLOC_BYTES(oldsize)); + offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize)); } else Safefree(xhv->xhv_array); @@ -789,20 +805,20 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) if (a) { PL_nomemok = TRUE; #if defined(STRANGE_MALLOC) || defined(MYMALLOC) - Renew(a, ARRAY_ALLOC_BYTES(newsize), char); + Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); if (!a) { PL_nomemok = FALSE; return; } #else - New(2, a, ARRAY_ALLOC_BYTES(newsize), char); + New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); if (!a) { PL_nomemok = FALSE; return; } Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char); if (oldsize >= 64) { - offer_nice_chunk(xhv->xhv_array, ARRAY_ALLOC_BYTES(oldsize)); + offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize)); } else Safefree(xhv->xhv_array); @@ -811,7 +827,7 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/ } else { - Newz(0, a, ARRAY_ALLOC_BYTES(newsize), char); + Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); } xhv->xhv_max = --newsize; xhv->xhv_array = a; @@ -1079,7 +1095,8 @@ Perl_hv_iternext(pTHX_ HV *hv) #endif if (!xhv->xhv_array) - Newz(506,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char); + Newz(506, xhv->xhv_array, + PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char); if (entry) entry = HeNEXT(entry); while (!entry) { diff --git a/hv.h b/hv.h index 3977b1c..11a602c 100644 --- a/hv.h +++ b/hv.h @@ -114,3 +114,13 @@ struct xpvhv { #define HEK_HASH(hek) (hek)->hek_hash #define HEK_LEN(hek) (hek)->hek_len #define HEK_KEY(hek) (hek)->hek_key + +#if defined(STRANGE_MALLOC) || defined(MYMALLOC) +# define PERL_HV_ARRAY_ALLOC_BYTES(size) ((size) * sizeof(HE*)) +#else +# define MALLOC_OVERHEAD 16 +# define PERL_HV_ARRAY_ALLOC_BYTES(size) \ + (((size) < 64) \ + ? (size) * sizeof(HE*) \ + : (size) * sizeof(HE*) * 2 - MALLOC_OVERHEAD) +#endif diff --git a/intrpvar.h b/intrpvar.h index 9f6f3b2..0e23905 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -378,3 +378,7 @@ PERLVAR(IDir, struct IPerlDir*) PERLVAR(ISock, struct IPerlSock*) PERLVAR(IProc, struct IPerlProc*) #endif + +#if defined(USE_ITHREADS) +PERLVAR(Isv_table, SVTBL*) +#endif diff --git a/makedef.pl b/makedef.pl index 63a09bd..8ec55bd 100644 --- a/makedef.pl +++ b/makedef.pl @@ -359,6 +359,26 @@ Perl_unlock_condpair Perl_magic_mutexfree )]; } + +unless ($define{'USE_ITHREADS'}) + { + skip_symbols [qw( +PL_sv_table +Perl_dirp_dup +Perl_fp_dup +Perl_gp_dup +Perl_he_dup +Perl_mg_dup +Perl_re_dup +Perl_sv_dup +Perl_sys_intern_dup +Perl_sv_table_fetch +Perl_sv_table_new +Perl_sv_table_split +Perl_sv_table_store +)]; + } + unless ($define{'USE_THREADS'} or $define{'PERL_IMPLICIT_CONTEXT'} or $define{'PERL_OBJECT'}) { diff --git a/objXSUB.h b/objXSUB.h index f7d1fd4..168f547 100644 --- a/objXSUB.h +++ b/objXSUB.h @@ -418,6 +418,8 @@ #define PL_sv_objcount (*Perl_Isv_objcount_ptr(aTHXo)) #undef PL_sv_root #define PL_sv_root (*Perl_Isv_root_ptr(aTHXo)) +#undef PL_sv_table +#define PL_sv_table (*Perl_Isv_table_ptr(aTHXo)) #undef PL_sv_undef #define PL_sv_undef (*Perl_Isv_undef_ptr(aTHXo)) #undef PL_sv_yes @@ -3527,6 +3529,58 @@ #define Perl_boot_core_xsutils pPerl->Perl_boot_core_xsutils #undef boot_core_xsutils #define boot_core_xsutils Perl_boot_core_xsutils +#if defined(USE_ITHREADS) +#undef Perl_he_dup +#define Perl_he_dup pPerl->Perl_he_dup +#undef he_dup +#define he_dup Perl_he_dup +#undef Perl_re_dup +#define Perl_re_dup pPerl->Perl_re_dup +#undef re_dup +#define re_dup Perl_re_dup +#undef Perl_fp_dup +#define Perl_fp_dup pPerl->Perl_fp_dup +#undef fp_dup +#define fp_dup Perl_fp_dup +#undef Perl_dirp_dup +#define Perl_dirp_dup pPerl->Perl_dirp_dup +#undef dirp_dup +#define dirp_dup Perl_dirp_dup +#undef Perl_gp_dup +#define Perl_gp_dup pPerl->Perl_gp_dup +#undef gp_dup +#define gp_dup Perl_gp_dup +#undef Perl_mg_dup +#define Perl_mg_dup pPerl->Perl_mg_dup +#undef mg_dup +#define mg_dup Perl_mg_dup +#undef Perl_sv_dup +#define Perl_sv_dup pPerl->Perl_sv_dup +#undef sv_dup +#define sv_dup Perl_sv_dup +#if defined(HAVE_INTERP_INTERN) +#undef Perl_sys_intern_dup +#define Perl_sys_intern_dup pPerl->Perl_sys_intern_dup +#undef sys_intern_dup +#define sys_intern_dup Perl_sys_intern_dup +#endif +#undef Perl_sv_table_new +#define Perl_sv_table_new pPerl->Perl_sv_table_new +#undef sv_table_new +#define sv_table_new Perl_sv_table_new +#undef Perl_sv_table_fetch +#define Perl_sv_table_fetch pPerl->Perl_sv_table_fetch +#undef sv_table_fetch +#define sv_table_fetch Perl_sv_table_fetch +#undef Perl_sv_table_store +#define Perl_sv_table_store pPerl->Perl_sv_table_store +#undef sv_table_store +#define sv_table_store Perl_sv_table_store +#undef Perl_sv_table_split +#define Perl_sv_table_split pPerl->Perl_sv_table_split +#undef sv_table_split +#define sv_table_split Perl_sv_table_split +#endif #if defined(PERL_OBJECT) #endif #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) diff --git a/perl.h b/perl.h index d30674d..7ec3750 100644 --- a/perl.h +++ b/perl.h @@ -470,7 +470,7 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); # include #endif -#if !defined(PERL_FOR_X2P) && !defined(PERL_OBJECT) +#if !defined(PERL_FOR_X2P) && !defined(WIN32) # include "embed.h" #endif @@ -1326,6 +1326,8 @@ typedef struct xpvfm XPVFM; typedef struct xpvio XPVIO; typedef struct mgvtbl MGVTBL; typedef union any ANY; +typedef struct svtblent SVTBLENT; +typedef struct svtbl SVTBL; #include "handy.h" @@ -1745,6 +1747,18 @@ struct scan_data_t; /* Used in S_* functions in regcomp.c */ typedef I32 CHECKPOINT; +struct svtblent { + struct svtblent* next; + SV* oldval; + SV* newval; +}; + +struct svtbl { + struct svtblent** tbl_ary; + UV tbl_max; + UV tbl_items; +}; + #if defined(iAPX286) || defined(M_I286) || defined(I80286) # define I286 #endif @@ -2658,6 +2672,10 @@ PERLVARA(object_compatibility,30, char) /* this has structure inits, so it cannot be included before here */ # include "opcode.h" +#else +# if defined(WIN32) +# include "embed.h" +# endif #endif /* PERL_OBJECT */ #ifndef PERL_GLOBAL_STRUCT diff --git a/perlapi.c b/perlapi.c index 41dd32a..cdea984 100644 --- a/perlapi.c +++ b/perlapi.c @@ -4848,6 +4848,94 @@ Perl_boot_core_xsutils(pTHXo) { ((CPerlObj*)pPerl)->Perl_boot_core_xsutils(); } +#if defined(USE_ITHREADS) + +#undef Perl_he_dup +HE* +Perl_he_dup(pTHXo_ HE* e, bool shared) +{ + return ((CPerlObj*)pPerl)->Perl_he_dup(e, shared); +} + +#undef Perl_re_dup +REGEXP* +Perl_re_dup(pTHXo_ REGEXP* r) +{ + return ((CPerlObj*)pPerl)->Perl_re_dup(r); +} + +#undef Perl_fp_dup +PerlIO* +Perl_fp_dup(pTHXo_ PerlIO* fp, char type) +{ + return ((CPerlObj*)pPerl)->Perl_fp_dup(fp, type); +} + +#undef Perl_dirp_dup +DIR* +Perl_dirp_dup(pTHXo_ DIR* dp) +{ + return ((CPerlObj*)pPerl)->Perl_dirp_dup(dp); +} + +#undef Perl_gp_dup +GP* +Perl_gp_dup(pTHXo_ GP* gp) +{ + return ((CPerlObj*)pPerl)->Perl_gp_dup(gp); +} + +#undef Perl_mg_dup +MAGIC* +Perl_mg_dup(pTHXo_ MAGIC* mg) +{ + return ((CPerlObj*)pPerl)->Perl_mg_dup(mg); +} + +#undef Perl_sv_dup +SV* +Perl_sv_dup(pTHXo_ SV* sstr) +{ + return ((CPerlObj*)pPerl)->Perl_sv_dup(sstr); +} +#if defined(HAVE_INTERP_INTERN) + +#undef Perl_sys_intern_dup +void +Perl_sys_intern_dup(pTHXo_ struct interp_intern* src, struct interp_intern* dst) +{ + ((CPerlObj*)pPerl)->Perl_sys_intern_dup(src, dst); +} +#endif + +#undef Perl_sv_table_new +SVTBL* +Perl_sv_table_new(pTHXo) +{ + return ((CPerlObj*)pPerl)->Perl_sv_table_new(); +} + +#undef Perl_sv_table_fetch +SV* +Perl_sv_table_fetch(pTHXo_ SVTBL *tbl, SV *sv) +{ + return ((CPerlObj*)pPerl)->Perl_sv_table_fetch(tbl, sv); +} + +#undef Perl_sv_table_store +void +Perl_sv_table_store(pTHXo_ SVTBL *tbl, SV *oldsv, SV *newsv) +{ + ((CPerlObj*)pPerl)->Perl_sv_table_store(tbl, oldsv, newsv); +} + +#undef Perl_sv_table_split +void +Perl_sv_table_split(pTHXo_ SVTBL *tbl) +{ + ((CPerlObj*)pPerl)->Perl_sv_table_split(tbl); +} +#endif #if defined(PERL_OBJECT) #endif #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) diff --git a/proto.h b/proto.h index e62902c..7956898 100644 --- a/proto.h +++ b/proto.h @@ -737,6 +737,22 @@ PERL_CALLCONV CV* Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, PERL_CALLCONV void Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block); PERL_CALLCONV OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs); PERL_CALLCONV void Perl_boot_core_xsutils(pTHX); +#if defined(USE_ITHREADS) +PERL_CALLCONV HE* Perl_he_dup(pTHX_ HE* e, bool shared); +PERL_CALLCONV REGEXP* Perl_re_dup(pTHX_ REGEXP* r); +PERL_CALLCONV PerlIO* Perl_fp_dup(pTHX_ PerlIO* fp, char type); +PERL_CALLCONV DIR* Perl_dirp_dup(pTHX_ DIR* dp); +PERL_CALLCONV GP* Perl_gp_dup(pTHX_ GP* gp); +PERL_CALLCONV MAGIC* Perl_mg_dup(pTHX_ MAGIC* mg); +PERL_CALLCONV SV* Perl_sv_dup(pTHX_ SV* sstr); +#if defined(HAVE_INTERP_INTERN) +PERL_CALLCONV void Perl_sys_intern_dup(pTHX_ struct interp_intern* src, struct interp_intern* dst); +#endif +PERL_CALLCONV SVTBL* Perl_sv_table_new(pTHX); +PERL_CALLCONV SV* Perl_sv_table_fetch(pTHX_ SVTBL *tbl, SV *sv); +PERL_CALLCONV void Perl_sv_table_store(pTHX_ SVTBL *tbl, SV *oldsv, SV *newsv); +PERL_CALLCONV void Perl_sv_table_split(pTHX_ SVTBL *tbl); +#endif #if defined(PERL_OBJECT) protected: #endif diff --git a/sv.c b/sv.c index ccb93f3..324737a 100644 --- a/sv.c +++ b/sv.c @@ -5580,6 +5580,1002 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } +#if defined(USE_ITHREADS) + +#if defined(USE_THREADS) +# include "error: USE_THREADS and USE_ITHREADS are incompatible" +#endif + +#ifndef OpREFCNT_inc +# define OpREFCNT_inc(o) o +#endif + +#define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s)) +#define av_dup(s) (AV*)sv_dup((SV*)s) +#define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s)) +#define hv_dup(s) (HV*)sv_dup((SV*)s) +#define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s)) +#define cv_dup(s) (CV*)sv_dup((SV*)s) +#define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s)) +#define io_dup(s) (IO*)sv_dup((SV*)s) +#define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s)) +#define gv_dup(s) (GV*)sv_dup((SV*)s) +#define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s)) +#define SAVEPV(p) (p ? savepv(p) : Nullch) +#define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch) + +REGEXP * +Perl_re_dup(pTHX_ REGEXP *r) +{ + /* XXX fix when pmop->op_pmregexp becomes shared */ + return ReREFCNT_inc(r); +} + +PerlIO * +Perl_fp_dup(pTHX_ PerlIO *fp, char type) +{ + if (!fp) + return (PerlIO*)NULL; + return fp; /* XXX */ + /* return PerlIO_fdopen(PerlIO_fileno(fp), + type == '<' ? "r" : type == '>' ? "w" : "rw"); */ +} + +DIR * +Perl_dirp_dup(pTHX_ DIR *dp) +{ + if (!dp) + return (DIR*)NULL; + /* XXX TODO */ + return dp; +} + +GP * +Perl_gp_dup(pTHX_ GP *gp) +{ + GP *ret; + if (!gp) + return (GP*)NULL; + Newz(0, ret, 1, GP); + ret->gp_sv = sv_dup_inc(gp->gp_sv); + ret->gp_io = io_dup_inc(gp->gp_io); + ret->gp_form = cv_dup_inc(gp->gp_form); + ret->gp_av = av_dup_inc(gp->gp_av); + ret->gp_hv = hv_dup_inc(gp->gp_hv); + ret->gp_egv = gv_dup_inc(gp->gp_egv); + ret->gp_cv = cv_dup_inc(gp->gp_cv); + ret->gp_cvgen = gp->gp_cvgen; + ret->gp_flags = gp->gp_flags; + ret->gp_line = gp->gp_line; + ret->gp_file = gp->gp_file; /* points to COP.cop_file */ + ret->gp_refcnt = 0; + return ret; +} + +MAGIC * +Perl_mg_dup(pTHX_ MAGIC *mg) +{ + MAGIC *mgret = (MAGIC*)NULL; + MAGIC *mgprev; + if (!mg) + return (MAGIC*)NULL; + for (; mg; mg = mg->mg_moremagic) { + MAGIC *nmg; + Newz(0, nmg, 1, MAGIC); + if (!mgret) + mgret = nmg; + else + mgprev->mg_moremagic = nmg; + nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */ + nmg->mg_private = mg->mg_private; + nmg->mg_type = mg->mg_type; + nmg->mg_flags = mg->mg_flags; + if (mg->mg_type == 'r') { + nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj); + } + else { + nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED) + ? sv_dup_inc(mg->mg_obj) + : sv_dup(mg->mg_obj); + } + nmg->mg_len = mg->mg_len; + nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */ + if (mg->mg_ptr && mg->mg_type != 'g') { + if (mg->mg_len >= 0) + nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len); + else if (mg->mg_len == HEf_SVKEY) + nmg->mg_ptr = (char*)sv_dup((SV*)mg->mg_ptr); + } + mgprev = nmg; + } + return mgret; +} + +SVTBL * +Perl_sv_table_new(pTHX) +{ + SVTBL *tbl; + Newz(0, tbl, 1, SVTBL); + tbl->tbl_max = 511; + tbl->tbl_items = 0; + Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, SVTBLENT*); + return tbl; +} + +SV * +Perl_sv_table_fetch(pTHX_ SVTBL *tbl, SV *sv) +{ + SVTBLENT *tblent; + UV hash = (UV)sv; + assert(tbl); + tblent = tbl->tbl_ary[hash & tbl->tbl_max]; + for (; tblent; tblent = tblent->next) { + if (tblent->oldval == sv) + return tblent->newval; + } + return Nullsv; +} + +void +Perl_sv_table_store(pTHX_ SVTBL *tbl, SV *old, SV *new) +{ + SVTBLENT *tblent, **otblent; + UV hash = (UV)old; + bool i = 1; + assert(tbl); + otblent = &tbl->tbl_ary[hash & tbl->tbl_max]; + for (tblent = *otblent; tblent; i=0, tblent = tblent->next) { + if (tblent->oldval == old) { + tblent->newval = new; + tbl->tbl_items++; + return; + } + } + Newz(0, tblent, 1, SVTBLENT); + tblent->oldval = old; + tblent->newval = new; + tblent->next = *otblent; + *otblent = tblent; + tbl->tbl_items++; + if (i && tbl->tbl_items > tbl->tbl_max) + sv_table_split(tbl); +} + +void +Perl_sv_table_split(pTHX_ SVTBL *tbl) +{ + SVTBLENT **ary = tbl->tbl_ary; + UV oldsize = tbl->tbl_max + 1; + UV newsize = oldsize * 2; + UV i; + + Renew(ary, newsize, SVTBLENT*); + Zero(&ary[oldsize * sizeof(SVTBLENT*)], (newsize-oldsize) * sizeof(SVTBLENT*), char); + tbl->tbl_max = --newsize; + tbl->tbl_ary = ary; + for (i=0; i < oldsize; i++, ary++) { + SVTBLENT **curentp, **entp, *ent; + if (!*ary) + continue; + curentp = ary + oldsize; + for (entp = ary, ent = *ary; ent; ent = *entp) { + if ((newsize & (UV)ent->oldval) != i) { + *entp = ent->next; + ent->next = *curentp; + *curentp = ent; + continue; + } + else + entp = &ent->next; + } + } +} + +SV * +Perl_sv_dup(pTHX_ SV *sstr) +{ + U32 sflags; + int dtype; + int stype; + SV *dstr; + + if (!sstr) + return Nullsv; + /* look for it in the table first */ + dstr = sv_table_fetch(PL_sv_table, sstr); + if (dstr) + return dstr; + + /* XXX TODO: sanity-check sv_dup() vs sv_dup_inc() appropriateness */ + + /* create anew and remember what it is */ + new_SV(dstr); + sv_table_store(PL_sv_table, sstr, dstr); + + /* clone */ + SvFLAGS(dstr) = SvFLAGS(sstr); + SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */ + SvREFCNT(dstr) = 0; + + switch (SvTYPE(sstr)) { + case SVt_NULL: + SvANY(dstr) = NULL; + break; + case SVt_IV: + SvANY(dstr) = new_XIV(); + SvIVX(dstr) = SvIVX(sstr); + break; + case SVt_NV: + SvANY(dstr) = new_XNV(); + SvNVX(dstr) = SvNVX(sstr); + break; + case SVt_RV: + SvANY(dstr) = new_XRV(); + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + break; + case SVt_PV: + SvANY(dstr) = new_XPV(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + if (SvPOKp(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + break; + case SVt_PVIV: + SvANY(dstr) = new_XPVIV(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + if (SvPOKp(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + break; + case SVt_PVNV: + SvANY(dstr) = new_XPVNV(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + if (SvPOKp(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + break; + case SVt_PVMG: + SvANY(dstr) = new_XPVMG(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); + if (SvSMAGICAL(sstr) && mg_find(sstr, 'l')) + SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */ + else + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvPOKp(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + break; + case SVt_PVBM: + SvANY(dstr) = new_XPVBM(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); + if (SvSMAGICAL(sstr) && mg_find(sstr, 'l')) + SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */ + else + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvPOKp(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + BmRARE(dstr) = BmRARE(sstr); + BmUSEFUL(dstr) = BmUSEFUL(sstr); + BmPREVIOUS(dstr)= BmPREVIOUS(sstr); + break; + case SVt_PVLV: + SvANY(dstr) = new_XPVLV(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); + if (SvSMAGICAL(sstr) && mg_find(sstr, 'l')) + SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */ + else + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvPOKp(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */ + LvTARGLEN(dstr) = LvTARGLEN(sstr); + LvTARG(dstr) = sv_dup_inc(LvTARG(sstr)); + LvTYPE(dstr) = LvTYPE(sstr); + break; + case SVt_PVGV: + SvANY(dstr) = new_XPVGV(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); + if (SvSMAGICAL(sstr) && mg_find(sstr, 'l')) + SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */ + else + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvPOKp(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + GvNAMELEN(dstr) = GvNAMELEN(sstr); + GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr)); + GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr)); + GvFLAGS(dstr) = GvFLAGS(sstr); + GvGP(dstr) = gp_dup(GvGP(sstr)); + GvGP(dstr)->gp_refcnt++; + break; + case SVt_PVIO: + SvANY(dstr) = new_XPVIO(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); + if (SvSMAGICAL(sstr) && mg_find(sstr, 'l')) + SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */ + else + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvPOKp(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr)); + if (IoOFP(sstr) == IoIFP(sstr)) + IoOFP(dstr) = IoIFP(dstr); + else + IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr)); + /* XXX PL_rsfp_filters entries have fake IoDIRP() */ + IoDIRP(dstr) = dirp_dup(IoDIRP(sstr)); + IoLINES(dstr) = IoLINES(sstr); + IoPAGE(dstr) = IoPAGE(sstr); + IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr); + IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr); + IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr)); + IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr)); + IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr)); + IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr)); + IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr)); + IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr)); + IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr); + IoTYPE(dstr) = IoTYPE(sstr); + IoFLAGS(dstr) = IoFLAGS(sstr); + break; + case SVt_PVAV: + SvANY(dstr) = new_XPVAV(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr)); + AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr); + if (AvALLOC((AV*)sstr)) { + SV **dst_ary, **src_ary; + SSize_t items = AvFILLp((AV*)sstr) + 1; + + src_ary = AvALLOC((AV*)sstr); + Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*); + SvPVX(dstr) = (char*)dst_ary; + AvALLOC((AV*)dstr) = dst_ary; + if (AvREAL((AV*)sstr)) { + while (items-- > 0) + *dst_ary++ = sv_dup_inc(*src_ary++); + } + else { + while (items-- > 0) + *dst_ary++ = sv_dup(*src_ary++); + } + items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr); + while (items-- > 0) { + *dst_ary++ = &PL_sv_undef; + } + } + else { + SvPVX(dstr) = Nullch; + AvALLOC((AV*)dstr) = (SV**)NULL; + } + break; + case SVt_PVHV: + SvANY(dstr) = new_XPVHV(); + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + HvRITER((HV*)dstr) = HvRITER((HV*)sstr); + if (HvARRAY((HV*)sstr)) { + HE *entry; + STRLEN i = 0; + XPVHV *dxhv = (XPVHV*)SvANY(dstr); + XPVHV *sxhv = (XPVHV*)SvANY(sstr); + Newz(0, dxhv->xhv_array, + PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char); + while (i <= sxhv->xhv_max) { + HE *dentry, *oentry; + entry = ((HE**)sxhv->xhv_array)[i]; + dentry = he_dup(entry, !!HvSHAREKEYS(sstr)); + ((HE**)dxhv->xhv_array)[i] = dentry; + while (entry) { + entry = HeNEXT(entry); + oentry = dentry; + dentry = he_dup(entry, !!HvSHAREKEYS(sstr)); + HeNEXT(oentry) = dentry; + } + ++i; + } + if (sxhv->xhv_riter >= 0 && sxhv->xhv_eiter) { + entry = ((HE**)sxhv->xhv_array)[sxhv->xhv_riter]; + while (entry && entry != sxhv->xhv_eiter) + entry = HeNEXT(entry); + dxhv->xhv_eiter = entry; + } + else + dxhv->xhv_eiter = (HE*)NULL; + } + else + SvPVX(dstr) = Nullch; + HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */ + HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr)); + break; + case SVt_PVFM: + SvANY(dstr) = new_XPVFM(); + goto dup_pvcv; + /* NOTREACHED */ + case SVt_PVCV: + SvANY(dstr) = new_XPVCV(); +dup_pvcv: + SvCUR(dstr) = SvCUR(sstr); + SvLEN(dstr) = SvLEN(sstr); + SvIVX(dstr) = SvIVX(sstr); + SvNVX(dstr) = SvNVX(sstr); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); + if (SvSMAGICAL(sstr) && mg_find(sstr, 'l')) + SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */ + else + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvPOKp(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + else + SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */ + CvSTART(dstr) = CvSTART(sstr); + CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr)); + CvXSUB(dstr) = CvXSUB(sstr); + CvXSUBANY(dstr) = CvXSUBANY(sstr); + CvGV(dstr) = gv_dup_inc(CvGV(sstr)); + CvDEPTH(dstr) = CvDEPTH(sstr); + CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr)); + CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr)); + CvFLAGS(dstr) = CvFLAGS(sstr); + break; + default: + Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr)); + break; + } + + if (SvOBJECT(dstr)) + ++PL_sv_objcount; + + return dstr; +} + +PerlInterpreter * +perl_clone_using(PerlInterpreter *proto_perl, IV flags, + struct IPerlMem* ipM, struct IPerlEnv* ipE, + struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, + struct IPerlDir* ipD, struct IPerlSock* ipS, + struct IPerlProc* ipP) +{ + IV i; + SV *sv; + SV **svp; + PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); + PERL_SET_INTERP(my_perl); + +#ifdef DEBUGGING + memset(my_perl, 0xab, sizeof(PerlInterpreter)); + PL_markstack = 0; + PL_scopestack = 0; + PL_savestack = 0; + PL_retstack = 0; +#else +# if 0 + Copy(proto_perl, my_perl, 1, PerlInterpreter); +# endif +#endif + + /* XXX many of the string copies here can be optimized if they're + * constants; they need to be allocated as common memory and just + * their pointers copied. */ + + /* host pointers */ + PL_Mem = ipM; + PL_Env = ipE; + PL_StdIO = ipStd; + PL_LIO = ipLIO; + PL_Dir = ipD; + PL_Sock = ipS; + PL_Proc = ipP; + + /* arena roots */ + PL_xiv_arenaroot = NULL; + PL_xiv_root = NULL; + PL_xnv_root = NULL; + PL_xrv_root = NULL; + PL_xpv_root = NULL; + PL_xpviv_root = NULL; + PL_xpvnv_root = NULL; + PL_xpvcv_root = NULL; + PL_xpvav_root = NULL; + PL_xpvhv_root = NULL; + PL_xpvmg_root = NULL; + PL_xpvlv_root = NULL; + PL_xpvbm_root = NULL; + PL_he_root = NULL; + PL_nice_chunk = NULL; + PL_nice_chunk_size = 0; + PL_sv_count = 0; + PL_sv_objcount = 0; + PL_sv_root = Nullsv; + PL_sv_arenaroot = Nullsv; + + PL_debug = proto_perl->Idebug; + + /* create SV map for pointer relocation */ + PL_sv_table = sv_table_new(); + + /* initialize these special pointers as early as possible */ + SvANY(&PL_sv_undef) = NULL; + SvREFCNT(&PL_sv_undef) = (~(U32)0)/2; + SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; + sv_table_store(PL_sv_table, &proto_perl->Isv_undef, &PL_sv_undef); + + SvANY(&PL_sv_no) = new_XPVNV(); + SvREFCNT(&PL_sv_no) = (~(U32)0)/2; + SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; + SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0); + SvCUR(&PL_sv_no) = 0; + SvLEN(&PL_sv_no) = 1; + SvNVX(&PL_sv_no) = 0; + sv_table_store(PL_sv_table, &proto_perl->Isv_no, &PL_sv_no); + + SvANY(&PL_sv_yes) = new_XPVNV(); + SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; + SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; + SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1); + SvCUR(&PL_sv_yes) = 1; + SvLEN(&PL_sv_yes) = 2; + SvNVX(&PL_sv_yes) = 1; + sv_table_store(PL_sv_table, &proto_perl->Isv_yes, &PL_sv_yes); + + /* create shared string table */ + PL_strtab = newHV(); + HvSHAREKEYS_off(PL_strtab); + hv_ksplit(PL_strtab, 512); + sv_table_store(PL_sv_table, (SV*)proto_perl->Istrtab, (SV*)PL_strtab); + + PL_compiling = proto_perl->Icompiling; + PL_compiling.cop_stash = hv_dup(PL_compiling.cop_stash); + PL_compiling.cop_filegv = gv_dup(PL_compiling.cop_filegv); + PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings); + if (proto_perl->Tcurcop == &proto_perl->Icompiling) + PL_curcop = &PL_compiling; + else + PL_curcop = proto_perl->Tcurcop; + + /* pseudo environmental stuff */ + PL_origargc = proto_perl->Iorigargc; + i = PL_origargc; + New(0, PL_origargv, i+1, char*); + PL_origargv[i] = '\0'; + while (i-- > 0) { + PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]); + } + PL_envgv = gv_dup(proto_perl->Ienvgv); + PL_incgv = gv_dup(proto_perl->Iincgv); + PL_hintgv = gv_dup(proto_perl->Ihintgv); + PL_origfilename = SAVEPV(proto_perl->Iorigfilename); + PL_diehook = sv_dup_inc(proto_perl->Idiehook); + PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook); + + /* switches */ + PL_minus_c = proto_perl->Iminus_c; + Copy(proto_perl->Ipatchlevel, PL_patchlevel, 10, char); + PL_localpatches = proto_perl->Ilocalpatches; + PL_splitstr = proto_perl->Isplitstr; + PL_preprocess = proto_perl->Ipreprocess; + PL_minus_n = proto_perl->Iminus_n; + PL_minus_p = proto_perl->Iminus_p; + PL_minus_l = proto_perl->Iminus_l; + PL_minus_a = proto_perl->Iminus_a; + PL_minus_F = proto_perl->Iminus_F; + PL_doswitches = proto_perl->Idoswitches; + PL_dowarn = proto_perl->Idowarn; + PL_doextract = proto_perl->Idoextract; + PL_sawampersand = proto_perl->Isawampersand; + PL_unsafe = proto_perl->Iunsafe; + PL_inplace = SAVEPV(proto_perl->Iinplace); + PL_e_script = sv_dup_inc(proto_perl->Ie_script); + PL_perldb = proto_perl->Iperldb; + PL_perl_destruct_level = proto_perl->Iperl_destruct_level; + + /* magical thingies */ + /* XXX time(&PL_basetime) instead? */ + PL_basetime = proto_perl->Ibasetime; + PL_formfeed = sv_dup(proto_perl->Iformfeed); + + PL_maxsysfd = proto_perl->Imaxsysfd; + PL_multiline = proto_perl->Imultiline; + PL_statusvalue = proto_perl->Istatusvalue; +#ifdef VMS + PL_statusvalue_vms = proto_perl->Istatusvalue_vms; +#endif + + /* shortcuts to various I/O objects */ + PL_stdingv = gv_dup(proto_perl->Istdingv); + PL_stderrgv = gv_dup(proto_perl->Istderrgv); + PL_defgv = gv_dup(proto_perl->Idefgv); + PL_argvgv = gv_dup(proto_perl->Iargvgv); + PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv); + PL_argvout_stack = av_dup(proto_perl->Iargvout_stack); + + /* shortcuts to regexp stuff */ + PL_replgv = gv_dup(proto_perl->Ireplgv); + + /* shortcuts to misc objects */ + PL_errgv = gv_dup(proto_perl->Ierrgv); + + /* shortcuts to debugging objects */ + PL_DBgv = gv_dup(proto_perl->IDBgv); + PL_DBline = gv_dup(proto_perl->IDBline); + PL_DBsub = gv_dup(proto_perl->IDBsub); + PL_DBsingle = sv_dup(proto_perl->IDBsingle); + PL_DBtrace = sv_dup(proto_perl->IDBtrace); + PL_DBsignal = sv_dup(proto_perl->IDBsignal); + PL_lineary = av_dup(proto_perl->Ilineary); + PL_dbargs = av_dup(proto_perl->Idbargs); + + /* symbol tables */ + PL_defstash = hv_dup_inc(proto_perl->Tdefstash); + PL_curstash = hv_dup(proto_perl->Tcurstash); + PL_debstash = hv_dup(proto_perl->Idebstash); + PL_globalstash = hv_dup(proto_perl->Iglobalstash); + PL_curstname = sv_dup_inc(proto_perl->Icurstname); + + PL_beginav = av_dup_inc(proto_perl->Ibeginav); + PL_endav = av_dup_inc(proto_perl->Iendav); + PL_stopav = av_dup_inc(proto_perl->Istopav); + PL_initav = av_dup_inc(proto_perl->Iinitav); + + PL_sub_generation = proto_perl->Isub_generation; + + /* funky return mechanisms */ + PL_forkprocess = proto_perl->Iforkprocess; + + /* subprocess state */ + PL_fdpid = av_dup(proto_perl->Ifdpid); + + /* internal state */ + PL_tainting = proto_perl->Itainting; + PL_maxo = proto_perl->Imaxo; + if (proto_perl->Iop_mask) + PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo); + else + PL_op_mask = Nullch; + + /* current interpreter roots */ + PL_main_cv = cv_dup_inc(proto_perl->Imain_cv); + PL_main_root = OpREFCNT_inc(proto_perl->Imain_root); + PL_main_start = proto_perl->Imain_start; + PL_eval_root = proto_perl->Ieval_root; + PL_eval_start = proto_perl->Ieval_start; + + /* runtime control stuff */ + PL_curcopdb = proto_perl->Icurcopdb; + PL_copline = proto_perl->Icopline; + + PL_filemode = proto_perl->Ifilemode; + PL_lastfd = proto_perl->Ilastfd; + PL_oldname = proto_perl->Ioldname; /* XXX */ + PL_Argv = NULL; + PL_Cmd = Nullch; + PL_gensym = proto_perl->Igensym; + PL_preambled = proto_perl->Ipreambled; + PL_preambleav = av_dup_inc(proto_perl->Ipreambleav); + PL_laststatval = proto_perl->Ilaststatval; + PL_laststype = proto_perl->Ilaststype; + PL_mess_sv = Nullsv; + + PL_orslen = proto_perl->Iorslen; + PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen); + PL_ofmt = SAVEPV(proto_perl->Iofmt); + + /* interpreter atexit processing */ + PL_exitlistlen = proto_perl->Iexitlistlen; + if (PL_exitlistlen) { + New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry); + Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry); + } + else + PL_exitlist = (PerlExitListEntry*)NULL; + PL_modglobal = hv_dup(proto_perl->Imodglobal); + + PL_profiledata = NULL; /* XXX */ + PL_rsfp = fp_dup(proto_perl->Irsfp, '<'); + /* XXX PL_rsfp_filters entries have fake IoDIRP() */ + PL_rsfp_filters = av_dup(proto_perl->Irsfp_filters); + + PL_compcv = cv_dup(proto_perl->Icompcv); + PL_comppad = av_dup(proto_perl->Icomppad); + PL_comppad_name = av_dup(proto_perl->Icomppad_name); + PL_comppad_name_fill = proto_perl->Icomppad_name_fill; + PL_comppad_name_floor = proto_perl->Icomppad_name_floor; + PL_curpad = AvARRAY(PL_comppad); /* XXX */ + +#ifdef HAVE_INTERP_INTERN + sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); +#endif + + /* more statics moved here */ + PL_generation = proto_perl->Igeneration; + PL_DBcv = cv_dup(proto_perl->IDBcv); + PL_archpat_auto = SAVEPV(proto_perl->Iarchpat_auto); + + PL_in_clean_objs = proto_perl->Iin_clean_objs; + PL_in_clean_all = proto_perl->Iin_clean_all; + + PL_uid = proto_perl->Iuid; + PL_euid = proto_perl->Ieuid; + PL_gid = proto_perl->Igid; + PL_egid = proto_perl->Iegid; + PL_nomemok = proto_perl->Inomemok; + PL_an = proto_perl->Ian; + PL_cop_seqmax = proto_perl->Icop_seqmax; + PL_op_seqmax = proto_perl->Iop_seqmax; + PL_evalseq = proto_perl->Ievalseq; + PL_origenviron = proto_perl->Iorigenviron; /* XXX */ + PL_origalen = proto_perl->Iorigalen; + PL_pidstatus = newHV(); + PL_osname = SAVEPV(proto_perl->Iosname); + PL_sh_path = SAVEPV(proto_perl->Ish_path); + PL_sighandlerp = proto_perl->Isighandlerp; + + + PL_runops = proto_perl->Irunops; + + Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); /* XXX */ + +#ifdef CSH + PL_cshlen = proto_perl->Icshlen; + PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen); +#endif + + PL_lex_state = proto_perl->Ilex_state; + PL_lex_defer = proto_perl->Ilex_defer; + PL_lex_expect = proto_perl->Ilex_expect; + PL_lex_formbrack = proto_perl->Ilex_formbrack; + PL_lex_fakebrack = proto_perl->Ilex_fakebrack; + PL_lex_dojoin = proto_perl->Ilex_dojoin; + PL_lex_starts = proto_perl->Ilex_starts; + PL_lex_stuff = Nullsv; /* XXX */ + PL_lex_repl = Nullsv; /* XXX */ + PL_lex_op = proto_perl->Ilex_op; + PL_lex_inpat = proto_perl->Ilex_inpat; + PL_lex_inwhat = proto_perl->Ilex_inwhat; + PL_lex_brackets = proto_perl->Ilex_brackets; + i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets); + PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i); + PL_lex_casemods = proto_perl->Ilex_casemods; + i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods); + PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i); + + Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE); + Copy(proto_perl->Inexttype, PL_nexttype, 5, I32); + PL_nexttoke = proto_perl->Inexttoke; + + PL_linestr = sv_dup_inc(proto_perl->Ilinestr); + i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr); + PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr); + PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr); + PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr); + PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + PL_pending_ident = proto_perl->Ipending_ident; + PL_sublex_info = proto_perl->Isublex_info; /* XXX */ + + PL_expect = proto_perl->Iexpect; + + PL_multi_start = proto_perl->Imulti_start; + PL_multi_end = proto_perl->Imulti_end; + PL_multi_open = proto_perl->Imulti_open; + PL_multi_close = proto_perl->Imulti_close; + + PL_error_count = proto_perl->Ierror_count; + PL_subline = proto_perl->Isubline; + PL_subname = sv_dup_inc(proto_perl->Isubname); + + PL_min_intro_pending = proto_perl->Imin_intro_pending; + PL_max_intro_pending = proto_perl->Imax_intro_pending; + PL_padix = proto_perl->Ipadix; + PL_padix_floor = proto_perl->Ipadix_floor; + PL_pad_reset_pending = proto_perl->Ipad_reset_pending; + + i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr); + PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr); + PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + PL_last_lop_op = proto_perl->Ilast_lop_op; + PL_in_my = proto_perl->Iin_my; + PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash); +#ifdef FCRYPT + PL_cryptseen = proto_perl->Icryptseen; +#endif + + PL_hints = proto_perl->Ihints; + + PL_amagic_generation = proto_perl->Iamagic_generation; + +#ifdef USE_LOCALE_COLLATE + PL_collation_ix = proto_perl->Icollation_ix; + PL_collation_name = SAVEPV(proto_perl->Icollation_name); + PL_collation_standard = proto_perl->Icollation_standard; + PL_collxfrm_base = proto_perl->Icollxfrm_base; + PL_collxfrm_mult = proto_perl->Icollxfrm_mult; +#endif /* USE_LOCALE_COLLATE */ + +#ifdef USE_LOCALE_NUMERIC + PL_numeric_name = SAVEPV(proto_perl->Inumeric_name); + PL_numeric_standard = proto_perl->Inumeric_standard; + PL_numeric_local = proto_perl->Inumeric_local; + PL_numeric_radix = proto_perl->Inumeric_radix; +#endif /* !USE_LOCALE_NUMERIC */ + + /* utf8 character classes */ + PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum); + PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc); + PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii); + PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha); + PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space); + PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl); + PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph); + PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit); + PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper); + PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower); + PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print); + PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct); + PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit); + PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark); + PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper); + PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle); + PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower); + + /* swatch cache */ + PL_last_swash_hv = Nullhv; /* XXX recreate swatch cache? */ + PL_last_swash_klen = 0; + PL_last_swash_key[0]= '\0'; + PL_last_swash_tmps = Nullch; + PL_last_swash_slen = 0; + + /* perly.c globals */ + PL_yydebug = proto_perl->Iyydebug; + PL_yynerrs = proto_perl->Iyynerrs; + PL_yyerrflag = proto_perl->Iyyerrflag; + PL_yychar = proto_perl->Iyychar; + PL_yyval = proto_perl->Iyyval; + PL_yylval = proto_perl->Iyylval; + + PL_glob_index = proto_perl->Iglob_index; + PL_srand_called = proto_perl->Isrand_called; + PL_uudmap['M'] = 0; /* reinit on demand */ + PL_bitcount = Nullch; /* reinit on demand */ + + + /* thrdvar.h stuff */ + +/* PL_curstackinfo = clone_stackinfo(proto_perl->Tcurstackinfo); + clone_stacks(); + PL_mainstack = av_dup(proto_perl->Tmainstack); + PL_curstack = av_dup(proto_perl->Tcurstack);*/ /* XXXXXX */ + init_stacks(); + + PL_op = proto_perl->Top; + PL_statbuf = proto_perl->Tstatbuf; + PL_statcache = proto_perl->Tstatcache; + PL_statgv = gv_dup(proto_perl->Tstatgv); + PL_statname = sv_dup(proto_perl->Tstatname); +#ifdef HAS_TIMES + PL_timesbuf = proto_perl->Ttimesbuf; +#endif + + PL_tainted = proto_perl->Ttainted; + PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */ + PL_nrs = sv_dup_inc(proto_perl->Tnrs); + PL_rs = sv_dup_inc(proto_perl->Trs); + PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv); + PL_ofslen = proto_perl->Tofslen; + PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen); + PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv); + PL_chopset = proto_perl->Tchopset; + PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget); + PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget); + PL_formtarget = sv_dup(proto_perl->Tformtarget); + + PL_restartop = proto_perl->Trestartop; + PL_in_eval = proto_perl->Tin_eval; + PL_delaymagic = proto_perl->Tdelaymagic; + PL_dirty = proto_perl->Tdirty; + PL_localizing = proto_perl->Tlocalizing; + + PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ + PL_top_env = &PL_start_env; + PL_protect = proto_perl->Tprotect; + PL_errors = sv_dup_inc(proto_perl->Terrors); + PL_av_fetch_sv = Nullsv; + PL_hv_fetch_sv = Nullsv; + Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */ + PL_modcount = proto_perl->Tmodcount; + PL_lastgotoprobe = Nullop; + PL_dumpindent = proto_perl->Tdumpindent; + PL_sortstash = hv_dup(proto_perl->Tsortstash); + PL_firstgv = gv_dup(proto_perl->Tfirstgv); + PL_secondgv = gv_dup(proto_perl->Tsecondgv); + PL_sortcxix = proto_perl->Tsortcxix; + PL_efloatbuf = Nullch; + PL_efloatsize = 0; + + PL_screamfirst = NULL; + PL_screamnext = NULL; + PL_maxscream = -1; + PL_lastscream = Nullsv; + + /* RE engine - function pointers */ + PL_regcompp = proto_perl->Tregcompp; + PL_regexecp = proto_perl->Tregexecp; + PL_regint_start = proto_perl->Tregint_start; + PL_regint_string = proto_perl->Tregint_string; + PL_regfree = proto_perl->Tregfree; + + PL_regindent = 0; + PL_reginterp_cnt = 0; + PL_reg_start_tmp = 0; + PL_reg_start_tmpl = 0; + PL_reg_poscache = Nullch; + + PL_watchaddr = NULL; + PL_watchok = Nullch; + + return my_perl; +} + +PerlInterpreter * +perl_clone(pTHXx_ IV flags) +{ + return perl_clone_using(aTHXx_ flags, PL_Mem, PL_Env, PL_StdIO, PL_LIO, + PL_Dir, PL_Sock, PL_Proc); +} + +#endif /* USE_ITHREADS */ #ifdef PERL_OBJECT #include "XSUB.h" diff --git a/win32/perllib.c b/win32/perllib.c index e8d59cd..0480ae3 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -1556,7 +1556,15 @@ RunPerl(int argc, char **argv, char **env) exitstatus = perl_parse(my_perl, xs_init, argc, argv, env); if (!exitstatus) { +#ifdef USE_ITHREADS /* XXXXXX testing */ +extern PerlInterpreter * perl_clone(pTHXx_ IV flags); + + PerlInterpreter *new_perl = perl_clone(my_perl, 0); + exitstatus = perl_run( new_perl ); + /* perl_destruct(new_perl); perl_free(new_perl); */ +#else exitstatus = perl_run( my_perl ); +#endif } perl_destruct( my_perl ); diff --git a/win32/win32.c b/win32/win32.c index cf341cd..d3a7b40 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -3331,6 +3331,21 @@ Perl_win32_init(int *argcp, char ***argvp) MALLOC_INIT; } +#ifdef USE_ITHREADS +void +Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst) +{ + dst->perlshell_tokens = Nullch; + dst->perlshell_vec = (char**)NULL; + dst->perlshell_items = 0; + dst->fdpid = newAV(); + New(1313, dst->children, 1, child_tab); + dst->children->num = 0; + dst->hostlist = src->hostlist; /* XXX */ + dst->thr_intern.Winit_socktype = src->thr_intern.Winit_socktype; +} +#endif + #ifdef USE_BINMODE_SCRIPTS void @@ -3355,4 +3370,3 @@ win32_strip_return(SV *sv) } #endif -