X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/742421a6d27bb72693477d2ace6f6c1fbb417709..65ac1738675fbcf49a4c9d625c0c43dd73e6ff2f:/sv.c diff --git a/sv.c b/sv.c index 5f99266..47822f0 100644 --- a/sv.c +++ b/sv.c @@ -689,7 +689,6 @@ Perl_sv_free_arenas(pTHX) 2. regular body arenas 3. arenas for reduced-size bodies 4. Hash-Entry arenas - 5. pte arenas (thread related) Arena types 2 & 3 are chained by body-type off an array of arena-root pointers, which is indexed by svtype. Some of the @@ -708,12 +707,6 @@ Perl_sv_free_arenas(pTHX) HE, HEK arenas are managed separately, with separate code, but may be merge-able later.. - - PTE arenas are not sv-bodies, but they share these mid-level - mechanics, so are considered here. The new mid-level mechanics rely - on the sv_type of the body being allocated, so we just reserve one - of the unused body-slots for PTEs, then use it in those (2) PTE - contexts below (line ~10k) */ /* get_arena(size): this creates custom-sized arenas @@ -852,13 +845,6 @@ 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. -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. - */ struct body_details { @@ -921,14 +907,11 @@ static const struct body_details bodies_by_type[] = { 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. */ + /* IVs are in the head, so the allocation size is 0. */ + { 0, sizeof(IV), /* This is used to copy out the IV body. */ STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV, - NOARENA /* IVS don't need an arena */, - /* But PTEs need to know the size of their arena */ - FIT_ARENA(0, sizeof(struct ptr_tbl_ent)) + NOARENA /* IVS don't need an arena */, 0 }, /* 8 bytes on most ILP32 with IEEE doubles */ @@ -1006,13 +989,6 @@ static const struct body_details bodies_by_type[] = { FIT_ARENA(24, sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur)) }, }; -#define new_body_type(sv_type) \ - (void *)((char *)S_new_body(aTHX_ sv_type)) - -#define del_body_type(p, sv_type) \ - del_body(p, &PL_body_roots[sv_type]) - - #define new_body_allocated(sv_type) \ (void *)((char *)S_new_body(aTHX_ sv_type) \ - bodies_by_type[sv_type].offset) @@ -1047,11 +1023,11 @@ static const struct body_details bodies_by_type[] = { #else /* !PURIFY */ -#define new_XNV() new_body_type(SVt_NV) -#define del_XNV(p) del_body_type(p, SVt_NV) +#define new_XNV() new_body_allocated(SVt_NV) +#define del_XNV(p) del_body_allocated(p, SVt_NV) -#define new_XPVNV() new_body_type(SVt_PVNV) -#define del_XPVNV(p) del_body_type(p, SVt_PVNV) +#define new_XPVNV() new_body_allocated(SVt_PVNV) +#define del_XPVNV(p) del_body_allocated(p, SVt_PVNV) #define new_XPVAV() new_body_allocated(SVt_PVAV) #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV) @@ -1059,11 +1035,11 @@ static const struct body_details bodies_by_type[] = { #define new_XPVHV() new_body_allocated(SVt_PVHV) #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV) -#define new_XPVMG() new_body_type(SVt_PVMG) -#define del_XPVMG(p) del_body_type(p, SVt_PVMG) +#define new_XPVMG() new_body_allocated(SVt_PVMG) +#define del_XPVMG(p) del_body_allocated(p, SVt_PVMG) -#define new_XPVGV() new_body_type(SVt_PVGV) -#define del_XPVGV(p) del_body_type(p, SVt_PVGV) +#define new_XPVGV() new_body_allocated(SVt_PVGV) +#define del_XPVGV(p) del_body_allocated(p, SVt_PVGV) #endif /* PURIFY */ @@ -1372,6 +1348,10 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) break; + case SVt_REGEXP: + /* This ensures that SvTHINKFIRST(sv) is true, and hence that + sv_force_normal_flags(sv) is called. */ + SvFAKE_on(sv); case SVt_PVIV: /* XXX Is this still needed? Was it ever needed? Surely as there is no route from NV to PVIV, NOK can never be true */ @@ -1382,7 +1362,6 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) case SVt_PVGV: case SVt_PVCV: case SVt_PVLV: - case SVt_REGEXP: case SVt_PVMG: case SVt_PVNV: case SVt_PV: @@ -1431,7 +1410,7 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) if (new_type == SVt_PVIO) { IO * const io = MUTABLE_IO(sv); - GV *iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV); + GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV); SvOBJECT_on(io); /* Clear the stashcache because a new IO could overrule a package @@ -1452,7 +1431,7 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) (unsigned long)new_type); } - if (old_type > SVt_IV) { /* SVt_IVs are overloaded for PTEs */ + if (old_type > SVt_IV) { #ifdef PURIFY my_safefree(old_body); #else @@ -1714,7 +1693,7 @@ Perl_sv_setnv(pTHX_ register SV *const sv, const NV num) case SVt_PVFM: case SVt_PVIO: Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), - OP_NAME(PL_op)); + OP_DESC(PL_op)); default: NOOP; } SvNV_set(sv, num); @@ -2336,7 +2315,10 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags) if (SvROK(sv)) { return_rok: if (SvAMAGIC(sv)) { - SV * const tmpstr=AMG_CALLun(sv,numer); + SV * tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return 0; + tmpstr=AMG_CALLun(sv,numer); if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { return SvIV(tmpstr); } @@ -2412,7 +2394,10 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags) if (SvROK(sv)) { return_rok: if (SvAMAGIC(sv)) { - SV *const tmpstr = AMG_CALLun(sv,numer); + SV *tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return 0; + tmpstr = AMG_CALLun(sv,numer); if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { return SvUV(tmpstr); } @@ -2442,14 +2427,14 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags) =for apidoc sv_2nv Return the num value of an SV, doing any necessary string or integer -conversion, magic etc. Normally used via the C and C -macros. +conversion. If flags includes SV_GMAGIC, does an mg_get() first. +Normally used via the C and C macros. =cut */ NV -Perl_sv_2nv(pTHX_ register SV *const sv) +Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags) { dVAR; if (!sv) @@ -2457,7 +2442,8 @@ Perl_sv_2nv(pTHX_ register SV *const 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 (flags & SV_GMAGIC) + mg_get(sv); if (SvNOKp(sv)) return SvNVX(sv); if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) { @@ -2482,7 +2468,10 @@ Perl_sv_2nv(pTHX_ register SV *const sv) if (SvROK(sv)) { return_rok: if (SvAMAGIC(sv)) { - SV *const tmpstr = AMG_CALLun(sv,numer); + SV *tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return 0; + tmpstr = AMG_CALLun(sv,numer); if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { return SvNV(tmpstr); } @@ -2799,7 +2788,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags if (SvROK(sv)) { return_rok: if (SvAMAGIC(sv)) { - SV *const tmpstr = AMG_CALLun(sv,string); + SV *tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return NULL; + tmpstr = AMG_CALLun(sv,string); if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { /* Unwrap this: */ /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); @@ -2986,11 +2978,17 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags gv_efullname3(buffer, gv, "*"); SvFLAGS(gv) |= wasfake; - assert(SvPOK(buffer)); - if (lp) { - *lp = SvCUR(buffer); + if (SvPOK(buffer)) { + if (lp) { + *lp = SvCUR(buffer); + } + return SvPVX(buffer); + } + else { + if (lp) + *lp = 0; + return (char *)""; } - return SvPVX(buffer); } if (lp) @@ -3115,7 +3113,7 @@ Perl_sv_2bool(pTHX_ register SV *const sv) if (SvAMAGIC(sv)) { SV * const tmpsv = AMG_CALLun(sv,bool_); if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) - return (bool)SvTRUE(tmpsv); + return cBOOL(SvTRUE(tmpsv)); } return SvRV(sv) != 0; } @@ -3676,7 +3674,6 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) SV **location; U8 import_flag = 0; const U32 stype = SvTYPE(sref); - bool mro_changes = FALSE; PERL_ARGS_ASSERT_GLOB_ASSIGN_REF; @@ -3697,8 +3694,6 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) goto common; case SVt_PVAV: location = (SV **) &GvAV(dstr); - if (strEQ(GvNAME((GV*)dstr), "ISA")) - mro_changes = TRUE; import_flag = GVf_IMPORTED_AV; goto common; case SVt_PVIO: @@ -3772,12 +3767,15 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvFLAGS(dstr) |= import_flag; } + if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) { + sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0); + mro_isa_changed_in(GvSTASH(dstr)); + } break; } SvREFCNT_dec(dref); if (SvTAINTED(sstr)) SvTAINT(dstr); - if (mro_changes) mro_isa_changed_in(GvSTASH(dstr)); return; } @@ -3905,7 +3903,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) { const char * const type = sv_reftype(sstr,0); if (PL_op) - Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op)); + Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op)); else Perl_croak(aTHX_ "Bizarre copy of %s", type); } @@ -3965,7 +3963,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } 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)); + Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op)); else Perl_croak(aTHX_ "Cannot copy to %s", type); } else if (sflags & SVf_ROK) { @@ -4071,9 +4069,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) (!(flags & SV_NOSTEAL)) && /* and we're allowed to steal temps */ SvREFCNT(sstr) == 1 && /* and no other references to it? */ - SvLEN(sstr) && /* and really is a string */ - /* and won't be needed again, potentially */ - !(PL_op && PL_op->op_type == OP_AASSIGN)) + SvLEN(sstr)) /* and really is a string */ #ifdef PERL_OLD_COPY_ON_WRITE && ((flags & SV_COW_SHARED_HASH_KEYS) ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS @@ -4609,6 +4605,45 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) sv_unref_flags(sv, flags); else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) sv_unglob(sv); + else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) { + /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous + to sv_unglob. We only need it here, so inline it. */ + const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV; + SV *const temp = newSV_type(new_type); + void *const temp_p = SvANY(sv); + + if (new_type == SVt_PVMG) { + SvMAGIC_set(temp, SvMAGIC(sv)); + SvMAGIC_set(sv, NULL); + SvSTASH_set(temp, SvSTASH(sv)); + SvSTASH_set(sv, NULL); + } + SvCUR_set(temp, SvCUR(sv)); + /* Remember that SvPVX is in the head, not the body. */ + if (SvLEN(temp)) { + SvLEN_set(temp, SvLEN(sv)); + /* This signals "buffer is owned by someone else" in sv_clear, + which is the least effort way to stop it freeing the buffer. + */ + SvLEN_set(sv, SvLEN(sv)+1); + } else { + /* Their buffer is already owned by someone else. */ + SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv)); + SvLEN_set(temp, SvCUR(sv)+1); + } + + /* Now swap the rest of the bodies. */ + + SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK); + SvFLAGS(sv) |= new_type; + SvANY(sv) = SvANY(temp); + + SvFLAGS(temp) &= ~(SVTYPEMASK); + SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE; + SvANY(temp) = temp_p; + + SvREFCNT_dec(temp); + } } /* @@ -5628,15 +5663,9 @@ Perl_sv_clear(pTHX_ register SV *const sv) if (type <= SVt_IV) { /* See the comment in sv.h about the collusion between this early - return and the overloading of the NULL and IV slots in the size - table. */ - if (SvROK(sv)) { - SV * const target = SvRV(sv); - if (SvWEAKREF(sv)) - sv_del_backref(target, sv); - else - SvREFCNT_dec(target); - } + return and the overloading of the NULL slots in the size table. */ + if (SvROK(sv)) + goto free_rv; SvFLAGS(sv) &= SVf_BREAK; SvFLAGS(sv) |= SVTYPEMASK; return; @@ -5658,7 +5687,8 @@ Perl_sv_clear(pTHX_ register SV *const sv) && !CvCONST(destructor) /* Don't bother calling an empty destructor */ && (CvISXSUB(destructor) - || CvSTART(destructor)->op_next->op_type != OP_LEAVESUB)) + || (CvSTART(destructor) + && (CvSTART(destructor)->op_next->op_type != OP_LEAVESUB)))) { SV* const tmpref = newRV(sv); SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ @@ -5787,11 +5817,14 @@ Perl_sv_clear(pTHX_ register SV *const sv) /* Don't even bother with turning off the OOK flag. */ } if (SvROK(sv)) { - SV * const target = SvRV(sv); - if (SvWEAKREF(sv)) - sv_del_backref(target, sv); - else - SvREFCNT_dec(target); + free_rv: + { + SV * const target = SvRV(sv); + if (SvWEAKREF(sv)) + sv_del_backref(target, sv); + else + SvREFCNT_dec(target); + } } #ifdef PERL_OLD_COPY_ON_WRITE else if (SvPVX_const(sv)) { @@ -6023,6 +6056,10 @@ Perl_sv_len_utf8(pTHX_ register SV *const sv) } assert(mg); mg->mg_len = ulen; + /* For now, treat "overflowed" as "still unknown". + See RT #72924. */ + if (ulen != (STRLEN) mg->mg_len) + mg->mg_len = -1; } } return ulen; @@ -6191,62 +6228,97 @@ S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start /* -=for apidoc sv_pos_u2b +=for apidoc sv_pos_u2b_flags Converts the value pointed to by offsetp from a count of UTF-8 chars from the start of the string, to a count of the equivalent number of bytes; if lenp is non-zero, it does the same to lenp, but this time starting from -the offset, rather than from the start of the string. Handles magic and -type coercion. +the offset, rather than from the start of the string. Handles type coercion. +I is passed to C, and usually should be +C to handle magic. =cut */ /* - * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential + * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and * byte offsets. See also the comments of S_utf8_mg_pos_cache_update(). * */ -void -Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp) +STRLEN +Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp, + U32 flags) { const U8 *start; STRLEN len; + STRLEN boffset; - PERL_ARGS_ASSERT_SV_POS_U2B; - - if (!sv) - return; + PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS; - start = (U8*)SvPV_const(sv, len); + start = (U8*)SvPV_flags(sv, len, flags); if (len) { - STRLEN uoffset = (STRLEN) *offsetp; const U8 * const send = start + len; MAGIC *mg = NULL; - const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send, - uoffset, 0, 0); - - *offsetp = (I32) boffset; + boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0); if (lenp) { /* Convert the relative offset to absolute. */ - const STRLEN uoffset2 = uoffset + (STRLEN) *lenp; + const STRLEN uoffset2 = uoffset + *lenp; const STRLEN boffset2 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2, uoffset, boffset) - boffset; *lenp = boffset2; } - } - else { - *offsetp = 0; - if (lenp) - *lenp = 0; + } else { + if (lenp) + *lenp = 0; + boffset = 0; } - return; + return boffset; +} + +/* +=for apidoc sv_pos_u2b + +Converts the value pointed to by offsetp from a count of UTF-8 chars from +the start of the string, to a count of the equivalent number of bytes; if +lenp is non-zero, it does the same to lenp, but this time starting from +the offset, rather than from the start of the string. Handles magic and +type coercion. + +Use C in preference, which correctly handles strings longer +than 2Gb. + +=cut +*/ + +/* + * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential + * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and + * byte offsets. See also the comments of S_utf8_mg_pos_cache_update(). + * + */ + +/* This function is subject to size and sign problems */ + +void +Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp) +{ + PERL_ARGS_ASSERT_SV_POS_U2B; + + if (lenp) { + STRLEN ulen = (STRLEN)*lenp; + *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen, + SV_GMAGIC|SV_CONST_RETURN); + *lenp = (I32)ulen; + } else { + *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL, + SV_GMAGIC|SV_CONST_RETURN); + } } /* Create and update the UTF8 magic offset cache, with the proffered utf8/ @@ -7586,7 +7658,8 @@ string. You are responsible for ensuring that the source string is at least C bytes long. If the C argument is NULL the new SV will be undefined. Currently the only flag bits accepted are C and C. If C is set, then C is called on the result before -returning. If C is set, then it will be set on the new SV. +returning. If C is set, C is considered to be in UTF-8 and the +C flag will be set on the new SV. C is a convenience wrapper for this function, defined as #define newSVpvn_utf8(s, len, u) \ @@ -8346,14 +8419,14 @@ Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) const char * const ref = sv_reftype(sv,0); if (PL_op) Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s", - ref, OP_NAME(PL_op)); + ref, OP_DESC(PL_op)); else Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref); } if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) || isGV_with_GP(sv)) Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), - OP_NAME(PL_op)); + OP_DESC(PL_op)); s = sv_2pv_flags(sv, &len, flags); if (lp) *lp = len; @@ -9202,7 +9275,7 @@ S_expect_number(pTHX_ char **const pattern) while (isDIGIT(**pattern)) { const I32 tmp = var * 10 + (*(*pattern)++ - '0'); if (tmp < var) - Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn")); + Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn")); var = tmp; } } @@ -9298,6 +9371,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, else if (svix < svmax) { sv_catsv(sv, *svargs); } + else + S_vcatpvfn_missing_argument(aTHX); return; } if (args && patlen == 3 && pat[0] == '%' && @@ -9317,13 +9392,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, pp = pat + 2; while (*pp >= '0' && *pp <= '9') digits = 10 * digits + (*pp++ - '0'); - if (pp - pat == (int)patlen - 1) { - NV nv; - - if (svix < svmax) - nv = SvNV(*svargs); - else - return; + if (pp - pat == (int)patlen - 1 && svix < svmax) { + const NV nv = SvNV(*svargs); if (*pp == 'g') { /* Add check for digits != 0 because it seems that some gconverts are buggy in this case, and we don't yet have @@ -10342,6 +10412,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, goto vector; } } + SvTAINT(sv); } /* ========================================================================= @@ -10647,6 +10718,11 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param) #endif /* USE_ITHREADS */ +struct ptr_tbl_arena { + struct ptr_tbl_arena *next; + struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */ +}; + /* create a new pointer-mapping table */ PTR_TBL_t * @@ -10658,6 +10734,9 @@ Perl_ptr_table_new(pTHX) Newx(tbl, 1, PTR_TBL_t); tbl->tbl_max = 511; tbl->tbl_items = 0; + tbl->tbl_arena = NULL; + tbl->tbl_arena_next = NULL; + tbl->tbl_arena_end = NULL; Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*); return tbl; } @@ -10665,14 +10744,6 @@ Perl_ptr_table_new(pTHX) #define PTR_TABLE_HASH(ptr) \ ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) -/* - we use the PTE_SVSLOT 'reservation' made above, both here (in the - following define) and at call to new_body_inline made below in - Perl_ptr_table_store() - */ - -#define del_pte(p) del_body_type(p, PTE_SVSLOT) - /* map an existing pointer using a table */ STATIC PTR_TBL_ENT_t * @@ -10717,7 +10788,18 @@ Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void * } else { const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max; - new_body_inline(tblent, PTE_SVSLOT); + if (tbl->tbl_arena_next == tbl->tbl_arena_end) { + struct ptr_tbl_arena *new_arena; + + Newx(new_arena, 1, struct ptr_tbl_arena); + new_arena->next = tbl->tbl_arena; + tbl->tbl_arena = new_arena; + tbl->tbl_arena_next = new_arena->array; + tbl->tbl_arena_end = new_arena->array + + sizeof(new_arena->array) / sizeof(new_arena->array[0]); + } + + tblent = tbl->tbl_arena_next++; tblent->oldval = oldsv; tblent->newval = newsv; @@ -10765,25 +10847,27 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl) } /* remove all the entries from a ptr table */ +/* Deprecated - will be removed post 5.14 */ void Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl) { if (tbl && tbl->tbl_items) { - register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary; - UV riter = tbl->tbl_max; + struct ptr_tbl_arena *arena = tbl->tbl_arena; - do { - PTR_TBL_ENT_t *entry = array[riter]; + Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **); - while (entry) { - PTR_TBL_ENT_t * const oentry = entry; - entry = entry->next; - del_pte(oentry); - } - } while (riter--); + while (arena) { + struct ptr_tbl_arena *next = arena->next; + + Safefree(arena); + arena = next; + }; tbl->tbl_items = 0; + tbl->tbl_arena = NULL; + tbl->tbl_arena_next = NULL; + tbl->tbl_arena_end = NULL; } } @@ -10792,10 +10876,21 @@ Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl) void Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl) { + struct ptr_tbl_arena *arena; + if (!tbl) { return; } - ptr_table_clear(tbl); + + arena = tbl->tbl_arena; + + while (arena) { + struct ptr_tbl_arena *next = arena->next; + + Safefree(arena); + arena = next; + } + Safefree(tbl->tbl_ary); Safefree(tbl); } @@ -11104,6 +11199,11 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) else { while (items-- > 0) *dst_ary++ = sv_dup(*src_ary++, param); + if (!(param->flags & CLONEf_COPY_STACKS) + && AvREIFY(sstr)) + { + av_reify(MUTABLE_AV(dstr)); /* #41138 */ + } } items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr); while (items-- > 0) { @@ -11148,7 +11248,7 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) daux->xhv_riter = saux->xhv_riter; daux->xhv_eiter = saux->xhv_eiter ? he_dup(saux->xhv_eiter, - (bool)!!HvSHAREKEYS(sstr), param) : 0; + cBOOL(HvSHAREKEYS(sstr)), param) : 0; /* backref array needs refcnt=2; see sv_add_backref */ daux->xhv_backreferences = saux->xhv_backreferences @@ -11331,6 +11431,8 @@ Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) #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 POPUV(ss,ix) ((ss)[--(ix)].any_uv) +#define TOPUV(ss,ix) ((ss)[ix].any_uv) #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool) #define TOPBOOL(ss,ix) ((ss)[ix].any_bool) #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr) @@ -11403,9 +11505,13 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) Newxz(nss, max, ANY); while (ix > 0) { - const I32 type = POPINT(ss,ix); - TOPINT(nss,ix) = type; + const UV uv = POPUV(ss,ix); + const U8 type = (U8)uv & SAVE_MASK; + + TOPUV(nss,ix) = uv; switch (type) { + case SAVEt_CLEARSV: + break; case SAVEt_HELEM: /* hash element */ sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); @@ -11452,14 +11558,10 @@ 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; case SAVEt_I32: /* I32 reference */ - case SAVEt_I16: /* I16 reference */ - case SAVEt_I8: /* I8 reference */ case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */ ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); @@ -11483,6 +11585,12 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) case SAVEt_VPTR: /* random* reference */ ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + /* Fall through */ + case SAVEt_INT_SMALL: + case SAVEt_I32_SMALL: + case SAVEt_I16: /* I16 reference */ + case SAVEt_I8: /* I8 reference */ + case SAVEt_BOOL: ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); break; @@ -11494,12 +11602,14 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPPTR(nss,ix) = pv_dup(c); break; case SAVEt_GP: /* scalar reference */ + gv = (const GV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup_inc(gv, param); gp = (GP*)POPPTR(ss,ix); TOPPTR(nss,ix) = gp = gp_dup(gp, param); (void)GpREFCNT_inc(gp); - gv = (const GV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup_inc(gv, param); - break; + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; case SAVEt_FREEOP: ptr = POPPTR(ss,ix); if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { @@ -11558,9 +11668,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) break; case SAVEt_REGCONTEXT: case SAVEt_ALLOC: - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - ix -= i; + ix -= uv >> SAVE_TIGHT_SHIFT; break; case SAVEt_AELEM: /* array element */ sv = (const SV *)POPPTR(ss,ix); @@ -11597,12 +11705,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); break; - case SAVEt_BOOL: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - longval = (long)POPBOOL(ss,ix); - TOPBOOL(nss,ix) = (bool)longval; - break; case SAVEt_SET_SVFLAGS: i = POPINT(ss,ix); TOPINT(nss,ix) = i; @@ -11810,27 +11912,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); PERL_ARGS_ASSERT_PERL_CLONE_USING; - - /* for each stash, determine whether its objects should be cloned */ - S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); - PERL_SET_THX(my_perl); - -# ifdef DEBUGGING - PoisonNew(my_perl, 1, PerlInterpreter); - PL_op = NULL; - PL_curcop = NULL; - PL_markstack = 0; - PL_scopestack = 0; - PL_scopestack_name = 0; - PL_savestack = 0; - 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); -# endif /* DEBUGGING */ #else /* !PERL_IMPLICIT_SYS */ IV i; CLONE_PARAMS clone_params; @@ -11838,12 +11919,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); PERL_ARGS_ASSERT_PERL_CLONE; +#endif /* PERL_IMPLICIT_SYS */ /* for each stash, determine whether its objects should be cloned */ S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); PERL_SET_THX(my_perl); -# ifdef DEBUGGING +#ifdef DEBUGGING PoisonNew(my_perl, 1, PerlInterpreter); PL_op = NULL; PL_curcop = NULL; @@ -11856,10 +11938,12 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_sig_pending = 0; PL_parser = NULL; Zero(&PL_debug_pad, 1, struct perl_debug_pad); -# else /* !DEBUGGING */ +# ifdef DEBUG_LEAKING_SCALARS + PL_sv_serial = (((U32)my_perl >> 2) & 0xfff) * 1000000; +# endif +#else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); -# endif /* DEBUGGING */ -#endif /* PERL_IMPLICIT_SYS */ +#endif /* DEBUGGING */ #ifdef PERL_IMPLICIT_SYS /* host pointers */ @@ -11933,6 +12017,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvNV_set(&PL_sv_yes, 1); ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); + /* dbargs array probably holds garbage */ + PL_dbargs = NULL; + /* create (a non-shared!) shared string table */ PL_strtab = newHV(); HvSHAREKEYS_off(PL_strtab); @@ -12059,7 +12146,6 @@ 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_dbargs = av_dup(proto_perl->Idbargs, param); /* symbol tables */ PL_defstash = hv_dup_inc(proto_perl->Idefstash, param); @@ -12404,6 +12490,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param); PL_formtarget = sv_dup(proto_perl->Iformtarget, param); + PL_restartjmpenv = proto_perl->Irestartjmpenv; PL_restartop = proto_perl->Irestartop; PL_in_eval = proto_perl->Iin_eval; PL_delaymagic = proto_perl->Idelaymagic;