X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8a12f161a3a8b8cc9c866a9f342b9476fb0b9b95..94f23f413fc20beae3970bde041120ceeceae8e4:/sv.c?ds=sidebyside diff --git a/sv.c b/sv.c index 9a4fb96..010ce2e 100644 --- a/sv.c +++ b/sv.c @@ -316,6 +316,16 @@ Perl_sv_free_arenas(pTHX) PL_sv_root = 0; } +void +Perl_report_uninit(pTHX) +{ + if (PL_op) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, + " in ", PL_op_desc[PL_op->op_type]); + else + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", ""); +} + STATIC XPVIV* S_new_xiv(pTHX) { @@ -1427,7 +1437,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } return 0; } @@ -1442,7 +1452,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) if (SvREADONLY(sv) && !SvOK(sv)) { dTHR; if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); return 0; } } @@ -1538,7 +1548,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) else { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); if (SvTYPE(sv) < SVt_IV) /* Typically the caller expects that sv_any is not NULL now. */ sv_upgrade(sv, SVt_IV); @@ -1566,7 +1576,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } return 0; } @@ -1581,7 +1591,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (SvREADONLY(sv) && !SvOK(sv)) { dTHR; if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); return 0; } } @@ -1695,7 +1705,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } if (SvTYPE(sv) < SVt_IV) /* Typically the caller expects that sv_any is not NULL now. */ @@ -1704,7 +1714,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n", - (UV)sv,SvUVX(sv))); + PTR2UV(sv),SvUVX(sv))); return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); } @@ -1733,7 +1743,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } return 0; } @@ -1748,7 +1758,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvREADONLY(sv) && !SvOK(sv)) { dTHR; if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); return 0.0; } } @@ -1790,7 +1800,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) else { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); if (SvTYPE(sv) < SVt_NV) /* Typically the caller expects that sv_any is not NULL now. */ sv_upgrade(sv, SVt_NV); @@ -2035,7 +2045,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } *lp = 0; return ""; @@ -2129,7 +2139,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) if (SvREADONLY(sv) && !SvOK(sv)) { dTHR; if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); *lp = 0; return ""; } @@ -2193,7 +2203,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) { - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } *lp = 0; if (SvTYPE(sv) < SVt_PV) @@ -2248,6 +2258,30 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) } } +char * +Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv) +{ + return sv_2pv_nolen(sv); +} + +char * +Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) +{ + return sv_2pv(sv,lp); +} + +char * +Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv) +{ + return sv_2pv_nolen(sv); +} + +char * +Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) +{ + return sv_2pv(sv,lp); +} + /* This function is only called on magical items */ bool Perl_sv_2bool(pTHX_ register SV *sv) @@ -2370,7 +2404,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) sstr = SvRV(sstr); if (sstr == dstr) { if (GvIMPORTED(dstr) != GVf_IMPORTED - && CopSTASH(PL_curcop) != GvSTASH(dstr)) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvIMPORTED_on(dstr); } @@ -2428,7 +2462,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) GvGP(dstr) = gp_ref(GvGP(sstr)); SvTAINT(dstr); if (GvIMPORTED(dstr) != GVf_IMPORTED - && CopSTASH(PL_curcop) != GvSTASH(dstr)) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvIMPORTED_on(dstr); } @@ -2463,7 +2497,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) if (intro) { GP *gp; - GvGP(dstr)->gp_refcnt--; + gp_free((GV*)dstr); GvINTRO_off(dstr); /* one-shot flag */ Newz(602,gp, 1, GP); GvGP(dstr) = gp_ref(gp); @@ -2480,7 +2514,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) dref = (SV*)GvAV(dstr); GvAV(dstr) = (AV*)sref; if (GvIMPORTED_AV_off(dstr) - && CopSTASH(PL_curcop) != GvSTASH(dstr)) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvIMPORTED_AV_on(dstr); } @@ -2492,7 +2526,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) dref = (SV*)GvHV(dstr); GvHV(dstr) = (HV*)sref; if (GvIMPORTED_HV_off(dstr) - && CopSTASH(PL_curcop) != GvSTASH(dstr)) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvIMPORTED_HV_on(dstr); } @@ -2548,7 +2582,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) PL_sub_generation++; } if (GvIMPORTED_CV_off(dstr) - && CopSTASH(PL_curcop) != GvSTASH(dstr)) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvIMPORTED_CV_on(dstr); } @@ -2567,7 +2601,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) dref = (SV*)GvSV(dstr); GvSV(dstr) = sref; if (GvIMPORTED_SV_off(dstr) - && CopSTASH(PL_curcop) != GvSTASH(dstr)) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvIMPORTED_SV_on(dstr); } @@ -2645,6 +2679,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) *SvEND(dstr) = '\0'; (void)SvPOK_only(dstr); } + if (SvUTF8(sstr)) + SvUTF8_on(dstr); /*SUPPRESS 560*/ if (sflags & SVp_NOK) { SvNOK_on(dstr); @@ -3174,6 +3210,7 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN SvCUR_set(bigstr, offset+len); } + SvTAINT(bigstr); i = littlelen - len; if (i > 0) { /* string might grow */ big = SvGROW(bigstr, SvCUR(bigstr) + i + 1); @@ -4022,10 +4059,6 @@ screamer2: } } -#ifdef WIN32 - win32_strip_return(sv); -#endif - return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } @@ -4549,8 +4582,7 @@ Perl_sv_true(pTHX_ register SV *sv) if (SvPOK(sv)) { register XPV* tXpv; if ((tXpv = (XPV*)SvANY(sv)) && - (*tXpv->xpv_pv > '0' || - tXpv->xpv_cur > 1 || + (tXpv->xpv_cur > 1 || (tXpv->xpv_cur && *tXpv->xpv_pv != '0'))) return 1; else @@ -4660,6 +4692,42 @@ Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) } char * +Perl_sv_pvbyte(pTHX_ SV *sv) +{ + return sv_pv(sv); +} + +char * +Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp) +{ + return sv_pvn(sv,lp); +} + +char * +Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) +{ + return sv_pvn_force(sv,lp); +} + +char * +Perl_sv_pvutf8(pTHX_ SV *sv) +{ + return sv_pv(sv); +} + +char * +Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp) +{ + return sv_pvn(sv,lp); +} + +char * +Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp) +{ + return sv_pvn_force(sv,lp); +} + +char * Perl_sv_reftype(pTHX_ SV *sv, int ob) { if (ob && SvOBJECT(sv)) @@ -5163,7 +5231,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* SIZE */ switch (*q) { -#ifdef Quad_t +#ifdef HAS_QUAD case 'L': /* Ld */ case 'q': /* qd */ intsize = 'q'; @@ -5171,7 +5239,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV break; #endif case 'l': -#ifdef Quad_t +#ifdef HAS_QUAD if (*(q + 1) == 'l') { /* lld */ intsize = 'q'; q += 2; @@ -5287,7 +5355,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV default: iv = va_arg(*args, int); break; case 'l': iv = va_arg(*args, long); break; case 'V': iv = va_arg(*args, IV); break; -#ifdef Quad_t +#ifdef HAS_QUAD case 'q': iv = va_arg(*args, Quad_t); break; #endif } @@ -5299,7 +5367,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV default: iv = (int)iv; break; case 'l': iv = (long)iv; break; case 'V': break; -#ifdef Quad_t +#ifdef HAS_QUAD case 'q': iv = (Quad_t)iv; break; #endif } @@ -5353,7 +5421,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV default: uv = va_arg(*args, unsigned); break; case 'l': uv = va_arg(*args, unsigned long); break; case 'V': uv = va_arg(*args, UV); break; -#ifdef Quad_t +#ifdef HAS_QUAD case 'q': uv = va_arg(*args, Quad_t); break; #endif } @@ -5365,7 +5433,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV default: uv = (unsigned)uv; break; case 'l': uv = (unsigned long)uv; break; case 'V': break; -#ifdef Quad_t +#ifdef HAS_QUAD case 'q': uv = (Quad_t)uv; break; #endif } @@ -5521,7 +5589,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV default: *(va_arg(*args, int*)) = i; break; case 'l': *(va_arg(*args, long*)) = i; break; case 'V': *(va_arg(*args, IV*)) = i; break; -#ifdef Quad_t +#ifdef HAS_QUAD case 'q': *(va_arg(*args, Quad_t*)) = i; break; #endif } @@ -5610,9 +5678,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV #endif #ifndef OpREFCNT_inc -# define OpREFCNT_inc(o) o +# define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop) +#endif + +#ifndef GpREFCNT_inc +# define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL) #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)) @@ -5637,11 +5710,19 @@ Perl_re_dup(pTHX_ REGEXP *r) PerlIO * Perl_fp_dup(pTHX_ PerlIO *fp, char type) { + PerlIO *ret; if (!fp) return (PerlIO*)NULL; - return fp; /* XXX */ - /* return PerlIO_fdopen(PerlIO_fileno(fp), - type == '<' ? "r" : type == '>' ? "w" : "rw"); */ + + /* look for it in the table first */ + ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp); + if (ret) + return ret; + + /* create anew and remember what it is */ + ret = PerlIO_fdupopen(fp); + ptr_table_store(PL_ptr_table, fp, ret); + return ret; } DIR * @@ -5659,19 +5740,28 @@ Perl_gp_dup(pTHX_ GP *gp) GP *ret; if (!gp) return (GP*)NULL; + /* look for it in the table first */ + ret = (GP*)ptr_table_fetch(PL_ptr_table, gp); + if (ret) + return ret; + + /* create anew and remember what it is */ Newz(0, ret, 1, GP); + ptr_table_store(PL_ptr_table, gp, ret); + + /* clone */ + ret->gp_refcnt = 0; /* must be before any other dups! */ 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_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */ 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; } @@ -5682,6 +5772,11 @@ Perl_mg_dup(pTHX_ MAGIC *mg) MAGIC *mgprev; if (!mg) return (MAGIC*)NULL; + /* look for it in the table first */ + mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg); + if (mgret) + return mgret; + for (; mg; mg = mg->mg_moremagic) { MAGIC *nmg; Newz(0, nmg, 1, MAGIC); @@ -5704,8 +5799,17 @@ Perl_mg_dup(pTHX_ MAGIC *mg) 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) + if (mg->mg_len >= 0) { nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len); + if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) { + AMT *amtp = (AMT*)mg->mg_ptr; + AMT *namtp = (AMT*)nmg->mg_ptr; + I32 i; + for (i = 1; i < NofAMmeth; i++) { + namtp->table[i] = cv_dup_inc(amtp->table[i]); + } + } + } else if (mg->mg_len == HEf_SVKEY) nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr); } @@ -5714,21 +5818,21 @@ Perl_mg_dup(pTHX_ MAGIC *mg) return mgret; } -SVTBL * -Perl_sv_table_new(pTHX) +PTR_TBL_t * +Perl_ptr_table_new(pTHX) { - SVTBL *tbl; - Newz(0, tbl, 1, SVTBL); + PTR_TBL_t *tbl; + Newz(0, tbl, 1, PTR_TBL_t); tbl->tbl_max = 511; tbl->tbl_items = 0; - Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, SVTBLENT*); + Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*); return tbl; } -SV * -Perl_sv_table_fetch(pTHX_ SVTBL *tbl, SV *sv) +void * +Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv) { - SVTBLENT *tblent; + PTR_TBL_ENT_t *tblent; UV hash = (UV)sv; assert(tbl); tblent = tbl->tbl_ary[hash & tbl->tbl_max]; @@ -5736,48 +5840,52 @@ Perl_sv_table_fetch(pTHX_ SVTBL *tbl, SV *sv) if (tblent->oldval == sv) return tblent->newval; } - return Nullsv; + return (void*)NULL; } void -Perl_sv_table_store(pTHX_ SVTBL *tbl, SV *old, SV *new) +Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv) { - SVTBLENT *tblent, **otblent; - UV hash = (UV)old; + PTR_TBL_ENT_t *tblent, **otblent; + /* XXX this may be pessimal on platforms where pointers aren't good + * hash values e.g. if they grow faster in the most significant + * bits */ + UV hash = (UV)oldv; 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; + if (tblent->oldval == oldv) { + tblent->newval = newv; tbl->tbl_items++; return; } } - Newz(0, tblent, 1, SVTBLENT); - tblent->oldval = old; - tblent->newval = new; + Newz(0, tblent, 1, PTR_TBL_ENT_t); + tblent->oldval = oldv; + tblent->newval = newv; tblent->next = *otblent; *otblent = tblent; tbl->tbl_items++; if (i && tbl->tbl_items > tbl->tbl_max) - sv_table_split(tbl); + ptr_table_split(tbl); } void -Perl_sv_table_split(pTHX_ SVTBL *tbl) +Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) { - SVTBLENT **ary = tbl->tbl_ary; + PTR_TBL_ENT_t **ary = tbl->tbl_ary; UV oldsize = tbl->tbl_max + 1; UV newsize = oldsize * 2; UV i; - Renew(ary, newsize, SVTBLENT*); - Zero(&ary[oldsize], newsize-oldsize, SVTBLENT*); + Renew(ary, newsize, PTR_TBL_ENT_t*); + Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*); tbl->tbl_max = --newsize; tbl->tbl_ary = ary; for (i=0; i < oldsize; i++, ary++) { - SVTBLENT **curentp, **entp, *ent; + PTR_TBL_ENT_t **curentp, **entp, *ent; if (!*ary) continue; curentp = ary + oldsize; @@ -5794,6 +5902,10 @@ Perl_sv_table_split(pTHX_ SVTBL *tbl) } } +#ifdef DEBUGGING +char *PL_watch_pvx; +#endif + SV * Perl_sv_dup(pTHX_ SV *sstr) { @@ -5802,23 +5914,27 @@ Perl_sv_dup(pTHX_ SV *sstr) int stype; SV *dstr; - if (!sstr) + if (!sstr || SvTYPE(sstr) == SVTYPEMASK) return Nullsv; /* look for it in the table first */ - dstr = sv_table_fetch(PL_sv_table, sstr); + dstr = (SV*)ptr_table_fetch(PL_ptr_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); + ptr_table_store(PL_ptr_table, sstr, dstr); /* clone */ SvFLAGS(dstr) = SvFLAGS(sstr); SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */ - SvREFCNT(dstr) = 0; + SvREFCNT(dstr) = 0; /* must be before any other dups! */ + +#ifdef DEBUGGING + if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx) + PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n", + PL_watch_pvx, SvPVX(sstr)); +#endif switch (SvTYPE(sstr)) { case SVt_NULL: @@ -5840,8 +5956,10 @@ Perl_sv_dup(pTHX_ SV *sstr) SvANY(dstr) = new_XPV(); SvCUR(dstr) = SvCUR(sstr); SvLEN(dstr) = SvLEN(sstr); - if (SvPOKp(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ break; @@ -5850,8 +5968,10 @@ Perl_sv_dup(pTHX_ SV *sstr) SvCUR(dstr) = SvCUR(sstr); SvLEN(dstr) = SvLEN(sstr); SvIVX(dstr) = SvIVX(sstr); - if (SvPOKp(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ break; @@ -5861,8 +5981,10 @@ Perl_sv_dup(pTHX_ SV *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)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ break; @@ -5873,12 +5995,11 @@ Perl_sv_dup(pTHX_ SV *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)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ break; @@ -5889,11 +6010,10 @@ Perl_sv_dup(pTHX_ SV *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)) + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ @@ -5908,12 +6028,11 @@ Perl_sv_dup(pTHX_ SV *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)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */ @@ -5928,12 +6047,11 @@ Perl_sv_dup(pTHX_ SV *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)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ GvNAMELEN(dstr) = GvNAMELEN(sstr); @@ -5941,7 +6059,7 @@ Perl_sv_dup(pTHX_ SV *sstr) GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr)); GvFLAGS(dstr) = GvFLAGS(sstr); GvGP(dstr) = gp_dup(GvGP(sstr)); - GvGP(dstr)->gp_refcnt++; + (void)GpREFCNT_inc(GvGP(dstr)); break; case SVt_PVIO: SvANY(dstr) = new_XPVIO(); @@ -5950,19 +6068,18 @@ Perl_sv_dup(pTHX_ SV *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)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ - IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr)); + 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)); + IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr)); /* PL_rsfp_filters entries have fake IoDIRP() */ if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP)) IoDIRP(dstr) = dirp_dup(IoDIRP(sstr)); @@ -5992,12 +6109,13 @@ Perl_sv_dup(pTHX_ SV *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)) { + if (AvARRAY((AV*)sstr)) { SV **dst_ary, **src_ary; SSize_t items = AvFILLp((AV*)sstr) + 1; - src_ary = AvALLOC((AV*)sstr); + src_ary = AvARRAY((AV*)sstr); Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*); + ptr_table_store(PL_ptr_table, src_ary, dst_ary); SvPVX(dstr) = (char*)dst_ary; AvALLOC((AV*)dstr) = dst_ary; if (AvREAL((AV*)sstr)) { @@ -6035,34 +6153,22 @@ Perl_sv_dup(pTHX_ SV *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; - } + ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i], + !!HvSHAREKEYS(sstr)); ++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; + dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr)); } - else + else { SvPVX(dstr) = Nullch; + HvEITER((HV*)dstr) = (HE*)NULL; + } HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */ HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr)); break; case SVt_PVFM: SvANY(dstr) = new_XPVFM(); + FmLINES(dstr) = FmLINES(sstr); goto dup_pvcv; /* NOTREACHED */ case SVt_PVCV: @@ -6073,12 +6179,9 @@ dup_pvcv: 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)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */ @@ -6088,7 +6191,15 @@ dup_pvcv: CvXSUBANY(dstr) = CvXSUBANY(sstr); CvGV(dstr) = gv_dup_inc(CvGV(sstr)); CvDEPTH(dstr) = CvDEPTH(sstr); - CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr)); + if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) { + /* XXX padlists are real, but pretend to be not */ + AvREAL_on(CvPADLIST(sstr)); + CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr)); + AvREAL_off(CvPADLIST(sstr)); + AvREAL_off(CvPADLIST(dstr)); + } + else + CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr)); CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr)); CvFLAGS(dstr) = CvFLAGS(sstr); break; @@ -6097,49 +6208,475 @@ dup_pvcv: break; } - if (SvOBJECT(dstr)) + if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO) ++PL_sv_objcount; return dstr; } +PERL_CONTEXT * +Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) +{ + PERL_CONTEXT *ncxs; + + if (!cxs) + return (PERL_CONTEXT*)NULL; + + /* look for it in the table first */ + ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs); + if (ncxs) + return ncxs; + + /* create anew and remember what it is */ + Newz(56, ncxs, max + 1, PERL_CONTEXT); + ptr_table_store(PL_ptr_table, cxs, ncxs); + + while (ix >= 0) { + PERL_CONTEXT *cx = &cxs[ix]; + PERL_CONTEXT *ncx = &ncxs[ix]; + ncx->cx_type = cx->cx_type; + if (CxTYPE(cx) == CXt_SUBST) { + Perl_croak(aTHX_ "Cloning substitution context is unimplemented"); + } + else { + ncx->blk_oldsp = cx->blk_oldsp; + ncx->blk_oldcop = cx->blk_oldcop; + ncx->blk_oldretsp = cx->blk_oldretsp; + ncx->blk_oldmarksp = cx->blk_oldmarksp; + ncx->blk_oldscopesp = cx->blk_oldscopesp; + ncx->blk_oldpm = cx->blk_oldpm; + ncx->blk_gimme = cx->blk_gimme; + switch (CxTYPE(cx)) { + case CXt_SUB: + ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0 + ? cv_dup_inc(cx->blk_sub.cv) + : cv_dup(cx->blk_sub.cv)); + ncx->blk_sub.argarray = (cx->blk_sub.hasargs + ? av_dup_inc(cx->blk_sub.argarray) + : Nullav); + ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray); + ncx->blk_sub.olddepth = cx->blk_sub.olddepth; + ncx->blk_sub.hasargs = cx->blk_sub.hasargs; + ncx->blk_sub.lval = cx->blk_sub.lval; + break; + case CXt_EVAL: + ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval; + ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type; + ncx->blk_eval.old_name = SAVEPV(cx->blk_eval.old_name); + ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root; + ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text); + break; + case CXt_LOOP: + ncx->blk_loop.label = cx->blk_loop.label; + ncx->blk_loop.resetsp = cx->blk_loop.resetsp; + ncx->blk_loop.redo_op = cx->blk_loop.redo_op; + ncx->blk_loop.next_op = cx->blk_loop.next_op; + ncx->blk_loop.last_op = cx->blk_loop.last_op; + ncx->blk_loop.iterdata = (CxPADLOOP(cx) + ? cx->blk_loop.iterdata + : gv_dup((GV*)cx->blk_loop.iterdata)); + ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave); + ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval); + ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary); + ncx->blk_loop.iterix = cx->blk_loop.iterix; + ncx->blk_loop.itermax = cx->blk_loop.itermax; + break; + case CXt_FORMAT: + ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv); + ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv); + ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv); + ncx->blk_sub.hasargs = cx->blk_sub.hasargs; + break; + case CXt_BLOCK: + case CXt_NULL: + break; + } + } + --ix; + } + return ncxs; +} + +PERL_SI * +Perl_si_dup(pTHX_ PERL_SI *si) +{ + PERL_SI *nsi; + + if (!si) + return (PERL_SI*)NULL; + + /* look for it in the table first */ + nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si); + if (nsi) + return nsi; + + /* create anew and remember what it is */ + Newz(56, nsi, 1, PERL_SI); + ptr_table_store(PL_ptr_table, si, nsi); + + nsi->si_stack = av_dup_inc(si->si_stack); + nsi->si_cxix = si->si_cxix; + nsi->si_cxmax = si->si_cxmax; + nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax); + nsi->si_type = si->si_type; + nsi->si_prev = si_dup(si->si_prev); + nsi->si_next = si_dup(si->si_next); + nsi->si_markoff = si->si_markoff; + + return nsi; +} + +#define POPINT(ss,ix) ((ss)[--(ix)].any_i32) +#define TOPINT(ss,ix) ((ss)[ix].any_i32) +#define POPLONG(ss,ix) ((ss)[--(ix)].any_long) +#define TOPLONG(ss,ix) ((ss)[ix].any_long) +#define POPIV(ss,ix) ((ss)[--(ix)].any_iv) +#define TOPIV(ss,ix) ((ss)[ix].any_iv) +#define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr) +#define TOPPTR(ss,ix) ((ss)[ix].any_ptr) +#define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr) +#define TOPDPTR(ss,ix) ((ss)[ix].any_dptr) +#define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr) +#define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr) + +/* XXXXX todo */ +#define pv_dup_inc(p) SAVEPV(p) +#define pv_dup(p) SAVEPV(p) +#define svp_dup_inc(p,pp) any_dup(p,pp) + +void * +Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl) +{ + void *ret; + + if (!v) + return (void*)NULL; + + /* look for it in the table first */ + ret = ptr_table_fetch(PL_ptr_table, v); + if (ret) + return ret; + + /* see if it is part of the interpreter structure */ + if (v >= (void*)proto_perl && v < (void*)(proto_perl+1)) + ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl)); + else + ret = v; + + return ret; +} + +ANY * +Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) +{ + ANY *ss = proto_perl->Tsavestack; + I32 ix = proto_perl->Tsavestack_ix; + I32 max = proto_perl->Tsavestack_max; + ANY *nss; + SV *sv; + GV *gv; + AV *av; + HV *hv; + void* ptr; + int intval; + long longval; + GP *gp; + IV iv; + I32 i; + char *c; + void (*dptr) (void*); + void (*dxptr) (pTHXo_ void*); + + Newz(54, nss, max, ANY); + + while (ix > 0) { + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + switch (i) { + case SAVEt_ITEM: /* normal string */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + break; + case SAVEt_SV: /* scalar reference */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup_inc(gv); + break; + case SAVEt_GENERIC_SVREF: /* generic sv */ + case SAVEt_SVREF: /* scalar reference */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ + break; + case SAVEt_AV: /* array reference */ + av = (AV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup_inc(av); + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup(gv); + break; + case SAVEt_HV: /* hash reference */ + hv = (HV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup_inc(hv); + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup(gv); + break; + case SAVEt_INT: /* int reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + intval = (int)POPINT(ss,ix); + TOPINT(nss,ix) = intval; + break; + case SAVEt_LONG: /* long reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + longval = (long)POPLONG(ss,ix); + TOPLONG(nss,ix) = longval; + break; + case SAVEt_I32: /* I32 reference */ + case SAVEt_I16: /* I16 reference */ + case SAVEt_I8: /* I8 reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_IV: /* IV reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + break; + case SAVEt_SPTR: /* SV* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup(sv); + break; + case SAVEt_VPTR: /* random* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + break; + case SAVEt_PPTR: /* char* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup(c); + break; + case SAVEt_HPTR: /* HV* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + hv = (HV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup(hv); + break; + case SAVEt_APTR: /* AV* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + av = (AV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup(av); + break; + case SAVEt_NSTAB: + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup(gv); + break; + case SAVEt_GP: /* scalar reference */ + gp = (GP*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gp = gp_dup(gp); + (void)GpREFCNT_inc(gp); + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup_inc(c); + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup(c); + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + break; + case SAVEt_FREESV: + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + break; + case SAVEt_FREEOP: + ptr = POPPTR(ss,ix); + if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { + /* these are assumed to be refcounted properly */ + switch (((OP*)ptr)->op_type) { + case OP_LEAVESUB: + case OP_LEAVESUBLV: + case OP_LEAVEEVAL: + case OP_LEAVE: + case OP_SCOPE: + case OP_LEAVEWRITE: + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + break; + default: + TOPPTR(nss,ix) = Nullop; + break; + } + } + else + TOPPTR(nss,ix) = Nullop; + break; + case SAVEt_FREEPV: + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup_inc(c); + break; + case SAVEt_CLEARSV: + longval = POPLONG(ss,ix); + TOPLONG(nss,ix) = longval; + break; + case SAVEt_DELETE: + hv = (HV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup_inc(hv); + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup_inc(c); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_DESTRUCTOR: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ + dptr = POPDPTR(ss,ix); + TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl); + break; + case SAVEt_DESTRUCTOR_X: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ + dxptr = POPDXPTR(ss,ix); + TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl); + break; + case SAVEt_REGCONTEXT: + case SAVEt_ALLOC: + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + ix -= i; + break; + case SAVEt_STACK_POS: /* Position on Perl stack */ + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_AELEM: /* array element */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + av = (AV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup_inc(av); + break; + case SAVEt_HELEM: /* hash element */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + hv = (HV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup_inc(hv); + break; + case SAVEt_OP: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = ptr; + break; + case SAVEt_HINTS: + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + default: + Perl_croak(aTHX_ "panic: ss_dup inconsistency"); + } + } + + return nss; +} + +#ifdef PERL_OBJECT +#include "XSUB.h" +#endif + +PerlInterpreter * +perl_clone(PerlInterpreter *proto_perl, UV flags) +{ +#ifdef PERL_OBJECT + CPerlObj *pPerl = (CPerlObj*)proto_perl; +#endif + +#ifdef PERL_IMPLICIT_SYS + return perl_clone_using(proto_perl, flags, + proto_perl->IMem, + proto_perl->IMemShared, + proto_perl->IMemParse, + proto_perl->IEnv, + proto_perl->IStdIO, + proto_perl->ILIO, + proto_perl->IDir, + proto_perl->ISock, + proto_perl->IProc); +} + PerlInterpreter * -perl_clone_using(PerlInterpreter *proto_perl, IV flags, - struct IPerlMem* ipM, struct IPerlEnv* ipE, +perl_clone_using(PerlInterpreter *proto_perl, UV flags, + struct IPerlMem* ipM, struct IPerlMem* ipMS, + struct IPerlMem* ipMP, struct IPerlEnv* ipE, struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, struct IPerlDir* ipD, struct IPerlSock* ipS, struct IPerlProc* ipP) { + /* 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. */ + IV i; SV *sv; SV **svp; +# ifdef PERL_OBJECT + CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO, + ipD, ipS, ipP); + PERL_SET_INTERP(pPerl); +# else /* !PERL_OBJECT */ PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); PERL_SET_INTERP(my_perl); -#ifdef DEBUGGING +# 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. */ +# else /* !DEBUGGING */ + Zero(my_perl, 1, PerlInterpreter); +# endif /* DEBUGGING */ /* host pointers */ PL_Mem = ipM; + PL_MemShared = ipMS; + PL_MemParse = ipMP; PL_Env = ipE; PL_StdIO = ipStd; PL_LIO = ipLIO; PL_Dir = ipD; PL_Sock = ipS; PL_Proc = ipP; +# endif /* PERL_OBJECT */ +#else /* !PERL_IMPLICIT_SYS */ + IV i; + SV *sv; + SV **svp; + PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(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 /* !DEBUGGING */ + Zero(my_perl, 1, PerlInterpreter); +# endif /* DEBUGGING */ +#endif /* PERL_IMPLICIT_SYS */ /* arena roots */ PL_xiv_arenaroot = NULL; @@ -6166,46 +6703,53 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_debug = proto_perl->Idebug; /* create SV map for pointer relocation */ - PL_sv_table = sv_table_new(); + PL_ptr_table = ptr_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); + ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); +#ifdef PERL_OBJECT + SvUPGRADE(&PL_sv_no, SVt_PVNV); +#else SvANY(&PL_sv_no) = new_XPVNV(); +#endif 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); + ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); +#ifdef PERL_OBJECT + SvUPGRADE(&PL_sv_yes, SVt_PVNV); +#else SvANY(&PL_sv_yes) = new_XPVNV(); +#endif 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); + ptr_table_store(PL_ptr_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); + ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab); PL_compiling = proto_perl->Icompiling; PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv); PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file); - 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; + ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); + if (!specialWARN(PL_compiling.cop_warnings)) + PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings); + PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl); /* pseudo environmental stuff */ PL_origargc = proto_perl->Iorigargc; @@ -6224,7 +6768,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, /* switches */ PL_minus_c = proto_perl->Iminus_c; - Copy(proto_perl->Ipatchlevel, PL_patchlevel, 10, char); + PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel); PL_localpatches = proto_perl->Ilocalpatches; PL_splitstr = proto_perl->Isplitstr; PL_preprocess = proto_perl->Ipreprocess; @@ -6244,7 +6788,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_perl_destruct_level = proto_perl->Iperl_destruct_level; /* magical thingies */ - /* XXX time(&PL_basetime) instead? */ + /* XXX time(&PL_basetime) when asked for? */ PL_basetime = proto_perl->Ibasetime; PL_formfeed = sv_dup(proto_perl->Iformfeed); @@ -6297,7 +6841,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_forkprocess = proto_perl->Iforkprocess; /* subprocess state */ - PL_fdpid = av_dup(proto_perl->Ifdpid); + PL_fdpid = av_dup_inc(proto_perl->Ifdpid); /* internal state */ PL_tainting = proto_perl->Itainting; @@ -6311,16 +6855,16 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, 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_root = OpREFCNT_inc(proto_perl->Ieval_root); PL_eval_start = proto_perl->Ieval_start; /* runtime control stuff */ - PL_curcopdb = proto_perl->Icurcopdb; + PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl); PL_copline = proto_perl->Icopline; PL_filemode = proto_perl->Ifilemode; PL_lastfd = proto_perl->Ilastfd; - PL_oldname = proto_perl->Ioldname; /* XXX */ + PL_oldname = proto_perl->Ioldname; /* XXX not quite right */ PL_Argv = NULL; PL_Cmd = Nullch; PL_gensym = proto_perl->Igensym; @@ -6342,19 +6886,20 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, } else PL_exitlist = (PerlExitListEntry*)NULL; - PL_modglobal = hv_dup(proto_perl->Imodglobal); + PL_modglobal = hv_dup_inc(proto_perl->Imodglobal); - PL_profiledata = NULL; /* XXX */ + PL_profiledata = NULL; 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_rsfp_filters entries have fake IoDIRP() */ + PL_rsfp_filters = av_dup_inc(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 */ + PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table, + proto_perl->Tcurpad); #ifdef HAVE_INTERP_INTERN sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); @@ -6363,7 +6908,6 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, /* 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; @@ -6377,9 +6921,9 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, 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_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */ PL_origalen = proto_perl->Iorigalen; - PL_pidstatus = newHV(); + PL_pidstatus = newHV(); /* XXX flag for cloning? */ PL_osname = SAVEPV(proto_perl->Iosname); PL_sh_path = SAVEPV(proto_perl->Ish_path); PL_sighandlerp = proto_perl->Isighandlerp; @@ -6387,7 +6931,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_runops = proto_perl->Irunops; - Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); /* XXX */ + Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); #ifdef CSH PL_cshlen = proto_perl->Icshlen; @@ -6398,11 +6942,10 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, 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_stuff = sv_dup_inc(proto_perl->Ilex_stuff); + PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl); PL_lex_op = proto_perl->Ilex_op; PL_lex_inpat = proto_perl->Ilex_inpat; PL_lex_inwhat = proto_perl->Ilex_inwhat; @@ -6428,7 +6971,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, 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_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */ PL_expect = proto_perl->Iexpect; @@ -6497,10 +7040,10 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower); /* swatch cache */ - PL_last_swash_hv = Nullhv; /* XXX recreate swatch cache? */ + PL_last_swash_hv = Nullhv; /* reinits on demand */ PL_last_swash_klen = 0; PL_last_swash_key[0]= '\0'; - PL_last_swash_tmps = Nullch; + PL_last_swash_tmps = (U8*)NULL; PL_last_swash_slen = 0; /* perly.c globals */ @@ -6513,23 +7056,98 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, 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 */ + PL_uudmap['M'] = 0; /* reinits on demand */ + PL_bitcount = Nullch; /* reinits on demand */ + if (proto_perl->Ipsig_ptr) { + int sig_num[] = { SIG_NUM }; + Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*); + Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*); + for (i = 1; PL_sig_name[i]; i++) { + PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]); + PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]); + } + } + else { + PL_psig_ptr = (SV**)NULL; + PL_psig_name = (SV**)NULL; + } /* 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(); + if (flags & 1) { + /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ + PL_tmps_ix = proto_perl->Ttmps_ix; + PL_tmps_max = proto_perl->Ttmps_max; + PL_tmps_floor = proto_perl->Ttmps_floor; + Newz(50, PL_tmps_stack, PL_tmps_max, SV*); + i = 0; + while (i <= PL_tmps_ix) { + PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]); + ++i; + } + + /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ + i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack; + Newz(54, PL_markstack, i, I32); + PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max + - proto_perl->Tmarkstack); + PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr + - proto_perl->Tmarkstack); + Copy(proto_perl->Tmarkstack, PL_markstack, + PL_markstack_ptr - PL_markstack + 1, I32); + + /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] + * NOTE: unlike the others! */ + PL_scopestack_ix = proto_perl->Tscopestack_ix; + PL_scopestack_max = proto_perl->Tscopestack_max; + Newz(54, PL_scopestack, PL_scopestack_max, I32); + Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32); + + /* next push_return() sets PL_retstack[PL_retstack_ix] + * NOTE: unlike the others! */ + PL_retstack_ix = proto_perl->Tretstack_ix; + PL_retstack_max = proto_perl->Tretstack_max; + Newz(54, PL_retstack, PL_retstack_max, OP*); + Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32); + + /* NOTE: si_dup() looks at PL_markstack */ + PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo); + + /* PL_curstack = PL_curstackinfo->si_stack; */ + PL_curstack = av_dup(proto_perl->Tcurstack); + PL_mainstack = av_dup(proto_perl->Tmainstack); + + /* next PUSHs() etc. set *(PL_stack_sp+1) */ + PL_stack_base = AvARRAY(PL_curstack); + PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp + - proto_perl->Tstack_base); + PL_stack_max = PL_stack_base + AvMAX(PL_curstack); + + /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] + * NOTE: unlike the others! */ + PL_savestack_ix = proto_perl->Tsavestack_ix; + PL_savestack_max = proto_perl->Tsavestack_max; + /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/ + PL_savestack = ss_dup(proto_perl); + } + else { + init_stacks(); + } + + PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ + PL_top_env = &PL_start_env; PL_op = proto_perl->Top; + + PL_Sv = Nullsv; + PL_Xpv = (XPV*)NULL; + PL_na = proto_perl->Tna; + PL_statbuf = proto_perl->Tstatbuf; PL_statcache = proto_perl->Tstatcache; PL_statgv = gv_dup(proto_perl->Tstatgv); - PL_statname = sv_dup(proto_perl->Tstatname); + PL_statname = sv_dup_inc(proto_perl->Tstatname); #ifdef HAS_TIMES PL_timesbuf = proto_perl->Ttimesbuf; #endif @@ -6542,7 +7160,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, 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; /* XXX */ + PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */ PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget); PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget); PL_formtarget = sv_dup(proto_perl->Tformtarget); @@ -6553,8 +7171,6 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, 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; @@ -6563,18 +7179,76 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_modcount = proto_perl->Tmodcount; PL_lastgotoprobe = Nullop; PL_dumpindent = proto_perl->Tdumpindent; + + PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl); 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_efloatbuf = Nullch; /* reinits on demand */ + PL_efloatsize = 0; /* reinits on demand */ + + /* regex stuff */ PL_screamfirst = NULL; PL_screamnext = NULL; - PL_maxscream = -1; + PL_maxscream = -1; /* reinits on demand */ PL_lastscream = Nullsv; + PL_watchaddr = NULL; + PL_watchok = Nullch; + + PL_regdummy = proto_perl->Tregdummy; + PL_regcomp_parse = Nullch; + PL_regxend = Nullch; + PL_regcode = (regnode*)NULL; + PL_regnaughty = 0; + PL_regsawback = 0; + PL_regprecomp = Nullch; + PL_regnpar = 0; + PL_regsize = 0; + PL_regflags = 0; + PL_regseen = 0; + PL_seen_zerolen = 0; + PL_seen_evals = 0; + PL_regcomp_rx = (regexp*)NULL; + PL_extralen = 0; + PL_colorset = 0; /* reinits PL_colors[] */ + /*PL_colors[6] = {0,0,0,0,0,0};*/ + PL_reg_whilem_seen = 0; + PL_reginput = Nullch; + PL_regbol = Nullch; + PL_regeol = Nullch; + PL_regstartp = (I32*)NULL; + PL_regendp = (I32*)NULL; + PL_reglastparen = (U32*)NULL; + PL_regtill = Nullch; + PL_regprev = '\n'; + PL_reg_start_tmp = (char**)NULL; + PL_reg_start_tmpl = 0; + PL_regdata = (struct reg_data*)NULL; + PL_bostr = Nullch; + PL_reg_flags = 0; + PL_reg_eval_set = 0; + PL_regnarrate = 0; + PL_regprogram = (regnode*)NULL; + PL_regindent = 0; + PL_regcc = (CURCUR*)NULL; + PL_reg_call_cc = (struct re_cc_state*)NULL; + PL_reg_re = (regexp*)NULL; + PL_reg_ganch = Nullch; + PL_reg_sv = Nullsv; + PL_reg_magic = (MAGIC*)NULL; + PL_reg_oldpos = 0; + PL_reg_oldcurpm = (PMOP*)NULL; + PL_reg_curpm = (PMOP*)NULL; + PL_reg_oldsaved = Nullch; + PL_reg_oldsavedlen = 0; + PL_reg_maxiter = 0; + PL_reg_leftiter = 0; + PL_reg_poscache = Nullch; + PL_reg_poscache_size= 0; + /* RE engine - function pointers */ PL_regcompp = proto_perl->Tregcompp; PL_regexecp = proto_perl->Tregexecp; @@ -6582,31 +7256,24 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, 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; + PL_reg_starttry = 0; +#ifdef PERL_OBJECT + return (PerlInterpreter*)pPerl; +#else return my_perl; +#endif } -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 */ +#else /* !USE_ITHREADS */ #ifdef PERL_OBJECT #include "XSUB.h" #endif +#endif /* USE_ITHREADS */ + static void do_report_used(pTHXo_ SV *sv) { @@ -6635,7 +7302,7 @@ do_clean_objs(pTHXo_ SV *sv) static void do_clean_named_objs(pTHXo_ SV *sv) { - if (SvTYPE(sv) == SVt_PVGV) { + if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) { if ( SvOBJECT(GvSV(sv)) || GvAV(sv) && SvOBJECT(GvAV(sv)) || GvHV(sv) && SvOBJECT(GvHV(sv)) ||