X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=7f030e3f08ea2de9b01ee5b3cad91bb331f7e8f7;hb=5be5c7a687aa37f2ea9dec7988eb57cad1f1ec24;hp=3d5a4f38f6043e23691618830b326490c3172251;hpb=7a7f3e459f22e8eecb8e377ed2a7b207cba1585f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 3d5a4f3..7f030e3 100644 --- a/sv.c +++ b/sv.c @@ -246,8 +246,13 @@ S_new_SV(pTHX) SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; - sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ? - (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline); + sv->sv_debug_line = (U16) (PL_parser + ? PL_parser->copline == NOLINE + ? PL_curcop + ? CopLINE(PL_curcop) + : 0 + : PL_parser->copline + : 0); sv->sv_debug_inpad = 0; sv->sv_debug_cloned = 0; sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL; @@ -462,7 +467,8 @@ do_clean_named_objs(pTHX_ SV *sv) SvOBJECT(GvSV(sv))) || (GvAV(sv) && SvOBJECT(GvAV(sv))) || (GvHV(sv) && SvOBJECT(GvHV(sv))) || - (GvIO(sv) && SvOBJECT(GvIO(sv))) || + /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */ + (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) || (GvCV(sv) && SvOBJECT(GvCV(sv))) ) { DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv))); @@ -502,10 +508,6 @@ do_clean_all(pTHX_ SV *sv) dVAR; DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); SvFLAGS(sv) |= SVf_BREAK; - if (PL_comppad == (AV*)sv) { - PL_comppad = NULL; - PL_curpad = NULL; - } SvREFCNT_dec(sv); } @@ -690,8 +692,8 @@ Perl_get_arena(pTHX_ size_t arena_size, U32 misc) Newx(adesc->arena, arena_size, char); adesc->size = arena_size; adesc->misc = misc; - DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %d\n", - curr, (void*)adesc->arena, arena_size)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", + curr, (void*)adesc->arena, (UV)arena_size)); return adesc->arena; } @@ -784,16 +786,16 @@ are used for this, except for arena_size. For the sv-types that have no bodies, arenas are not used, so those PL_body_roots[sv_type] are unused, and can be overloaded. In something of a special case, SVt_NULL is borrowed for HE arenas; -PL_body_roots[SVt_NULL] is filled by S_more_he, but the +PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the bodies_by_type[SVt_NULL] slot is not used, as the table is not -available in hv.c, +available in hv.c. -PTEs also use arenas, but are never seen in Perl_sv_upgrade. -Nonetheless, they get their own slot in bodies_by_type[SVt_NULL], so -they can just use the same allocation semantics. At first, PTEs were -also overloaded to a non-body sv-type, but this yielded hard-to-find -malloc bugs, so was simplified by claiming a new slot. This choice -has no consequence at this time. +PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless, +they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can +just use the same allocation semantics. At first, PTEs were also +overloaded to a non-body sv-type, but this yielded hard-to-find malloc +bugs, so was simplified by claiming a new slot. This choice has no +consequence at this time. */ @@ -873,7 +875,7 @@ static const struct body_details bodies_by_type[] = { FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) }, /* The bind placeholder pretends to be an RV for now. - Also it's marked as "can't upgrade" top stop anyone using it before it's + Also it's marked as "can't upgrade" to stop anyone using it before it's implemented. */ { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 }, @@ -928,13 +930,13 @@ static const struct body_details bodies_by_type[] = { copy_length(XPVAV, xmg_stash) - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill), + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill), - SVt_PVAV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) }, + SVt_PVAV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) }, { sizeof(xpvhv_allocated), copy_length(XPVHV, xmg_stash) - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill), + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill), - SVt_PVHV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) }, + SVt_PVHV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) }, /* 56 */ { sizeof(xpvcv_allocated), sizeof(xpvcv_allocated), @@ -1320,7 +1322,8 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) * NV slot, but the new one does, then we need to initialise the * freshly created NV slot with whatever the correct bit pattern is * for 0.0 */ - if (old_type_details->zero_nv && !new_type_details->zero_nv) + if (old_type_details->zero_nv && !new_type_details->zero_nv + && !isGV_with_GP(sv)) SvNV_set(sv, 0); #endif @@ -2737,15 +2740,16 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) const U32 isUIOK = SvIsUV(sv); char buf[TYPE_CHARS(UV)]; char *ebuf, *ptr; + STRLEN len; if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf); + len = ebuf - ptr; /* inlined from sv_setpvn */ - SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1)); - Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char); - SvCUR_set(sv, ebuf - ptr); - s = SvEND(sv); + s = SvGROW_mutable(sv, len + 1); + Move(ptr, s, len, char); + s += len; *s = '\0'; } else if (SvNOKp(sv)) { @@ -2809,7 +2813,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) Copies a stringified representation of the source SV into the destination SV. Automatically performs any necessary mg_get and coercion of numeric values into strings. Guaranteed to preserve -UTF-8 flag even from overloaded objects. Similar in nature to +UTF8 flag even from overloaded objects. Similar in nature to sv_2pv[_flags] but operates directly on an SV instead of just the string. Mostly uses sv_2pv_flags to do its work, except when that would lose the UTF-8'ness of the PV. @@ -3148,6 +3152,8 @@ copy-ish functions and macros use this underneath. static void S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) { + I32 mro_changes = 0; /* 1 = method, 2 = isa */ + if (dtype != SVt_PVGV) { const char * const name = GvNAME(sstr); const STRLEN len = GvNAMELEN(sstr); @@ -3177,6 +3183,28 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) } #endif + if(GvGP((GV*)sstr)) { + /* If source has method cache entry, clear it */ + if(GvCVGEN(sstr)) { + SvREFCNT_dec(GvCV(sstr)); + GvCV(sstr) = NULL; + GvCVGEN(sstr) = 0; + } + /* If source has a real method, then a method is + going to change */ + else if(GvCV((GV*)sstr)) { + mro_changes = 1; + } + } + + /* If dest already had a real method, that's a change as well */ + if(!mro_changes && GvGP((GV*)dstr) && GvCVu((GV*)dstr)) { + mro_changes = 1; + } + + if(strEQ(GvNAME((GV*)dstr),"ISA")) + mro_changes = 2; + gp_free((GV*)dstr); isGV_with_GP_off(dstr); (void)SvOK_off(dstr); @@ -3191,6 +3219,8 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) GvIMPORTED_on(dstr); } GvMULTI_on(dstr); + if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr)); + else if(mro_changes) mro_method_changed_in(GvSTASH(dstr)); return; } @@ -3240,18 +3270,18 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { common: if (intro) { if (stype == SVt_PVCV) { - if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) { + /*if (GvCVGEN(dstr) && (GvCV(dstr) != (CV*)sref || GvCVGEN(dstr))) {*/ + if (GvCVGEN(dstr)) { SvREFCNT_dec(GvCV(dstr)); GvCV(dstr) = NULL; GvCVGEN(dstr) = 0; /* Switch off cacheness. */ - PL_sub_generation++; } } SAVEGENERICSV(*location); } else dref = *location; - if (stype == SVt_PVCV && *location != sref) { + if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) { CV* const cv = (CV*)*location; if (cv) { if (!GvCVGEN((GV*)dstr) && @@ -3290,7 +3320,7 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { } GvCVGEN(dstr) = 0; /* Switch off cacheness. */ GvASSUMECV_on(dstr); - PL_sub_generation++; + if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ } *location = sref; if (import_flag && !(GvFLAGS(dstr) & import_flag) @@ -3593,9 +3623,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) /* and won't be needed again, potentially */ !(PL_op && PL_op->op_type == OP_AASSIGN)) #ifdef PERL_OLD_COPY_ON_WRITE - && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS - && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS - && SvTYPE(sstr) >= SVt_PVIV) + && ((flags & SV_COW_SHARED_HASH_KEYS) + ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS + && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS + && SvTYPE(sstr) >= SVt_PVIV)) + : 1) #endif ) { /* Failed the swipe test, and it's not a shared hash key either. @@ -3975,7 +4007,7 @@ Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) SvCUR_set(sv, len); SvLEN_set(sv, allocate); if (!(flags & SV_HAS_TRAILING_NUL)) { - *SvEND(sv) = '\0'; + ptr[len] = '\0'; } (void)SvPOK_only_UTF8(sv); /* validate pointer */ SvTAINT(sv); @@ -4365,6 +4397,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, */ if (!obj || obj == sv || how == PERL_MAGIC_arylen || + how == PERL_MAGIC_isaelem || how == PERL_MAGIC_qr || how == PERL_MAGIC_symtab || (SvTYPE(obj) == SVt_PVGV && @@ -5028,6 +5061,7 @@ Perl_sv_clear(pTHX_ register SV *sv) const U32 type = SvTYPE(sv); const struct body_details *const sv_type_details = bodies_by_type + type; + HV *stash; assert(sv); assert(SvREFCNT(sv) == 0); @@ -5123,6 +5157,10 @@ Perl_sv_clear(pTHX_ register SV *sv) hv_undef((HV*)sv); break; case SVt_PVAV: + if (PL_comppad == (AV*)sv) { + PL_comppad = NULL; + PL_curpad = NULL; + } av_undef((AV*)sv); break; case SVt_PVLV: @@ -5135,14 +5173,21 @@ Perl_sv_clear(pTHX_ register SV *sv) SvREFCNT_dec(LvTARG(sv)); case SVt_PVGV: if (isGV_with_GP(sv)) { + if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash)) + mro_method_changed_in(stash); gp_free((GV*)sv); if (GvNAME_HEK(sv)) unshare_hek(GvNAME_HEK(sv)); - /* If we're in a stash, we don't own a reference to it. However it does - have a back reference to us, which needs to be cleared. */ - if (!SvVALID(sv) && GvSTASH(sv)) - sv_del_backref((SV*)GvSTASH(sv), sv); - } + /* If we're in a stash, we don't own a reference to it. However it does + have a back reference to us, which needs to be cleared. */ + if (!SvVALID(sv) && (stash = GvSTASH(sv))) + sv_del_backref((SV*)stash, sv); + } + /* FIXME. There are probably more unreferenced pointers to SVs in the + interpreter struct that we should check and tidy in a similar + fashion to this: */ + if ((GV*)sv == PL_last_in_gv) + PL_last_in_gv = NULL; case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: @@ -5260,6 +5305,10 @@ Perl_sv_free(pTHX_ SV *sv) pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP Perl_dump_sv_child(aTHX_ sv); +#else + #ifdef DEBUG_LEAKING_SCALARS + sv_dump(sv); + #endif #endif } return; @@ -7266,10 +7315,17 @@ Perl_sv_reset(pTHX_ register const char *s, HV *stash) if (!*s) { /* reset ?? searches */ MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab); if (mg) { - PMOP *pm = (PMOP *) mg->mg_obj; - while (pm) { - pm->op_pmdynflags &= ~PMdf_USED; - pm = pm->op_pmnext; + const U32 count = mg->mg_len / sizeof(PMOP**); + PMOP **pmp = (PMOP**) mg->mg_ptr; + PMOP *const *const end = pmp + count; + + while (pmp < end) { +#ifdef USE_ITHREADS + SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]); +#else + (*pmp)->op_pmflags &= ~PMf_USED; +#endif + ++pmp; } } return; @@ -7566,7 +7622,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) SvGROW(sv, len + 1); Move(s,SvPVX(sv),len,char); SvCUR_set(sv, len); - *SvEND(sv) = '\0'; + SvPVX(sv)[len] = '\0'; } if (!SvPOK(sv)) { SvPOK_on(sv); /* validate pointer */ @@ -7932,6 +7988,7 @@ S_sv_unglob(pTHX_ SV *sv) { dVAR; void *xpvmg; + HV *stash; SV * const temp = sv_newmortal(); assert(SvTYPE(sv) == SVt_PVGV); @@ -7939,6 +7996,8 @@ S_sv_unglob(pTHX_ SV *sv) gv_efullname3(temp, (GV *) sv, "*"); if (GvGP(sv)) { + if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash)) + mro_method_changed_in(stash); gp_free((GV*)sv); } if (GvSTASH(sv)) { @@ -8561,7 +8620,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV has_precis = TRUE; } argsv = (SV*)va_arg(*args, void*); - eptr = SvPVx_const(argsv, elen); + eptr = SvPV_const(argsv, elen); if (DO_UTF8(argsv)) is_utf8 = TRUE; goto string; @@ -8693,12 +8752,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV goto unknown; } vecsv = sv_newmortal(); - /* scan_vstring is expected to be called during - * tokenization, so we need to fake up the end - * of the buffer for it - */ - PL_bufend = version + veclen; - scan_vstring(version, vecsv); + scan_vstring(version, version + veclen, vecsv); vecstr = (U8*)SvPV_const(vecsv, veclen); vec_utf8 = DO_UTF8(vecsv); Safefree(version); @@ -8825,7 +8879,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'c': if (vectorize) goto unknown; - uv = (args) ? va_arg(*args, int) : SvIVx(argsv); + uv = (args) ? va_arg(*args, int) : SvIV(argsv); if ((uv > 255 || (!UNI_IS_INVARIANT(uv) && SvUTF8(sv))) && !IN_BYTES) { @@ -8859,7 +8913,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } else { - eptr = SvPVx_const(argsv, elen); + eptr = SvPV_const(argsv, elen); if (DO_UTF8(argsv)) { I32 old_precis = precis; if (has_precis && precis < elen) { @@ -8931,7 +8985,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } else { - IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */ + IV tiv = SvIV(argsv); /* work around GCC bug #13488 */ switch (intsize) { case 'h': iv = (short)tiv; break; case 'l': iv = (long)tiv; break; @@ -9016,7 +9070,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } else { - UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */ + UV tuv = SvUV(argsv); /* work around GCC bug #13488 */ switch (intsize) { case 'h': uv = (unsigned short)tuv; break; case 'l': uv = (unsigned long)tuv; break; @@ -9138,7 +9192,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV #else va_arg(*args, double) #endif - : SvNVx(argsv); + : SvNV(argsv); need = 0; if (c != 'e' && c != 'E') { @@ -9528,9 +9582,47 @@ Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param) parser->multi_close = proto->multi_close; parser->multi_open = proto->multi_open; parser->multi_start = proto->multi_start; + parser->multi_end = proto->multi_end; parser->pending_ident = proto->pending_ident; parser->preambled = proto->preambled; parser->sublex_info = proto->sublex_info; /* XXX not quite right */ + parser->linestr = sv_dup_inc(proto->linestr, param); + parser->expect = proto->expect; + parser->copline = proto->copline; + parser->last_lop_op = proto->last_lop_op; + parser->lex_state = proto->lex_state; + parser->rsfp = fp_dup(proto->rsfp, '<', param); + /* rsfp_filters entries have fake IoDIRP() */ + parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param); + parser->in_my = proto->in_my; + parser->in_my_stash = hv_dup(proto->in_my_stash, param); + parser->error_count = proto->error_count; + + + parser->linestr = sv_dup_inc(proto->linestr, param); + + { + char * const ols = SvPVX(proto->linestr); + char * const ls = SvPVX(parser->linestr); + + parser->bufptr = ls + (proto->bufptr >= ols ? + proto->bufptr - ols : 0); + parser->oldbufptr = ls + (proto->oldbufptr >= ols ? + proto->oldbufptr - ols : 0); + parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ? + proto->oldoldbufptr - ols : 0); + parser->linestart = ls + (proto->linestart >= ols ? + proto->linestart - ols : 0); + parser->last_uni = ls + (proto->last_uni >= ols ? + proto->last_uni - ols : 0); + parser->last_lop = ls + (proto->last_lop >= ols ? + proto->last_lop - ols : 0); + + parser->bufend = ls + SvCUR(parser->linestr); + } + + Copy(proto->tokenbuf, parser->tokenbuf, 256, char); + #ifdef PERL_MAD parser->endwhite = proto->endwhite; @@ -9545,6 +9637,13 @@ Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param) parser->thisstuff = proto->thisstuff; parser->thistoken = proto->thistoken; parser->thiswhite = proto->thiswhite; + + Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE); + parser->curforce = proto->curforce; +#else + Copy(proto->nextval, parser->nextval, 5, YYSTYPE); + Copy(proto->nexttype, parser->nexttype, 5, I32); + parser->nexttoke = proto->nexttoke; #endif return parser; } @@ -9651,9 +9750,6 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) 1. */ nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param)); } - else if (mg->mg_type == PERL_MAGIC_symtab) { - nmg->mg_obj = mg->mg_obj; - } else { nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED) ? sv_dup_inc(mg->mg_obj, param) @@ -10060,7 +10156,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) IoOFP(dstr) = IoIFP(dstr); else IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param); - /* PL_rsfp_filters entries have fake IoDIRP() */ + /* PL_parser->rsfp_filters entries have fake IoDIRP() */ if(IoFLAGS(dstr) & IOf_FAKE_DIRP) { /* I have no idea why fake dirp (rsfps) should be treated differently but otherwise @@ -10148,6 +10244,11 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) ? (AV*) SvREFCNT_inc( sv_dup((SV*)saux->xhv_backreferences, param)) : 0; + + daux->xhv_mro_meta = saux->xhv_mro_meta + ? mro_meta_dup(saux->xhv_mro_meta, param) + : 0; + /* Record stashes for possible cloning in Perl_clone(). */ if (hvname) av_push(param->stashes, dstr); @@ -10368,9 +10469,9 @@ ANY * Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) { dVAR; - ANY * const ss = proto_perl->Tsavestack; - const I32 max = proto_perl->Tsavestack_max; - I32 ix = proto_perl->Tsavestack_ix; + ANY * const ss = proto_perl->Isavestack; + const I32 max = proto_perl->Isavestack_max; + I32 ix = proto_perl->Isavestack_ix; ANY *nss; SV *sv; GV *gv; @@ -10615,10 +10716,9 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) = pv_dup(old_state->re_state_reginput); new_state->re_state_regeol = pv_dup(old_state->re_state_regeol); - new_state->re_state_regstartp - = (I32*) any_dup(old_state->re_state_regstartp, proto_perl); - new_state->re_state_regendp - = (I32*) any_dup(old_state->re_state_regendp, proto_perl); + new_state->re_state_regoffs + = (regexp_paren_pair*) + any_dup(old_state->re_state_regoffs, proto_perl); new_state->re_state_reglastparen = (U32*) any_dup(old_state->re_state_reglastparen, proto_perl); @@ -10807,6 +10907,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_savestack_ix = 0; PL_savestack_max = -1; PL_sig_pending = 0; + PL_parser = NULL; Zero(&PL_debug_pad, 1, struct perl_debug_pad); # else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); @@ -10841,6 +10942,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_savestack_ix = 0; PL_savestack_max = -1; PL_sig_pending = 0; + PL_parser = NULL; Zero(&PL_debug_pad, 1, struct perl_debug_pad); # else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); @@ -10927,7 +11029,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_compiling.cop_hints_hash->refcounted_he_refcnt++; HINTS_REFCNT_UNLOCK; } - PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl); + PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl); +#ifdef PERL_DEBUG_READONLY_OPS + PL_slabs = NULL; + PL_slab_count = 0; +#endif /* pseudo environmental stuff */ PL_origargc = proto_perl->Iorigargc; @@ -11042,13 +11148,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_DBsingle = sv_dup(proto_perl->IDBsingle, param); PL_DBtrace = sv_dup(proto_perl->IDBtrace, param); PL_DBsignal = sv_dup(proto_perl->IDBsignal, param); - PL_DBassertion = sv_dup(proto_perl->IDBassertion, param); - PL_lineary = av_dup(proto_perl->Ilineary, param); PL_dbargs = av_dup(proto_perl->Idbargs, param); /* symbol tables */ - PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param); - PL_curstash = hv_dup(proto_perl->Tcurstash, param); + PL_defstash = hv_dup_inc(proto_perl->Idefstash, param); + PL_curstash = hv_dup(proto_perl->Icurstash, param); PL_debstash = hv_dup(proto_perl->Idebstash, param); PL_globalstash = hv_dup(proto_perl->Iglobalstash, param); PL_curstname = sv_dup_inc(proto_perl->Icurstname, param); @@ -11063,6 +11167,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_initav = av_dup_inc(proto_perl->Iinitav, param); PL_sub_generation = proto_perl->Isub_generation; + PL_isarev = hv_dup_inc(proto_perl->Iisarev, param); + PL_delayedisa = hv_dup_inc(proto_perl->Idelayedisa, param); /* funky return mechanisms */ PL_forkprocess = proto_perl->Iforkprocess; @@ -11089,7 +11195,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* runtime control stuff */ 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; @@ -11133,9 +11238,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param); PL_profiledata = NULL; - PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param); - /* PL_rsfp_filters entries have fake IoDIRP() */ - PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param); PL_compcv = cv_dup(proto_perl->Icompcv, param); @@ -11169,8 +11271,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_runops = proto_perl->Irunops; - Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); - #ifdef CSH PL_cshlen = proto_perl->Icshlen; PL_cshname = proto_perl->Icshname; /* XXX never deallocated */ @@ -11178,43 +11278,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_parser = parser_dup(proto_perl->Iparser, param); - PL_lex_state = proto_perl->Ilex_state; - -#ifdef PERL_MAD - Copy(proto_perl->Inexttoke, PL_nexttoke, 5, NEXTTOKE); - PL_curforce = proto_perl->Icurforce; -#else - Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE); - Copy(proto_perl->Inexttype, PL_nexttype, 5, I32); - PL_nexttoke = proto_perl->Inexttoke; -#endif - - PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param); - i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr); - PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr); - PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr); - PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr); - PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - - PL_expect = proto_perl->Iexpect; - - PL_multi_end = proto_perl->Imulti_end; - - PL_error_count = proto_perl->Ierror_count; PL_subline = proto_perl->Isubline; PL_subname = sv_dup_inc(proto_perl->Isubname, param); - i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr); - PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ilast_lop - SvPVX_const(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, param); #ifdef FCRYPT PL_cryptseen = proto_perl->Icryptseen; #endif @@ -11287,9 +11353,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_unlockhook = proto_perl->Iunlockhook; PL_threadhook = proto_perl->Ithreadhook; - PL_runops_std = proto_perl->Irunops_std; - PL_runops_dbg = proto_perl->Irunops_dbg; - #ifdef THREADS_HAVE_PIDS PL_ppid = proto_perl->Ippid; #endif @@ -11303,7 +11366,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_glob_index = proto_perl->Iglob_index; PL_srand_called = proto_perl->Isrand_called; - PL_uudmap[(U32) 'M'] = 0; /* reinits on demand */ PL_bitcount = NULL; /* reinits on demand */ if (proto_perl->Ipsig_pend) { @@ -11326,54 +11388,54 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_psig_name = (SV**)NULL; } - /* thrdvar.h stuff */ + /* intrpvar.h stuff */ if (flags & CLONEf_COPY_STACKS) { /* 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; + PL_tmps_ix = proto_perl->Itmps_ix; + PL_tmps_max = proto_perl->Itmps_max; + PL_tmps_floor = proto_perl->Itmps_floor; Newxz(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], param); + PL_tmps_stack[i] = sv_dup_inc(proto_perl->Itmps_stack[i], param); ++i; } /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ - i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack; + i = proto_perl->Imarkstack_max - proto_perl->Imarkstack; Newxz(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_max = PL_markstack + (proto_perl->Imarkstack_max + - proto_perl->Imarkstack); + PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr + - proto_perl->Imarkstack); + Copy(proto_perl->Imarkstack, 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; + PL_scopestack_ix = proto_perl->Iscopestack_ix; + PL_scopestack_max = proto_perl->Iscopestack_max; Newxz(PL_scopestack, PL_scopestack_max, I32); - Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32); + Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32); /* NOTE: si_dup() looks at PL_markstack */ - PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param); + PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param); /* PL_curstack = PL_curstackinfo->si_stack; */ - PL_curstack = av_dup(proto_perl->Tcurstack, param); - PL_mainstack = av_dup(proto_perl->Tmainstack, param); + PL_curstack = av_dup(proto_perl->Icurstack, param); + PL_mainstack = av_dup(proto_perl->Imainstack, param); /* 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_sp = PL_stack_base + (proto_perl->Istack_sp + - proto_perl->Istack_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; + PL_savestack_ix = proto_perl->Isavestack_ix; + PL_savestack_max = proto_perl->Isavestack_max; /*Newxz(PL_savestack, PL_savestack_max, ANY);*/ PL_savestack = ss_dup(proto_perl, param); } @@ -11386,9 +11448,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, * non-refcount means (eg a temp in @_); otherwise they will be * orphaned */ - for (i = 0; i<= proto_perl->Ttmps_ix; i++) { + for (i = 0; i<= proto_perl->Itmps_ix; i++) { SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table, - proto_perl->Ttmps_stack[i]); + proto_perl->Itmps_stack[i]); if (nsv && !SvREFCNT(nsv)) { EXTEND_MORTAL(1); PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv); @@ -11396,50 +11458,50 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } } - PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ + PL_start_env = proto_perl->Istart_env; /* XXXXXX */ PL_top_env = &PL_start_env; - PL_op = proto_perl->Top; + PL_op = proto_perl->Iop; PL_Sv = NULL; PL_Xpv = (XPV*)NULL; - PL_na = proto_perl->Tna; + PL_na = proto_perl->Ina; - PL_statbuf = proto_perl->Tstatbuf; - PL_statcache = proto_perl->Tstatcache; - PL_statgv = gv_dup(proto_perl->Tstatgv, param); - PL_statname = sv_dup_inc(proto_perl->Tstatname, param); + PL_statbuf = proto_perl->Istatbuf; + PL_statcache = proto_perl->Istatcache; + PL_statgv = gv_dup(proto_perl->Istatgv, param); + PL_statname = sv_dup_inc(proto_perl->Istatname, param); #ifdef HAS_TIMES - PL_timesbuf = proto_perl->Ttimesbuf; + PL_timesbuf = proto_perl->Itimesbuf; #endif - PL_tainted = proto_perl->Ttainted; - PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */ - PL_rs = sv_dup_inc(proto_perl->Trs, param); - PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param); - PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param); - PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param); - PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */ - PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param); - PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param); - PL_formtarget = sv_dup(proto_perl->Tformtarget, param); - - 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_errors = sv_dup_inc(proto_perl->Terrors, param); + PL_tainted = proto_perl->Itainted; + PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */ + PL_rs = sv_dup_inc(proto_perl->Irs, param); + PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param); + PL_ofs_sv = sv_dup_inc(proto_perl->Iofs_sv, param); + PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param); + PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */ + PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param); + PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param); + PL_formtarget = sv_dup(proto_perl->Iformtarget, param); + + PL_restartop = proto_perl->Irestartop; + PL_in_eval = proto_perl->Iin_eval; + PL_delaymagic = proto_perl->Idelaymagic; + PL_dirty = proto_perl->Idirty; + PL_localizing = proto_perl->Ilocalizing; + + PL_errors = sv_dup_inc(proto_perl->Ierrors, param); PL_hv_fetch_ent_mh = NULL; - PL_modcount = proto_perl->Tmodcount; + PL_modcount = proto_perl->Imodcount; PL_lastgotoprobe = NULL; - PL_dumpindent = proto_perl->Tdumpindent; + PL_dumpindent = proto_perl->Idumpindent; - PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl); - PL_sortstash = hv_dup(proto_perl->Tsortstash, param); - PL_firstgv = gv_dup(proto_perl->Tfirstgv, param); - PL_secondgv = gv_dup(proto_perl->Tsecondgv, param); + PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl); + PL_sortstash = hv_dup(proto_perl->Isortstash, param); + PL_firstgv = gv_dup(proto_perl->Ifirstgv, param); + PL_secondgv = gv_dup(proto_perl->Isecondgv, param); PL_efloatbuf = NULL; /* reinits on demand */ PL_efloatsize = 0; /* reinits on demand */ @@ -11450,20 +11512,28 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_maxscream = -1; /* reinits on demand */ PL_lastscream = NULL; - PL_watchaddr = NULL; - PL_watchok = NULL; - PL_regdummy = proto_perl->Tregdummy; + PL_regdummy = proto_perl->Iregdummy; PL_colorset = 0; /* reinits PL_colors[] */ /*PL_colors[6] = {0,0,0,0,0,0};*/ /* Pluggable optimizer */ - PL_peepp = proto_perl->Tpeepp; + PL_peepp = proto_perl->Ipeepp; PL_stashcache = newHV(); + PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table, + proto_perl->Iwatchaddr); + PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL; + if (PL_debug && PL_watchaddr) { + PerlIO_printf(Perl_debug_log, + "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n", + PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr), + PTR2UV(PL_watchok)); + } + if (!(flags & CLONEf_KEEP_PTR_TABLE)) { ptr_table_free(PL_ptr_table); PL_ptr_table = NULL; @@ -11715,8 +11785,7 @@ S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, } } else { - U32 unused; - CV * const cv = find_runcv(&unused); + CV * const cv = find_runcv(NULL); SV *sv; AV *av; @@ -11996,6 +12065,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) case OP_PRTF: case OP_PRINT: + case OP_SAY: /* skip filehandle as it can't produce 'undef' warning */ o = cUNOPx(obase)->op_first; if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)