X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/10edeb5d2457364a70a6848a864cfa6b89dfc882..4848a83b92f23f5ce46f82d3a4743a4c6dfbf2da:/sv.c diff --git a/sv.c b/sv.c index 146d9e7..33cdb52 100644 --- a/sv.c +++ b/sv.c @@ -1,7 +1,7 @@ /* sv.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -704,7 +704,7 @@ Perl_get_arena(pTHX_ int arena_size) Newxz(adesc->arena, arena_size, char); adesc->size = arena_size; DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %d\n", - curr, adesc->arena, arena_size)); + curr, (void*)adesc->arena, arena_size)); return adesc->arena; } @@ -887,6 +887,11 @@ static const struct body_details bodies_by_type[] = { { sizeof(HE), 0, 0, SVt_NULL, 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 + implemented. */ + { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 }, + /* IVs are in the head, so the allocation size is 0. However, the slot is overloaded for PTEs. */ { sizeof(struct ptr_tbl_ent), /* This is used for PTEs. */ @@ -926,10 +931,6 @@ static const struct body_details bodies_by_type[] = { { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, - /* 36 */ - { sizeof(XPVBM), sizeof(XPVBM), 0, SVt_PVBM, TRUE, HADNV, - HASARENA, FIT_ARENA(0, sizeof(XPVBM)) }, - /* 48 */ { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVGV)) }, @@ -1068,7 +1069,7 @@ S_more_bodies (pTHX_ svtype sv_type) /* computed count doesnt reflect the 1st slot reservation */ DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %p end %p arena-size %d type %d size %d ct %d\n", - start, end, + (void*)start, (void*)end, (int)bdp->arena_size, sv_type, (int)body_size, (int)bdp->arena_size / (int)body_size)); @@ -1092,8 +1093,8 @@ S_more_bodies (pTHX_ svtype sv_type) STMT_START { \ void ** const r3wt = &PL_body_roots[sv_type]; \ LOCK_SV_MUTEX; \ - xpv = *((void **)(r3wt)) \ - ? *((void **)(r3wt)) : more_bodies(sv_type); \ + xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ + ? *((void **)(r3wt)) : more_bodies(sv_type)); \ *(r3wt) = *(void**)(xpv); \ UNLOCK_SV_MUTEX; \ } STMT_END @@ -1177,7 +1178,9 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) (In fact, GP ends up pointing at a previous GP structure, because the principle cause of the padding in XPVMG getting garbage is a copy of - sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob) + sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now + this happens to be moot because XPVGV has been re-ordered, with GP + no longer after STASH) So we are careful and work out the size of used parts of all the structures. */ @@ -1277,13 +1280,11 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) assert(SvPVX_const(sv) == 0); } - /* Could put this in the else clause below, as PVMG must have SvPVX - 0 already (the assertion above) */ - SvPV_set(sv, NULL); - if (old_type >= SVt_PVMG) { SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic); SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); + } else { + sv->sv_u.svu_array = NULL; /* or svu_hash */ } break; @@ -1295,7 +1296,6 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) assert(!SvNOK(sv)); case SVt_PVIO: case SVt_PVFM: - case SVt_PVBM: case SVt_PVGV: case SVt_PVCV: case SVt_PVLV: @@ -1560,8 +1560,6 @@ Like C, but also handles 'set' magic. void Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) { - sv_setiv(sv, 0); - SvIsUV_on(sv); sv_setuv(sv,u); SvSETMAGIC(sv); } @@ -1851,6 +1849,7 @@ STATIC int S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) { dVAR; + PERL_UNUSED_ARG(numtype); /* Used only under DEBUGGING? */ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); if (SvNVX(sv) < (NV)IV_MIN) { (void)SvIOKp_on(sv); @@ -2162,7 +2161,11 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) dVAR; if (!sv) return 0; - if (SvGMAGICAL(sv)) { + if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) { + /* FBMs use the same flag bit as SVf_IVisUV, so must let them + cache IVs just in case. In practice it seems that they never + actually anywhere accessible by user Perl code, let alone get used + in anything other than a string context. */ if (flags & SV_GMAGIC) mg_get(sv); if (SvIOKp(sv)) @@ -2242,7 +2245,9 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) dVAR; if (!sv) return 0; - if (SvGMAGICAL(sv)) { + if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) { + /* FBMs use the same flag bit as SVf_IVisUV, so must let them + cache IVs just in case. */ if (flags & SV_GMAGIC) mg_get(sv); if (SvIOKp(sv)) @@ -2317,7 +2322,9 @@ Perl_sv_2nv(pTHX_ register SV *sv) dVAR; if (!sv) return 0.0; - if (SvGMAGICAL(sv)) { + if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) { + /* FBMs use the same flag bit as SVf_IVisUV, so must let them + cache IVs just in case. */ mg_get(sv); if (SvNOKp(sv)) return SvNVX(sv); @@ -2543,87 +2550,6 @@ S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) return ptr; } -/* stringify_regexp(): private routine for use by sv_2pv_flags(): converts - * a regexp to its stringified form. - */ - -static char * -S_stringify_regexp(pTHX_ SV *sv, MAGIC *mg, STRLEN *lp) { - dVAR; - const regexp * const re = (regexp *)mg->mg_obj; - - if (!mg->mg_ptr) { - const char *fptr = "msix"; - char reflags[6]; - char ch; - int left = 0; - int right = 4; - bool need_newline = 0; - U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12); - - while((ch = *fptr++)) { - if(reganch & 1) { - reflags[left++] = ch; - } - else { - reflags[right--] = ch; - } - reganch >>= 1; - } - if(left != 4) { - reflags[left] = '-'; - left = 5; - } - - mg->mg_len = re->prelen + 4 + left; - /* - * If /x was used, we have to worry about a regex ending with a - * comment later being embedded within another regex. If so, we don't - * want this regex's "commentization" to leak out to the right part of - * the enclosing regex, we must cap it with a newline. - * - * So, if /x was used, we scan backwards from the end of the regex. If - * we find a '#' before we find a newline, we need to add a newline - * ourself. If we find a '\n' first (or if we don't find '#' or '\n'), - * we don't need to add anything. -jfriedl - */ - if (PMf_EXTENDED & re->reganch) { - const char *endptr = re->precomp + re->prelen; - while (endptr >= re->precomp) { - const char c = *(endptr--); - if (c == '\n') - break; /* don't need another */ - if (c == '#') { - /* we end while in a comment, so we need a newline */ - mg->mg_len++; /* save space for it */ - need_newline = 1; /* note to add it */ - break; - } - } - } - - Newx(mg->mg_ptr, mg->mg_len + 1 + left, char); - mg->mg_ptr[0] = '('; - mg->mg_ptr[1] = '?'; - Copy(reflags, mg->mg_ptr+2, left, char); - *(mg->mg_ptr+left+2) = ':'; - Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char); - if (need_newline) - mg->mg_ptr[mg->mg_len - 2] = '\n'; - mg->mg_ptr[mg->mg_len - 1] = ')'; - mg->mg_ptr[mg->mg_len] = 0; - } - PL_reginterp_cnt += re->program[0].next_off; - - if (re->reganch & ROPT_UTF8) - SvUTF8_on(sv); - else - SvUTF8_off(sv); - if (lp) - *lp = mg->mg_len; - return mg->mg_ptr; -} - /* =for apidoc sv_2pv_flags @@ -2728,35 +2654,93 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } } { - SV *tsv; + STRLEN len; + char *retval; + char *buffer; MAGIC *mg; const SV *const referent = (SV*)SvRV(sv); if (!referent) { - tsv = sv_2mortal(newSVpvs("NULLREF")); + len = 7; + retval = buffer = savepvn("NULLREF", len); } else if (SvTYPE(referent) == SVt_PVMG && ((SvFLAGS(referent) & (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) == (SVs_OBJECT|SVs_SMG)) - && (mg = mg_find(referent, PERL_MAGIC_qr))) { - return stringify_regexp(sv, mg, lp); + && (mg = mg_find(referent, PERL_MAGIC_qr))) + { + char *str = NULL; + I32 haseval = 0; + U32 flags = 0; + (str) = CALLREG_AS_STR(mg,lp,&flags,&haseval); + if (flags & 1) + SvUTF8_on(sv); + else + SvUTF8_off(sv); + PL_reginterp_cnt += haseval; + return str; } else { const char *const typestr = sv_reftype(referent, 0); + const STRLEN typelen = strlen(typestr); + UV addr = PTR2UV(referent); + const char *stashname = NULL; + STRLEN stashnamelen = 0; /* hush, gcc */ + const char *buffer_end; - tsv = sv_newmortal(); if (SvOBJECT(referent)) { - const char *const name = HvNAME_get(SvSTASH(referent)); - Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")", - name ? name : "__ANON__" , typestr, - PTR2UV(referent)); + const HEK *const name = HvNAME_HEK(SvSTASH(referent)); + + if (name) { + stashname = HEK_KEY(name); + stashnamelen = HEK_LEN(name); + + if (HEK_UTF8(name)) { + SvUTF8_on(sv); + } else { + SvUTF8_off(sv); + } + } else { + stashname = "__ANON__"; + stashnamelen = 8; + } + len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */ + + 2 * sizeof(UV) + 2 /* )\0 */; + } else { + len = typelen + 3 /* (0x */ + + 2 * sizeof(UV) + 2 /* )\0 */; } - else - Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, - PTR2UV(referent)); + + Newx(buffer, len, char); + buffer_end = retval = buffer + len; + + /* Working backwards */ + *--retval = '\0'; + *--retval = ')'; + do { + *--retval = PL_hexdigit[addr & 15]; + } while (addr >>= 4); + *--retval = 'x'; + *--retval = '0'; + *--retval = '('; + + retval -= typelen; + memcpy(retval, typestr, typelen); + + if (stashname) { + *--retval = '='; + retval -= stashnamelen; + memcpy(retval, stashname, stashnamelen); + } + /* retval may not neccesarily have reached the start of the + buffer here. */ + assert (retval >= buffer); + + len = buffer_end - retval - 1; /* -1 for that \0 */ } if (lp) - *lp = SvCUR(tsv); - return SvPVX(tsv); + *lp = len; + SAVEFREEPV(buffer); + return retval; } } if (SvREADONLY(sv) && !SvOK(sv)) { @@ -2770,7 +2754,6 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) { /* I'm assuming that if both IV and NV are equally valid then converting the IV is going to be more efficient */ - const U32 isIOK = SvIOK(sv); const U32 isUIOK = SvIsUV(sv); char buf[TYPE_CHARS(UV)]; char *ebuf, *ptr; @@ -2784,12 +2767,6 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) SvCUR_set(sv, ebuf - ptr); s = SvEND(sv); *s = '\0'; - if (isIOK) - SvIOK_on(sv); - else - SvIOKp_on(sv); - if (isUIOK) - SvIsUV_on(sv); } else if (SvNOKp(sv)) { const int olderrno = errno; @@ -3204,7 +3181,9 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) } sv_upgrade(dstr, SVt_PVGV); (void)SvOK_off(dstr); - SvSCREAM_on(dstr); + /* FIXME - why are we doing this, then turning it off and on again + below? */ + isGV_with_GP_on(dstr); } GvSTASH(dstr) = GvSTASH(sstr); if (GvSTASH(dstr)) @@ -3220,9 +3199,9 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) #endif gp_free((GV*)dstr); - SvSCREAM_off(dstr); + isGV_with_GP_off(dstr); (void)SvOK_off(dstr); - SvSCREAM_on(dstr); + isGV_with_GP_on(dstr); GvINTRO_off(dstr); /* one-shot flag */ GvGP(dstr) = gp_ref(GvGP(sstr)); if (SvTAINTED(sstr)) @@ -3357,9 +3336,18 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (sstr == dstr) return; + + if (SvIS_FREED(dstr)) { + Perl_croak(aTHX_ "panic: attempt to copy value %" SVf + " to a freed scalar %p", SVfARG(sstr), (void *)dstr); + } SV_CHECK_THINKFIRST_COW_DROP(dstr); if (!sstr) sstr = &PL_sv_undef; + if (SvIS_FREED(sstr)) { + Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", + (void*)sstr, (void*)dstr); + } stype = SvTYPE(sstr); dtype = SvTYPE(dstr); @@ -3392,6 +3380,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) case SVt_PV: sv_upgrade(dstr, SVt_PVIV); break; + case SVt_PVGV: + goto end_of_first_switch; } (void)SvIOK_only(dstr); SvIV_set(dstr, SvIVX(sstr)); @@ -3418,6 +3408,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) case SVt_PVIV: sv_upgrade(dstr, SVt_PVNV); break; + case SVt_PVGV: + goto end_of_first_switch; } SvNV_set(dstr, SvNVX(sstr)); (void)SvNOK_only(dstr); @@ -3465,21 +3457,22 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } break; + /* case SVt_BIND: */ case SVt_PVGV: - if (dtype <= SVt_PVGV) { + if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) { glob_assign_glob(dstr, sstr, dtype); return; } + /* SvVALID means that this PVGV is playing at being an FBM. */ /*FALLTHROUGH*/ case SVt_PVMG: case SVt_PVLV: - case SVt_PVBM: if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) { mg_get(sstr); - if ((int)SvTYPE(sstr) != stype) { + if (SvTYPE(sstr) != stype) { stype = SvTYPE(sstr); - if (stype == SVt_PVGV && dtype <= SVt_PVGV) { + if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) { glob_assign_glob(dstr, sstr, dtype); return; } @@ -3490,14 +3483,35 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) else SvUPGRADE(dstr, (svtype)stype); } + end_of_first_switch: /* dstr may have been upgraded. */ dtype = SvTYPE(dstr); sflags = SvFLAGS(sstr); - if (sflags & SVf_ROK) { - if (dtype == SVt_PVGV && - SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) { + if (dtype == SVt_PVCV || dtype == SVt_PVFM) { + /* Assigning to a subroutine sets the prototype. */ + if (SvOK(sstr)) { + STRLEN len; + const char *const ptr = SvPV_const(sstr, len); + + SvGROW(dstr, len + 1); + Copy(ptr, SvPVX(dstr), len + 1, char); + SvCUR_set(dstr, len); + SvPOK_only(dstr); + SvFLAGS(dstr) |= sflags & SVf_UTF8; + } else { + SvOK_off(dstr); + } + } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) { + const char * const type = sv_reftype(dstr,0); + if (PL_op) + Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op)); + else + Perl_croak(aTHX_ "Cannot copy to %s", type); + } else if (sflags & SVf_ROK) { + if (isGV_with_GP(dstr) && dtype == SVt_PVGV + && SvTYPE(SvRV(sstr)) == SVt_PVGV) { sstr = SvRV(sstr); if (sstr == dstr) { if (GvIMPORTED(dstr) != GVf_IMPORTED @@ -3525,13 +3539,13 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } (void)SvOK_off(dstr); SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr))); - SvFLAGS(dstr) |= sflags & (SVf_ROK|SVf_AMAGIC); + SvFLAGS(dstr) |= sflags & SVf_ROK; assert(!(sflags & SVp_NOK)); assert(!(sflags & SVp_IOK)); assert(!(sflags & SVf_NOK)); assert(!(sflags & SVf_IOK)); } - else if (dtype == SVt_PVGV) { + else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) { if (!(sflags & SVf_OK)) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), @@ -3554,6 +3568,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) * possible small lose on short strings, but a big win on long ones. * It might even be a win on short strings if SvPVX_const(dstr) * has to be allocated and SvPVX_const(sstr) has to be freed. + * Likewise if we can set up COW rather than doing an actual copy, we + * drop to the else clause, as the swipe code and the COW setup code + * have much in common. */ /* Whichever path we take through the next code, we want this true, @@ -3561,10 +3578,28 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) (void)SvPOK_only(dstr); if ( - /* We're not already COW */ - ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY) + /* If we're already COW then this clause is not true, and if COW + is allowed then we drop down to the else and make dest COW + with us. If caller hasn't said that we're allowed to COW + shared hash keys then we don't do the COW setup, even if the + source scalar is a shared hash key scalar. */ + (((flags & SV_COW_SHARED_HASH_KEYS) + ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY) + : 1 /* If making a COW copy is forbidden then the behaviour we + desire is as if the source SV isn't actually already + COW, even if it is. So we act as if the source flags + are not COW, rather than actually testing them. */ + ) #ifndef PERL_OLD_COPY_ON_WRITE - /* or we are, but dstr isn't a suitable target. */ + /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic + when PERL_OLD_COPY_ON_WRITE is defined a little wrong. + Conceptually PERL_OLD_COPY_ON_WRITE being defined should + override SV_COW_SHARED_HASH_KEYS, because it means "always COW" + but in turn, it's somewhat dead code, never expected to go + live, but more kept as a placeholder on how to do it better + in a newer implementation. */ + /* If we are COW and dstr is a suitable target then we drop down + into the else and make dest a COW of us. */ || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS #endif ) @@ -3678,8 +3713,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } - SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8 - |SVf_AMAGIC); + SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8); { const MAGIC * const smg = SvVSTRING_mg(sstr); if (smg) { @@ -3691,8 +3725,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } else if (sflags & (SVp_IOK|SVp_NOK)) { (void)SvOK_off(dstr); - SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK - |SVf_AMAGIC); + SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK); if (sflags & SVp_IOK) { /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ SvIV_set(dstr, SvIVX(sstr)); @@ -3712,7 +3745,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvFAKE_off(sstr); gv_efullname3(dstr, (GV *)sstr, "*"); SvFLAGS(sstr) |= wasfake; - SvFLAGS(dstr) |= sflags & SVf_AMAGIC; } else (void)SvOK_off(dstr); @@ -3746,7 +3778,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n", - sstr, dstr); + (void*)sstr, (void*)dstr); sv_dump(sstr); if (dstr) sv_dump(dstr); @@ -4335,7 +4367,7 @@ to contain an C and is stored as-is with its REFCNT incremented. =cut */ MAGIC * -Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, +Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, const char* name, I32 namlen) { dVAR; @@ -4397,7 +4429,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, else mg->mg_ptr = (char *) name; } - mg->mg_virtual = vtable; + mg->mg_virtual = (MGVTBL *) vtable; mg_magical(sv); if (SvGMAGICAL(sv)) @@ -4424,7 +4456,7 @@ void Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen) { dVAR; - MGVTBL *vtable; + const MGVTBL *vtable; MAGIC* mg; #ifdef PERL_OLD_COPY_ON_WRITE @@ -5084,14 +5116,15 @@ Perl_sv_clear(pTHX_ register SV *sv) } } if (type >= SVt_PVMG) { - if ((type == SVt_PVMG || type == SVt_PVGV) && SvPAD_OUR(sv)) { - SvREFCNT_dec(OURSTASH(sv)); + if (type == SVt_PVMG && SvPAD_OUR(sv)) { + SvREFCNT_dec(SvOURSTASH(sv)); } else if (SvMAGIC(sv)) mg_free(sv); if (type == SVt_PVMG && SvPAD_TYPED(sv)) SvREFCNT_dec(SvSTASH(sv)); } switch (type) { + /* case SVt_BIND: */ case SVt_PVIO: if (IoIFP(sv) && IoIFP(sv) != PerlIO_stdin() && @@ -5107,8 +5140,6 @@ Perl_sv_clear(pTHX_ register SV *sv) Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); goto freescalar; - case SVt_PVBM: - goto freescalar; case SVt_PVCV: case SVt_PVFM: cv_undef((CV*)sv); @@ -5130,14 +5161,15 @@ Perl_sv_clear(pTHX_ register SV *sv) SvREFCNT_dec(LvTARG(sv)); goto freescalar; case SVt_PVGV: - gp_free((GV*)sv); - if (GvNAME_HEK(sv)) { - unshare_hek(GvNAME_HEK(sv)); - } + if (isGV_with_GP(sv)) { + 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 (GvSTASH(sv)) - sv_del_backref((SV*)GvSTASH(sv), sv); + if (!SvVALID(sv) && GvSTASH(sv)) + sv_del_backref((SV*)GvSTASH(sv), sv); + } case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: @@ -5352,9 +5384,9 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) */ SAVEI8(PL_utf8cache); PL_utf8cache = 0; - Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVf - " real %"UVf" for %"SVf, - (UV) ulen, (UV) real, (void*)sv); + Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf + " real %"UVuf" for %"SVf, + (UV) ulen, (UV) real, SVfARG(sv)); } } } @@ -5510,9 +5542,9 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, infinitely while printing error messages. */ SAVEI8(PL_utf8cache); PL_utf8cache = 0; - Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVf - " real %"UVf" for %"SVf, - (UV) boffset, (UV) real_boffset, (void*)sv); + Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf + " real %"UVuf" for %"SVf, + (UV) boffset, (UV) real_boffset, SVfARG(sv)); } } boffset = real_boffset; @@ -5626,26 +5658,15 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8, if (PL_utf8cache < 0) { const U8 *start = (const U8 *) SvPVX_const(sv); - const U8 *const end = start + byte; - STRLEN realutf8 = 0; - - while (start < end) { - start += UTF8SKIP(start); - realutf8++; - } - - /* Can't use S_sv_pos_b2u_forwards as it will scream warnings on - surrogates. FIXME - is it inconsistent that b2u warns, but u2b - doesn't? I don't know whether this difference was introduced with - the caching code in 5.8.1. */ + const STRLEN realutf8 = utf8_length(start, start + byte); if (realutf8 != utf8) { /* Need to turn the assertions off otherwise we may recurse infinitely while printing error messages. */ SAVEI8(PL_utf8cache); PL_utf8cache = 0; - Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVf - " real %"UVf" for %"SVf, (UV) utf8, (UV) realutf8, (void*)sv); + Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf + " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv)); } } @@ -5748,29 +5769,6 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8, ASSERT_UTF8_CACHE(cache); } -/* If we don't know the character offset of the end of a region, our only - option is to walk forwards to the target byte offset. */ -static STRLEN -S_sv_pos_b2u_forwards(pTHX_ const U8 *s, const U8 *const target) -{ - STRLEN len = 0; - while (s < target) { - STRLEN n = 1; - - /* Call utf8n_to_uvchr() to validate the sequence - * (unless a simple non-UTF character) */ - if (!UTF8_IS_INVARIANT(*s)) - utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0); - if (n > 0) { - s += n; - len++; - } - else - break; - } - return len; -} - /* We already know all of the way, now we may be able to walk back. The same assumption is made as in S_sv_pos_u2b_midway(), namely that walking backward is half the speed of walking forward. */ @@ -5782,7 +5780,7 @@ S_sv_pos_b2u_midway(pTHX_ const U8 *s, const U8 *const target, const U8 *end, STRLEN backw = end - target; if (forw < 2 * backw) { - return S_sv_pos_b2u_forwards(aTHX_ s, target); + return utf8_length(s, target); } while (end > target) { @@ -5855,8 +5853,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send, s + blen, mg->mg_len - cache[0]); } else { - len = cache[0] - + S_sv_pos_b2u_forwards(aTHX_ s + cache[1], send); + len = cache[0] + utf8_length(s + cache[1], send); } } else if (cache[3] < byte) { @@ -5882,7 +5879,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) } } if (!found || PL_utf8cache < 0) { - const STRLEN real_len = S_sv_pos_b2u_forwards(aTHX_ s, send); + const STRLEN real_len = utf8_length(s, send); if (found && PL_utf8cache < 0) { if (len != real_len) { @@ -5890,9 +5887,9 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) infinitely while printing error messages. */ SAVEI8(PL_utf8cache); PL_utf8cache = 0; - Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVf - " real %"UVf" for %"SVf, - (UV) len, (UV) real_len, (void*)sv); + Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf + " real %"UVuf" for %"SVf, + (UV) len, (UV) real_len, SVfARG(sv)); } } len = real_len; @@ -5928,8 +5925,16 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) pv1 = ""; cur1 = 0; } - else + else { + /* if pv1 and pv2 are the same, second SvPV_const call may + * invalidate pv1, so we may need to make a copy */ + if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) { + pv1 = SvPV_const(sv1, cur1); + sv1 = sv_2mortal(newSVpvn(pv1, cur1)); + if (SvUTF8(sv2)) SvUTF8_on(sv1); + } pv1 = SvPV_const(sv1, cur1); + } if (!sv2){ pv2 = ""; @@ -6925,7 +6930,7 @@ Perl_newSVpv(pTHX_ const char *s, STRLEN len) register SV *sv; new_SV(sv); - sv_setpvn(sv,s,len ? len : strlen(s)); + sv_setpvn(sv, s, len || s == NULL ? len : strlen(s)); return sv; } @@ -7378,7 +7383,7 @@ Perl_sv_2io(pTHX_ SV *sv) else io = 0; if (!io) - Perl_croak(aTHX_ "Bad filehandle: %"SVf, (void*)sv); + Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv)); break; } return io; @@ -7470,7 +7475,7 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) LEAVE; if (!GvCVu(gv)) Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"", - (void*)sv); + SVfARG(sv)); } return GvCVu(gv); } @@ -7622,7 +7627,7 @@ Returns a string describing what the SV is a reference to. =cut */ -char * +const char * Perl_sv_reftype(pTHX_ const SV *sv, int ob) { /* The fact that I don't need to downcast to char * everywhere, only in ?: @@ -7641,7 +7646,6 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob) case SVt_PVIV: case SVt_PVNV: case SVt_PVMG: - case SVt_PVBM: if (SvVOK(sv)) return "VSTRING"; if (SvROK(sv)) @@ -7660,6 +7664,7 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob) case SVt_PVGV: return "GLOB"; case SVt_PVFM: return "FORMAT"; case SVt_PVIO: return "IO"; + case SVt_BIND: return "BIND"; default: return "UNKNOWN"; } } @@ -7951,7 +7956,7 @@ S_sv_unglob(pTHX_ SV *sv) if (GvNAME_HEK(sv)) { unshare_hek(GvNAME_HEK(sv)); } - SvSCREAM_off(sv); + isGV_with_GP_off(sv); /* need to keep SvANY(sv) in the right arena */ xpvmg = new_XPVMG(); @@ -8406,7 +8411,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } if (args && patlen == 3 && pat[0] == '%' && pat[1] == '-' && pat[2] == 'p') { - argsv = va_arg(*args, SV*); + argsv = (SV*)va_arg(*args, void*); sv_catsv(sv, argsv); return; } @@ -8562,7 +8567,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV precis = n; has_precis = TRUE; } - argsv = va_arg(*args, SV*); + argsv = (SV*)va_arg(*args, void*); eptr = SvPVx_const(argsv, elen); if (DO_UTF8(argsv)) is_utf8 = TRUE; @@ -8599,7 +8604,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV switch (*q) { case ' ': case '+': - plus = *q++; + if (plus == '+' && *q == ' ') /* '+' over ' ' */ + q++; + else + plus = *q++; continue; case '-': @@ -8736,14 +8744,15 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV else i = (ewix ? ewix <= svmax : svix < svmax) ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0; - precis = (i < 0) ? 0 : i; + precis = i; + has_precis = !(i < 0); } else { precis = 0; while (isDIGIT(*q)) precis = precis * 10 + (*q++ - '0'); + has_precis = TRUE; } - has_precis = TRUE; } /* SIZE */ @@ -8859,13 +8868,17 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV else { eptr = SvPVx_const(argsv, elen); if (DO_UTF8(argsv)) { + I32 old_precis = precis; if (has_precis && precis < elen) { I32 p = precis; sv_pos_u2b(argsv, &p, 0); /* sticks at end */ precis = p; } if (width) { /* fudge width (can't fudge elen) */ - width += elen - sv_len_utf8(argsv); + if (has_precis && precis < elen) + width += precis - old_precis; + else + width += elen - sv_len_utf8(argsv); } is_utf8 = TRUE; } @@ -8962,6 +8975,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV base = 10; goto uns_integer; + case 'B': case 'b': base = 2; goto uns_integer; @@ -9030,8 +9044,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV switch (base) { unsigned dig; case 16: - p = (char*)((c == 'X') - ? "0123456789ABCDEF" : "0123456789abcdef"); + p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit); do { dig = uv & 15; *--ptr = p[dig]; @@ -9056,7 +9069,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } while (uv >>= 1); if (tempalt) { esignbuf[esignlen++] = '0'; - esignbuf[esignlen++] = 'b'; + esignbuf[esignlen++] = c; } break; default: /* it had better be ten or less */ @@ -9071,8 +9084,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (has_precis) { if (precis > elen) zeros = precis - elen; - else if (precis == 0 && elen == 1 && *eptr == '0') + else if (precis == 0 && elen == 1 && *eptr == '0' + && !(base == 8 && alt)) /* "%#.0o" prints "0" */ elen = 0; + + /* a precision nullifies the 0 flag. */ + if (fill == '0') + fill = ' '; } } break; @@ -9326,7 +9344,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV (UV)c & 0xFF); } else sv_catpvs(msg, "end of string"); - Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, (void*)msg); /* yes, this is reentrant */ + Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */ } /* output mangled stuff ... */ @@ -9450,8 +9468,8 @@ ptr_table_* functions. /* Certain cases in Perl_ss_dup have been merged, by relying on the fact - that currently av_dup and hv_dup are the same as sv_dup. If this changes, - please unmerge ss_dup. */ + that currently av_dup, gv_dup and hv_dup are the same as sv_dup. + If this changes, please unmerge ss_dup. */ #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t)) #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t)) #define av_dup(s,t) (AV*)sv_dup((SV*)s,t) @@ -9467,135 +9485,78 @@ ptr_table_* functions. #define SAVEPV(p) ((p) ? savepv(p) : NULL) #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL) +/* clone a parser */ -/* Duplicate a regexp. Required reading: pregcomp() and pregfree() in - regcomp.c. AMS 20010712 */ - -REGEXP * -Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param) +yy_parser * +Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param) { - dVAR; - REGEXP *ret; - int i, len, npar; - struct reg_substr_datum *s; - - if (!r) - return (REGEXP *)NULL; + yy_parser *parser; - if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r))) - return ret; - - len = r->offsets[0]; - npar = r->nparens+1; - - Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp); - Copy(r->program, ret->program, len+1, regnode); - - Newx(ret->startp, npar, I32); - Copy(r->startp, ret->startp, npar, I32); - Newx(ret->endp, npar, I32); - Copy(r->startp, ret->startp, npar, I32); - - Newx(ret->substrs, 1, struct reg_substr_data); - for (s = ret->substrs->data, i = 0; i < 3; i++, s++) { - s->min_offset = r->substrs->data[i].min_offset; - s->max_offset = r->substrs->data[i].max_offset; - s->substr = sv_dup_inc(r->substrs->data[i].substr, param); - s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param); - } - - ret->regstclass = NULL; - if (r->data) { - struct reg_data *d; - const int count = r->data->count; - int i; - - Newxc(d, sizeof(struct reg_data) + count*sizeof(void *), - char, struct reg_data); - Newx(d->what, count, U8); - - d->count = count; - for (i = 0; i < count; i++) { - d->what[i] = r->data->what[i]; - switch (d->what[i]) { - /* legal options are one of: sfpont - see also regcomp.h and pregfree() */ - case 's': - d->data[i] = sv_dup_inc((SV *)r->data->data[i], param); - break; - case 'p': - d->data[i] = av_dup_inc((AV *)r->data->data[i], param); - break; - case 'f': - /* This is cheating. */ - Newx(d->data[i], 1, struct regnode_charclass_class); - StructCopy(r->data->data[i], d->data[i], - struct regnode_charclass_class); - ret->regstclass = (regnode*)d->data[i]; - break; - case 'o': - /* Compiled op trees are readonly, and can thus be - shared without duplication. */ - OP_REFCNT_LOCK; - d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]); - OP_REFCNT_UNLOCK; - break; - case 'n': - d->data[i] = r->data->data[i]; - break; - case 't': - d->data[i] = r->data->data[i]; - OP_REFCNT_LOCK; - ((reg_trie_data*)d->data[i])->refcount++; - OP_REFCNT_UNLOCK; - break; - case 'T': - d->data[i] = r->data->data[i]; - OP_REFCNT_LOCK; - ((reg_ac_data*)d->data[i])->refcount++; - OP_REFCNT_UNLOCK; - /* Trie stclasses are readonly and can thus be shared - * without duplication. We free the stclass in pregfree - * when the corresponding reg_ac_data struct is freed. - */ - ret->regstclass= r->regstclass; - break; - default: - Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]); - } - } - - ret->data = d; - } - else - ret->data = NULL; - - Newx(ret->offsets, 2*len+1, U32); - Copy(r->offsets, ret->offsets, 2*len+1, U32); + if (!proto) + return NULL; - ret->precomp = SAVEPVN(r->precomp, r->prelen); - ret->refcnt = r->refcnt; - ret->minlen = r->minlen; - ret->prelen = r->prelen; - ret->nparens = r->nparens; - ret->lastparen = r->lastparen; - ret->lastcloseparen = r->lastcloseparen; - ret->reganch = r->reganch; + /* look for it in the table first */ + parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto); + if (parser) + return parser; - ret->sublen = r->sublen; + /* create anew and remember what it is */ + Newxz(parser, 1, yy_parser); + ptr_table_store(PL_ptr_table, proto, parser); + + parser->yyerrstatus = 0; + parser->yychar = YYEMPTY; /* Cause a token to be read. */ + + /* XXX these not yet duped */ + parser->old_parser = NULL; + parser->stack = NULL; + parser->ps = NULL; + parser->stack_size = 0; + /* XXX parser->stack->state = 0; */ + + /* XXX eventually, just Copy() most of the parser struct ? */ + + parser->lex_brackets = proto->lex_brackets; + parser->lex_casemods = proto->lex_casemods; + parser->lex_brackstack = savepvn(proto->lex_brackstack, + (proto->lex_brackets < 120 ? 120 : proto->lex_brackets)); + parser->lex_casestack = savepvn(proto->lex_casestack, + (proto->lex_casemods < 12 ? 12 : proto->lex_casemods)); + parser->lex_defer = proto->lex_defer; + parser->lex_dojoin = proto->lex_dojoin; + parser->lex_expect = proto->lex_expect; + parser->lex_formbrack = proto->lex_formbrack; + parser->lex_inpat = proto->lex_inpat; + parser->lex_inwhat = proto->lex_inwhat; + parser->lex_op = proto->lex_op; + parser->lex_repl = sv_dup_inc(proto->lex_repl, param); + parser->lex_starts = proto->lex_starts; + parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param); + parser->multi_close = proto->multi_close; + parser->multi_open = proto->multi_open; + parser->multi_start = proto->multi_start; + parser->pending_ident = proto->pending_ident; + parser->preambled = proto->preambled; + parser->sublex_info = proto->sublex_info; /* XXX not quite right */ - if (RX_MATCH_COPIED(ret)) - ret->subbeg = SAVEPVN(r->subbeg, r->sublen); - else - ret->subbeg = NULL; -#ifdef PERL_OLD_COPY_ON_WRITE - ret->saved_copy = NULL; +#ifdef PERL_MAD + parser->endwhite = proto->endwhite; + parser->faketokens = proto->faketokens; + parser->lasttoke = proto->lasttoke; + parser->nextwhite = proto->nextwhite; + parser->realtokenstart = proto->realtokenstart; + parser->skipwhite = proto->skipwhite; + parser->thisclose = proto->thisclose; + parser->thismad = proto->thismad; + parser->thisopen = proto->thisopen; + parser->thisstuff = proto->thisstuff; + parser->thistoken = proto->thistoken; + parser->thiswhite = proto->thiswhite; #endif - - ptr_table_store(PL_ptr_table, r, ret); - return ret; + return parser; } + /* duplicate a file handle */ PerlIO * @@ -9690,7 +9651,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) nmg->mg_type = mg->mg_type; nmg->mg_flags = mg->mg_flags; if (mg->mg_type == PERL_MAGIC_qr) { - nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param); + nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param); } else if(mg->mg_type == PERL_MAGIC_backref) { /* The backref AV has its reference count deliberately bumped by @@ -9732,6 +9693,8 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) return mgret; } +#endif /* USE_ITHREADS */ + /* create a new pointer-mapping table */ PTR_TBL_t * @@ -9875,6 +9838,7 @@ Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl) Safefree(tbl); } +#if defined(USE_ITHREADS) void Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param) @@ -9970,7 +9934,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) #ifdef DEBUGGING if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx) PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n", - PL_watch_pvx, SvPVX_const(sstr)); + (void*)PL_watch_pvx, SvPVX_const(sstr)); #endif /* don't clone objects whose class has asked us not to */ @@ -9996,6 +9960,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) SvANY(dstr) = &(dstr->sv_u.svu_rv); Perl_rvpv_dup(aTHX_ dstr, sstr, param); break; + /* case SVt_BIND: */ default: { /* These are all the types that need complex bodies allocating. */ @@ -10017,7 +9982,6 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) case SVt_PVFM: case SVt_PVHV: case SVt_PVAV: - case SVt_PVBM: case SVt_PVCV: case SVt_PVLV: case SVt_PVMG: @@ -10057,7 +10021,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) FIXME - instrument and check that assumption */ if (sv_type >= SVt_PVMG) { if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) { - OURSTASH_set(dstr, hv_dup_inc(OURSTASH(dstr), param)); + SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param)); } else if (SvMAGIC(dstr)) SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param)); if (SvSTASH(dstr)) @@ -10074,8 +10038,6 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) break; case SVt_PVMG: break; - case SVt_PVBM: - break; case SVt_PVLV: /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */ if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */ @@ -10086,12 +10048,15 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param); break; case SVt_PVGV: - if (GvNAME_HEK(dstr)) - GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param); + if(isGV_with_GP(sstr)) { + if (GvNAME_HEK(dstr)) + GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param); + } /* Don't call sv_add_backref here as it's going to be created as part of the magic cloning of the symbol table. */ - GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); + if(!SvVALID(dstr)) + GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); if(isGV_with_GP(sstr)) { /* Danger Will Robinson - GvGP(dstr) isn't initialised at the point of this comment. */ @@ -10137,7 +10102,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) src_ary = AvARRAY((AV*)sstr); Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*); ptr_table_store(PL_ptr_table, src_ary, dst_ary); - SvPV_set(dstr, (char*)dst_ary); + AvARRAY((AV*)dstr) = dst_ary; AvALLOC((AV*)dstr) = dst_ary; if (AvREAL((AV*)sstr)) { while (items-- > 0) @@ -10153,7 +10118,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) } } else { - SvPV_set(dstr, NULL); + AvARRAY((AV*)dstr) = NULL; AvALLOC((AV*)dstr) = (SV**)NULL; } break; @@ -10200,7 +10165,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) } } else - SvPV_set(dstr, NULL); + HvARRAY((HV*)dstr) = NULL; break; case SVt_PVCV: if (!(param->flags & CLONEf_COPY_STACKS)) { @@ -10300,9 +10265,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) 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.my_op = cx->blk_loop.my_op; ncx->blk_loop.iterdata = (CxPADLOOP(cx) ? cx->blk_loop.iterdata : gv_dup((GV*)cx->blk_loop.iterdata, param)); @@ -10415,6 +10378,7 @@ Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl) 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; @@ -10428,6 +10392,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) long longval; GP *gp; IV iv; + I32 i; char *c = NULL; void (*dptr) (void*); void (*dxptr) (pTHX_ void*); @@ -10435,13 +10400,20 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) Newxz(nss, max, ANY); while (ix > 0) { - I32 i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - switch (i) { + const I32 type = POPINT(ss,ix); + TOPINT(nss,ix) = type; + switch (type) { + case SAVEt_HELEM: /* hash element */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + /* fall through */ case SAVEt_ITEM: /* normal string */ case SAVEt_SV: /* scalar reference */ sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); + /* fall through */ + case SAVEt_FREESV: + case SAVEt_MORTALIZESV: sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); break; @@ -10460,10 +10432,13 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) break; case SAVEt_HV: /* hash reference */ case SAVEt_AV: /* array reference */ - sv = POPPTR(ss,ix); + sv = (SV*) POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); - gv = (GV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup(gv, param); + /* fall through */ + case SAVEt_COMPPAD: + case SAVEt_NSTAB: + sv = (SV*) POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup(sv, param); break; case SAVEt_INT: /* int reference */ ptr = POPPTR(ss,ix); @@ -10474,6 +10449,8 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) case SAVEt_LONG: /* long reference */ ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + /* fall through */ + case SAVEt_CLEARSV: longval = (long)POPLONG(ss,ix); TOPLONG(nss,ix) = longval; break; @@ -10513,28 +10490,13 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = pv_dup(c); break; - case SAVEt_NSTAB: - gv = (GV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup(gv, param); - break; case SAVEt_GP: /* scalar reference */ gp = (GP*)POPPTR(ss,ix); TOPPTR(nss,ix) = gp = gp_dup(gp, param); (void)GpREFCNT_inc(gp); gv = (GV*)POPPTR(ss,ix); TOPPTR(nss,ix) = gv_dup_inc(gv, param); - 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: - case SAVEt_MORTALIZESV: - sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - break; case SAVEt_FREEOP: ptr = POPPTR(ss,ix); if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { @@ -10549,7 +10511,9 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) case OP_LEAVEWRITE: TOPPTR(nss,ix) = ptr; o = (OP*)ptr; + OP_REFCNT_LOCK; OpREFCNT_inc(o); + OP_REFCNT_UNLOCK; break; default: TOPPTR(nss,ix) = NULL; @@ -10563,15 +10527,13 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) 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, param); c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = pv_dup_inc(c); + /* fall through */ + case SAVEt_STACK_POS: /* Position on Perl stack */ i = POPINT(ss,ix); TOPINT(nss,ix) = i; break; @@ -10597,10 +10559,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) 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, param); @@ -10609,14 +10567,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) av = (AV*)POPPTR(ss,ix); TOPPTR(nss,ix) = av_dup_inc(av, param); break; - case SAVEt_HELEM: /* hash element */ - sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - hv = (HV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = hv_dup_inc(hv, param); - break; case SAVEt_OP: ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = ptr; @@ -10636,10 +10586,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPPTR(nss,ix) = hv_dup_inc(hv, param); } break; - case SAVEt_COMPPAD: - av = (AV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = av_dup(av, param); - break; case SAVEt_PADSV: longval = (long)POPLONG(ss,ix); TOPLONG(nss,ix) = longval; @@ -10681,13 +10627,14 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) new_state->re_state_regeol = pv_dup(old_state->re_state_regeol); new_state->re_state_regstartp - = any_dup(old_state->re_state_regstartp, proto_perl); + = (I32*) any_dup(old_state->re_state_regstartp, proto_perl); new_state->re_state_regendp - = any_dup(old_state->re_state_regendp, proto_perl); + = (I32*) any_dup(old_state->re_state_regendp, proto_perl); new_state->re_state_reglastparen - = any_dup(old_state->re_state_reglastparen, proto_perl); + = (U32*) any_dup(old_state->re_state_reglastparen, + proto_perl); new_state->re_state_reglastcloseparen - = any_dup(old_state->re_state_reglastcloseparen, + = (U32*)any_dup(old_state->re_state_reglastcloseparen, proto_perl); /* XXX This just has to be broken. The old save_re_context code did SAVEGENERICPV(PL_reg_start_tmp); @@ -10707,11 +10654,14 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) = sv_dup(old_state->re_state_nrs, param); #endif new_state->re_state_reg_magic - = any_dup(old_state->re_state_reg_magic, proto_perl); + = (MAGIC*) any_dup(old_state->re_state_reg_magic, + proto_perl); new_state->re_state_reg_oldcurpm - = any_dup(old_state->re_state_reg_oldcurpm, proto_perl); + = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm, + proto_perl); new_state->re_state_reg_curpm - = any_dup(old_state->re_state_reg_curpm, proto_perl); + = (PMOP*) any_dup(old_state->re_state_reg_curpm, + proto_perl); new_state->re_state_reg_oldsaved = pv_dup(old_state->re_state_reg_oldsaved); new_state->re_state_reg_poscache @@ -10724,8 +10674,13 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr); break; + case SAVEt_PARSER: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = parser_dup(ptr, param); + break; default: - Perl_croak(aTHX_ "panic: ss_dup inconsistency (%"IVdf")", (IV) i); + Perl_croak(aTHX_ + "panic: ss_dup inconsistency (%"IVdf")", (IV) type); } } @@ -11048,6 +11003,12 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */ sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */ + + /* RE engine related */ + Zero(&PL_reg_state, 1, struct re_save_state); + PL_reginterp_cnt = 0; + PL_regmatch_slab = NULL; + /* Clone the regex array */ PL_regex_padav = newAV(); { @@ -11061,7 +11022,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvREPADTMP(regex) ? sv_dup_inc(regex, param) : SvREFCNT_inc( - newSViv(PTR2IV(re_dup( + newSViv(PTR2IV(CALLREGDUPE( INT2PTR(REGEXP *, SvIVX(regex)), param)))) ; av_push(PL_regex_padav, sv); @@ -11104,6 +11065,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_beginav = av_dup_inc(proto_perl->Ibeginav, param); PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param); PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param); + PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param); + PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param); PL_endav = av_dup_inc(proto_perl->Iendav, param); PL_checkav = av_dup_inc(proto_perl->Icheckav, param); PL_initav = av_dup_inc(proto_perl->Iinitav, param); @@ -11126,7 +11089,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* current interpreter roots */ PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param); + OP_REFCNT_LOCK; PL_main_root = OpREFCNT_inc(proto_perl->Imain_root); + OP_REFCNT_UNLOCK; PL_main_start = proto_perl->Imain_start; PL_eval_root = proto_perl->Ieval_root; PL_eval_start = proto_perl->Ieval_start; @@ -11141,7 +11106,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_Argv = NULL; PL_Cmd = NULL; PL_gensym = proto_perl->Igensym; - PL_preambled = proto_perl->Ipreambled; PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param); PL_laststatval = proto_perl->Ilaststatval; PL_laststype = proto_perl->Ilaststype; @@ -11162,9 +11126,17 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, if (PL_my_cxt_size) { Newx(PL_my_cxt_list, PL_my_cxt_size, void *); Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *); +#ifdef PERL_GLOBAL_STRUCT_PRIVATE + Newx(PL_my_cxt_keys, PL_my_cxt_size, char *); + Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *); +#endif } - else + else { PL_my_cxt_list = (void**)NULL; +#ifdef PERL_GLOBAL_STRUCT_PRIVATE + PL_my_cxt_keys = (void**)NULL; +#endif + } PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param); PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param); PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param); @@ -11213,38 +11185,12 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_cshname = proto_perl->Icshname; /* XXX never deallocated */ #endif + PL_parser = parser_dup(proto_perl->Iparser, param); + 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_dojoin = proto_perl->Ilex_dojoin; - PL_lex_starts = proto_perl->Ilex_starts; - PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param); - PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param); - 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); #ifdef PERL_MAD Copy(proto_perl->Inexttoke, PL_nexttoke, 5, NEXTTOKE); - PL_lasttoke = proto_perl->Ilasttoke; - PL_realtokenstart = proto_perl->Irealtokenstart; - PL_faketokens = proto_perl->Ifaketokens; - PL_thismad = proto_perl->Ithismad; - PL_thistoken = proto_perl->Ithistoken; - PL_thisopen = proto_perl->Ithisopen; - PL_thisstuff = proto_perl->Ithisstuff; - PL_thisclose = proto_perl->Ithisclose; - PL_thiswhite = proto_perl->Ithiswhite; - PL_nextwhite = proto_perl->Inextwhite; - PL_skipwhite = proto_perl->Iskipwhite; - PL_endwhite = proto_perl->Iendwhite; PL_curforce = proto_perl->Icurforce; #else Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE); @@ -11252,56 +11198,30 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_nexttoke = proto_perl->Inexttoke; #endif - /* XXX This is probably masking the deeper issue of why - * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case: - * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html - * (A little debugging with a watchpoint on it may help.) - */ - if (SvANY(proto_perl->Ilinestr)) { - 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); - } - else { - PL_linestr = newSV(79); - sv_upgrade(PL_linestr,SVt_PVIV); - sv_setpvn(PL_linestr,"",0); - PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); - } + 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_pending_ident = proto_perl->Ipending_ident; - PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */ 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, param); - /* XXX See comment on SvANY(proto_perl->Ilinestr) above */ - if (SvANY(proto_perl->Ilinestr)) { - 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; - } - else { - PL_last_uni = SvPVX(PL_linestr); - PL_last_lop = SvPVX(PL_linestr); - PL_last_lop_op = 0; - } + 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 @@ -11392,7 +11312,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_glob_index = proto_perl->Iglob_index; PL_srand_called = proto_perl->Isrand_called; - PL_uudmap['M'] = 0; /* reinits on demand */ + PL_uudmap[(U32) 'M'] = 0; /* reinits on demand */ PL_bitcount = NULL; /* reinits on demand */ if (proto_perl->Ipsig_pend) { @@ -11546,15 +11466,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_colorset = 0; /* reinits PL_colors[] */ /*PL_colors[6] = {0,0,0,0,0,0};*/ - /* 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; - Zero(&PL_reg_state, 1, struct re_save_state); - PL_reginterp_cnt = 0; - PL_regmatch_slab = NULL; + /* Pluggable optimizer */ PL_peepp = proto_perl->Tpeepp; @@ -11821,8 +11733,7 @@ S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, return NULL; av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE)); sv = *av_fetch(av, targ, FALSE); - /* SvLEN in a pad name is not to be trusted */ - sv_setpv(name, SvPV_nolen_const(sv)); + sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv)); } if (subscript_type == FUV_SUBSCRIPT_HASH) {