X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/93d7320bf7eac5942274854396d4ccc6268106c7..6e8be9cfdd52adfc933b189c5829c3088178a7fe:/sv.c diff --git a/sv.c b/sv.c index 4371375..e3426ad 100644 --- a/sv.c +++ b/sv.c @@ -32,6 +32,15 @@ #include "perl.h" #include "regcomp.h" +#ifndef HAS_C99 +# if __STDC_VERSION__ >= 199901L && !defined(VMS) +# define HAS_C99 1 +# endif +#endif +#if HAS_C99 +# include +#endif + #define FCALL *f #ifdef __Lynx__ @@ -71,7 +80,7 @@ many types, a pointer to the body (struct xrv, xpv, xpviv...), which contains fields specific to each type. Some types store all they need in the head, so don't have a body. -In all but the most memory-paranoid configuations (ex: PURIFY), heads +In all but the most memory-paranoid configurations (ex: PURIFY), heads and bodies are allocated out of arenas, which by default are approximately 4K chunks of memory parcelled up into N heads or bodies. Sv-bodies are allocated by their sv-type, guaranteeing size @@ -513,7 +522,7 @@ do_clean_named_objs(pTHX_ SV *const sv) if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) { DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob CV object:\n "), sv_dump(obj))); - GvCV(sv) = NULL; + GvCV_set(sv, NULL); SvREFCNT_dec(obj); } SvREFCNT_dec(sv); /* undo the inc above */ @@ -542,6 +551,15 @@ do_clean_named_io_objs(pTHX_ SV *const sv) SvREFCNT_dec(sv); /* undo the inc above */ } +/* Void wrapper to pass to visit() */ +static void +do_curse(pTHX_ SV * const sv) { + if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv) + || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv)) + return; + (void)curse(sv, 0); +} + /* =for apidoc sv_clean_objs @@ -562,6 +580,9 @@ Perl_sv_clean_objs(pTHX) * error messages, close files etc */ visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP); visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP); + /* And if there are some very tenacious barnacles clinging to arrays, + closures, or what have you.... */ + visit(do_curse, SVs_OBJECT, SVs_OBJECT); olddef = PL_defoutgv; PL_defoutgv = NULL; /* disable skip of PL_defoutgv */ if (olddef && isGV_with_GP(olddef)) @@ -872,37 +893,31 @@ static const struct body_details bodies_by_type[] = { NOARENA /* IVS don't need an arena */, 0 }, - /* 8 bytes on most ILP32 with IEEE doubles */ { sizeof(NV), sizeof(NV), STRUCT_OFFSET(XPVNV, xnv_u), SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) }, - /* 8 bytes on most ILP32 with IEEE doubles */ { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur), copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur), + STRUCT_OFFSET(XPV, xpv_cur), SVt_PV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) }, - /* 12 */ { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur), copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur), + STRUCT_OFFSET(XPV, xpv_cur), SVt_PVIV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) }, - /* 20 */ { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur), copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur), + STRUCT_OFFSET(XPV, xpv_cur), SVt_PVNV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) }, - /* 28 */ { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, - /* something big */ { sizeof(regexp), sizeof(regexp), 0, @@ -910,11 +925,9 @@ static const struct body_details bodies_by_type[] = { FIT_ARENA(0, sizeof(regexp)) }, - /* 48 */ { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVGV)) }, - /* 64 */ { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVLV)) }, @@ -930,7 +943,6 @@ static const struct body_details bodies_by_type[] = { SVt_PVHV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(XPVHV)) }, - /* 56 */ { sizeof(XPVCV), sizeof(XPVCV), 0, @@ -943,7 +955,6 @@ static const struct body_details bodies_by_type[] = { SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(XPVFM)) }, - /* XPVIO is 84 bytes, fits 48x */ { sizeof(XPVIO), sizeof(XPVIO), 0, @@ -1047,7 +1058,7 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, Remember, this is integer division: */ end = start + good_arena_size / body_size * body_size; - /* computed count doesnt reflect the 1st slot reservation */ + /* computed count doesn't reflect the 1st slot reservation */ #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE) DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %p end %p arena-size %d (from %d) type %d " @@ -1555,6 +1566,7 @@ Perl_sv_setiv(pTHX_ register SV *const sv, const IV i) case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: + /* diag_listed_as: Can't coerce %s to %s in %s */ Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), OP_DESC(PL_op)); default: NOOP; @@ -1664,6 +1676,7 @@ Perl_sv_setnv(pTHX_ register SV *const sv, const NV num) case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: + /* diag_listed_as: Can't coerce %s to %s in %s */ Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), OP_DESC(PL_op)); default: NOOP; @@ -2244,11 +2257,13 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags) dVAR; if (!sv) return 0; - 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 (SvGMAGICAL(sv) || SvVALID(sv)) { + /* FBMs use the space for SvIVX and SvNVX for other purposes, and use + the same flag bit as SVf_IVisUV, so must not let them cache IVs. + In practice they are extremely unlikely to actually get anywhere + accessible by user Perl code - the only way that I'm aware of is when + a constant subroutine which is used as the second argument to index. + */ if (flags & SV_GMAGIC) mg_get(sv); if (SvIOKp(sv)) @@ -2290,7 +2305,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags) SV * tmpstr; if (flags & SV_SKIP_OVERLOAD) return 0; - tmpstr=AMG_CALLun(sv,numer); + tmpstr = AMG_CALLunary(sv, numer_amg); if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { return SvIV(tmpstr); } @@ -2331,9 +2346,9 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags) dVAR; if (!sv) return 0; - 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 (SvGMAGICAL(sv) || SvVALID(sv)) { + /* FBMs use the space for SvIVX and SvNVX for other purposes, and use + the same flag bit as SVf_IVisUV, so must not let them cache IVs. */ if (flags & SV_GMAGIC) mg_get(sv); if (SvIOKp(sv)) @@ -2369,7 +2384,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags) SV *tmpstr; if (flags & SV_SKIP_OVERLOAD) return 0; - tmpstr = AMG_CALLun(sv,numer); + tmpstr = AMG_CALLunary(sv, numer_amg); if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { return SvUV(tmpstr); } @@ -2411,9 +2426,9 @@ Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags) dVAR; if (!sv) return 0.0; - 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 (SvGMAGICAL(sv) || SvVALID(sv)) { + /* FBMs use the space for SvIVX and SvNVX for other purposes, and use + the same flag bit as SVf_IVisUV, so must not let them cache NVs. */ if (flags & SV_GMAGIC) mg_get(sv); if (SvNOKp(sv)) @@ -2443,7 +2458,7 @@ Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags) SV *tmpstr; if (flags & SV_SKIP_OVERLOAD) return 0; - tmpstr = AMG_CALLun(sv,numer); + tmpstr = AMG_CALLunary(sv, numer_amg); if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { return SvNV(tmpstr); } @@ -2642,7 +2657,7 @@ Perl_sv_2num(pTHX_ register SV *const sv) if (!SvROK(sv)) return sv; if (SvAMAGIC(sv)) { - SV * const tmpsv = AMG_CALLun(sv,numer); + SV * const tmpsv = AMG_CALLunary(sv, numer_amg); TAINT_IF(tmpsv && SvTAINTED(tmpsv)); if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) return sv_2num(tmpsv); @@ -2761,7 +2776,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags SV *tmpstr; if (flags & SV_SKIP_OVERLOAD) return NULL; - tmpstr = AMG_CALLun(sv,string); + tmpstr = AMG_CALLunary(sv, string_amg); TAINT_IF(tmpstr && SvTAINTED(tmpstr)); if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { /* Unwrap this: */ @@ -2869,7 +2884,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags retval -= stashnamelen; memcpy(retval, stashname, stashnamelen); } - /* retval may not neccesarily have reached the start of the + /* retval may not necessarily have reached the start of the buffer here. */ assert (retval >= buffer); @@ -3084,7 +3099,7 @@ Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags) return 0; if (SvROK(sv)) { if (SvAMAGIC(sv)) { - SV * const tmpsv = AMG_CALLun(sv,bool_); + SV * const tmpsv = AMG_CALLunary(sv, bool__amg); if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) return cBOOL(SvTRUE(tmpsv)); } @@ -3198,7 +3213,7 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, ST return len; } } else { - (void) SvPV_force(sv,len); + (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC); } } @@ -3406,6 +3421,29 @@ must_be_utf8: } } } + + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + /* Update pos. We do it at the end rather than during + * the upgrade, to avoid slowing down the common case + * (upgrade without pos) */ + MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); + if (mg) { + I32 pos = mg->mg_len; + if (pos > 0 && (U32)pos > invariant_head) { + U8 *d = (U8*) SvPVX(sv) + invariant_head; + STRLEN n = (U32)pos - invariant_head; + while (n > 0) { + if (UTF8_IS_START(*d)) + d++; + d++; + n--; + } + mg->mg_len = d - (U8*)SvPVX(sv); + } + } + if ((mg = mg_find(sv, PERL_MAGIC_utf8))) + magic_setutf8(sv,mg); /* clear UTF8 cache */ + } } } @@ -3440,11 +3478,28 @@ Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok) if (SvCUR(sv)) { U8 *s; STRLEN len; + int mg_flags = SV_GMAGIC; if (SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); } - s = (U8 *) SvPV(sv, len); + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + /* update pos */ + MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); + if (mg) { + I32 pos = mg->mg_len; + if (pos > 0) { + sv_pos_b2u(sv, &pos); + mg_flags = 0; /* sv_pos_b2u does get magic */ + mg->mg_len = pos; + } + } + if ((mg = mg_find(sv, PERL_MAGIC_utf8))) + magic_setutf8(sv,mg); /* clear UTF8 cache */ + + } + s = (U8 *) SvPV_flags(sv, len, mg_flags); + if (!utf8_to_bytes(s, &len)) { if (fail_ok) return FALSE; @@ -3493,7 +3548,7 @@ Perl_sv_utf8_encode(pTHX_ register SV *const sv) If the PV of the SV is an octet sequence in UTF-8 and contains a multiple-byte character, the C flag is turned on so that it looks like a character. If the PV contains only single-byte -characters, the C flag stays being off. +characters, the C flag stays off. Scans PV for validity and returns false if the PV is invalid UTF-8. =cut @@ -3505,7 +3560,7 @@ Perl_sv_utf8_decode(pTHX_ register SV *const sv) PERL_ARGS_ASSERT_SV_UTF8_DECODE; if (SvPOKp(sv)) { - const U8 *c; + const U8 *start, *c; const U8 *e; /* The octets may have got themselves encoded - get them back as @@ -3517,7 +3572,7 @@ Perl_sv_utf8_decode(pTHX_ register SV *const sv) /* it is actually just a matter of turning the utf8 flag on, but * we want to make sure everything inside is valid utf8 first. */ - c = (const U8 *) SvPVX_const(sv); + c = start = (const U8 *) SvPVX_const(sv); if (!is_utf8_string(c, SvCUR(sv)+1)) return FALSE; e = (const U8 *) SvEND(sv); @@ -3528,6 +3583,22 @@ Perl_sv_utf8_decode(pTHX_ register SV *const sv) break; } } + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + /* adjust pos to the start of a UTF8 char sequence */ + MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); + if (mg) { + I32 pos = mg->mg_len; + if (pos > 0) { + for (c = start + pos; c > start; c--) { + if (UTF8_IS_START(*c)) + break; + } + mg->mg_len = c - start; + } + } + if ((mg = mg_find(sv, PERL_MAGIC_utf8))) + magic_setutf8(sv,mg); /* clear UTF8 cache */ + } } return TRUE; } @@ -3602,7 +3673,7 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) /* If source has method cache entry, clear it */ if(GvCVGEN(sstr)) { SvREFCNT_dec(GvCV(sstr)); - GvCV(sstr) = NULL; + GvCV_set(sstr, NULL); GvCVGEN(sstr) = 0; } /* If source has a real method, then a method is @@ -3636,7 +3707,8 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) mro_changes = 2; else { const STRLEN len = GvNAMELEN(dstr); - if (len > 1 && name[len-2] == ':' && name[len-1] == ':') { + if ((len > 1 && name[len-2] == ':' && name[len-1] == ':') + || (len == 1 && name[0] == ':')) { mro_changes = 3; /* Set aside the old stash, so we can reset isa caches on @@ -3655,7 +3727,7 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) (void)SvOK_off(dstr); isGV_with_GP_on(dstr); GvINTRO_off(dstr); /* one-shot flag */ - GvGP(dstr) = gp_ref(GvGP(sstr)); + GvGP_set(dstr, gp_ref(GvGP(sstr))); if (SvTAINTED(sstr)) SvTAINT(dstr); if (GvIMPORTED(dstr) != GVf_IMPORTED @@ -3710,7 +3782,7 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) GvMULTI_on(dstr); switch (stype) { case SVt_PVCV: - location = (SV **) &GvCV(dstr); + location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */ import_flag = GVf_IMPORTED_CV; goto common; case SVt_PVHV: @@ -3736,7 +3808,7 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/ if (GvCVGEN(dstr)) { SvREFCNT_dec(GvCV(dstr)); - GvCV(dstr) = NULL; + GvCV_set(dstr, NULL); GvCVGEN(dstr) = 0; /* Switch off cacheness. */ } } @@ -3796,7 +3868,10 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) const char * const name = GvNAME((GV*)dstr); const STRLEN len = GvNAMELEN(dstr); if ( - len > 1 && name[len-2] == ':' && name[len-1] == ':' + ( + (len > 1 && name[len-2] == ':' && name[len-1] == ':') + || (len == 1 && name[0] == ':') + ) && (!dref || HvENAME_get(dref)) ) { mro_package_moved( @@ -4003,8 +4078,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) /* case SVt_BIND: */ case SVt_PVLV: case SVt_PVGV: - /* SvVALID means that this PVGV is playing at being an FBM. */ - case SVt_PVMG: if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) { mg_get(sstr); @@ -4094,7 +4167,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) const STRLEN len = GvNAMELEN(dstr); HV *old_stash = NULL; bool reset_isa = FALSE; - if (len > 1 && name[len-2] == ':' && name[len-1] == ':') { + if ((len > 1 && name[len-2] == ':' && name[len-1] == ':') + || (len == 1 && name[0] == ':')) { /* Set aside the old stash, so we can reset isa caches on its subclasses. */ if((old_stash = GvHV(dstr))) { @@ -4108,7 +4182,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) if (GvGP(dstr)) gp_free(MUTABLE_GV(dstr)); - GvGP(dstr) = gp_ref(GvGP(gv)); + GvGP_set(dstr, gp_ref(GvGP(gv))); if (reset_isa) { HV * const stash = GvHV(dstr); @@ -4557,7 +4631,7 @@ Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 #endif if (flags & SV_HAS_TRAILING_NUL) { /* It's long enough - do nothing. - Specfically Perl_newCONSTSUB is relying on this. */ + Specifically Perl_newCONSTSUB is relying on this. */ } else { #ifdef DEBUGGING /* Force a move to shake out bugs in callers. */ @@ -4634,7 +4708,7 @@ we do the copy, and is also used locally. If C is set then a copy-on-write scalar drops its PV buffer (if any) and becomes SvPOK_off rather than making a copy. (Used where this scalar is about to be set to some other value.) In addition, the C parameter gets passed to -C when unrefing. C calls this function +C when unreffing. C calls this function with flags set to 0. =cut @@ -4692,7 +4766,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) } #else if (SvREADONLY(sv)) { - if (SvFAKE(sv)) { + if (SvFAKE(sv) && !isGV_with_GP(sv)) { const char * const pvx = SvPVX_const(sv); const STRLEN len = SvCUR(sv); SvFAKE_off(sv); @@ -4713,7 +4787,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) else if (SvFAKE(sv) && isGV_with_GP(sv)) sv_unglob(sv); else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) { - /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous + /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous 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); @@ -5021,7 +5095,7 @@ space is allocated.) The reference count for the new SV is set to 1. In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first parameter, I, a debug aid which allowed callers to identify themselves. This aid has been superseded by a new build option, PERL_MEM_LOG (see -L). The older API is still there for use in XS +L). The older API is still there for use in XS modules supporting older perls. =cut @@ -5118,7 +5192,7 @@ Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, mg->mg_ptr = savepvn(name, namlen); else if (namlen == HEf_SVKEY) { /* Yes, this is casting away const. This is only for the case of - HEf_SVKEY. I think we need to document this abberation of the + HEf_SVKEY. I think we need to document this aberation of the constness of the API, rather than making name non-const, as that change propagating outwards a long way. */ mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name); @@ -5155,9 +5229,25 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, dVAR; const MGVTBL *vtable; MAGIC* mg; + unsigned int flags; + unsigned int vtable_index; PERL_ARGS_ASSERT_SV_MAGIC; + if (how < 0 || (unsigned)how > C_ARRAY_LENGTH(PL_magic_data) + || ((flags = PL_magic_data[how]), + (vtable_index = flags & PERL_MAGIC_VTABLE_MASK) + > magic_vtable_max)) + Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how); + + /* PERL_MAGIC_ext is reserved for use by extensions not perl internals. + Useful for attaching extension internal data to perl vars. + Note that multiple extensions may clash if magical scalars + etc holding private data from one are passed to another. */ + + vtable = (vtable_index == magic_vtable_max) + ? NULL : PL_magic_vtables + vtable_index; + #ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); @@ -5169,11 +5259,7 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG) && IN_PERL_RUNTIME - && how != PERL_MAGIC_regex_global - && how != PERL_MAGIC_bm - && how != PERL_MAGIC_fm - && how != PERL_MAGIC_sv - && how != PERL_MAGIC_backref + && !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how) ) { Perl_croak_no_modify(aTHX); @@ -5195,127 +5281,6 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, } } - switch (how) { - case PERL_MAGIC_sv: - vtable = &PL_vtbl_sv; - break; - case PERL_MAGIC_overload: - vtable = &PL_vtbl_amagic; - break; - case PERL_MAGIC_overload_elem: - vtable = &PL_vtbl_amagicelem; - break; - case PERL_MAGIC_overload_table: - vtable = &PL_vtbl_ovrld; - break; - case PERL_MAGIC_bm: - vtable = &PL_vtbl_bm; - break; - case PERL_MAGIC_regdata: - vtable = &PL_vtbl_regdata; - break; - case PERL_MAGIC_regdatum: - vtable = &PL_vtbl_regdatum; - break; - case PERL_MAGIC_env: - vtable = &PL_vtbl_env; - break; - case PERL_MAGIC_fm: - vtable = &PL_vtbl_fm; - break; - case PERL_MAGIC_envelem: - vtable = &PL_vtbl_envelem; - break; - case PERL_MAGIC_regex_global: - vtable = &PL_vtbl_mglob; - break; - case PERL_MAGIC_isa: - vtable = &PL_vtbl_isa; - break; - case PERL_MAGIC_isaelem: - vtable = &PL_vtbl_isaelem; - break; - case PERL_MAGIC_nkeys: - vtable = &PL_vtbl_nkeys; - break; - case PERL_MAGIC_dbfile: - vtable = NULL; - break; - case PERL_MAGIC_dbline: - vtable = &PL_vtbl_dbline; - break; -#ifdef USE_LOCALE_COLLATE - case PERL_MAGIC_collxfrm: - vtable = &PL_vtbl_collxfrm; - break; -#endif /* USE_LOCALE_COLLATE */ - case PERL_MAGIC_tied: - vtable = &PL_vtbl_pack; - break; - case PERL_MAGIC_tiedelem: - case PERL_MAGIC_tiedscalar: - vtable = &PL_vtbl_packelem; - break; - case PERL_MAGIC_qr: - vtable = &PL_vtbl_regexp; - break; - case PERL_MAGIC_sig: - vtable = &PL_vtbl_sig; - break; - case PERL_MAGIC_sigelem: - vtable = &PL_vtbl_sigelem; - break; - case PERL_MAGIC_taint: - vtable = &PL_vtbl_taint; - break; - case PERL_MAGIC_uvar: - vtable = &PL_vtbl_uvar; - break; - case PERL_MAGIC_vec: - vtable = &PL_vtbl_vec; - break; - case PERL_MAGIC_arylen_p: - case PERL_MAGIC_rhash: - case PERL_MAGIC_symtab: - case PERL_MAGIC_vstring: - case PERL_MAGIC_checkcall: - vtable = NULL; - break; - case PERL_MAGIC_utf8: - vtable = &PL_vtbl_utf8; - break; - case PERL_MAGIC_substr: - vtable = &PL_vtbl_substr; - break; - case PERL_MAGIC_defelem: - vtable = &PL_vtbl_defelem; - break; - case PERL_MAGIC_arylen: - vtable = &PL_vtbl_arylen; - break; - case PERL_MAGIC_pos: - vtable = &PL_vtbl_pos; - break; - case PERL_MAGIC_backref: - vtable = &PL_vtbl_backref; - break; - case PERL_MAGIC_hintselem: - vtable = &PL_vtbl_hintselem; - break; - case PERL_MAGIC_hints: - vtable = &PL_vtbl_hints; - break; - case PERL_MAGIC_ext: - /* Reserved for use by extensions not perl internals. */ - /* Useful for attaching extension internal data to perl vars. */ - /* Note that multiple extensions may clash if magical scalars */ - /* etc holding private data from one are passed to another. */ - vtable = NULL; - break; - default: - Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how); - } - /* Rest of work is done else where */ mg = sv_magicext(sv,obj,how,vtable,name,namlen); @@ -5330,7 +5295,7 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, } } -int +static int S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags) { MAGIC* mg; @@ -5444,16 +5409,13 @@ Perl_sv_rvweaken(pTHX_ SV *const sv) * store it directly in the HvAUX or mg_obj slot, avoiding the need to * allocate an AV. (Whether the slot holds an AV tells us whether this is * active.) - * - * If an HV's backref is stored in magic, it is moved back to HvAUX. */ /* A discussion about the backreferences array and its refcount: * * The AV holding the backreferences is pointed to either as the mg_obj of - * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux - * structure, from the xhv_backreferences field. (A HV without hv_aux will - * have the standard magic instead.) The array is created with a refcount + * PERL_MAGIC_backref, or in the specific case of a HV, from the + * xhv_backreferences field. The array is created with a refcount * of 2. This means that if during global destruction the array gets * picked on before its parent to have its refcount decremented by the * random zapper, it won't actually be freed, meaning it's still there for @@ -5481,21 +5443,6 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) if (SvTYPE(tsv) == SVt_PVHV) { svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); - - if (!*svp) { - if ((mg = mg_find(tsv, PERL_MAGIC_backref))) { - /* Aha. They've got it stowed in magic instead. - * Move it back to xhv_backreferences */ - *svp = mg->mg_obj; - /* Stop mg_free decreasing the reference count. */ - mg->mg_obj = NULL; - /* Stop mg_free even calling the destructor, given that - there's no AV to free up. */ - mg->mg_virtual = 0; - sv_unmagic(tsv, PERL_MAGIC_backref); - mg = NULL; - } - } } else { if (! ((mg = (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL)))) @@ -5553,10 +5500,11 @@ Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv) PERL_ARGS_ASSERT_SV_DEL_BACKREF; - if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) { - svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); + if (SvTYPE(tsv) == SVt_PVHV) { + if (SvOOK(tsv)) + svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); } - if (!svp || !*svp) { + else { MAGIC *const mg = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; svp = mg ? &(mg->mg_obj) : NULL; @@ -5636,6 +5584,17 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av) if (!av) return; + /* after multiple passes through Perl_sv_clean_all() for a thinngy + * that has badly leaked, the backref array may have gotten freed, + * since we only protect it against 1 round of cleanup */ + if (SvIS_FREED(av)) { + if (PL_in_clean_all) /* All is fair */ + return; + Perl_croak(aTHX_ + "panic: magic_killbackrefs (freed backref AV/SV)"); + } + + is_array = (SvTYPE(av) == SVt_PVAV); if (is_array) { assert(!SvIS_FREED(av)); @@ -5908,7 +5867,8 @@ S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv) } /* if not, anonymise: */ - stash = GvSTASH(gv) ? HvNAME(GvSTASH(gv)) : NULL; + stash = GvSTASH(gv) && HvNAME(GvSTASH(gv)) + ? HvENAME(GvSTASH(gv)) : NULL; gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__", stash ? stash : "__ANON__"); anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV); @@ -5944,6 +5904,7 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) SV* iter_sv = NULL; SV* next_sv = NULL; register SV *sv = orig_sv; + STRLEN hash_index; PERL_ARGS_ASSERT_SV_CLEAR; @@ -5969,72 +5930,27 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) goto free_head; } - if (SvOBJECT(sv)) { - if (PL_defstash && /* Still have a symbol table? */ - SvDESTROYABLE(sv)) - { - dSP; - HV* stash; - do { - CV* destructor; - stash = SvSTASH(sv); - destructor = StashHANDLER(stash,DESTROY); - if (destructor - /* A constant subroutine can have no side effects, so - don't bother calling it. */ - && !CvCONST(destructor) - /* Don't bother calling an empty destructor */ - && (CvISXSUB(destructor) - || (CvSTART(destructor) - && (CvSTART(destructor)->op_next->op_type - != OP_LEAVESUB)))) - { - SV* const tmpref = newRV(sv); - SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ - ENTER; - PUSHSTACKi(PERLSI_DESTROY); - EXTEND(SP, 2); - PUSHMARK(SP); - PUSHs(tmpref); - PUTBACK; - call_sv(MUTABLE_SV(destructor), - G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); - POPSTACK; - SPAGAIN; - LEAVE; - if(SvREFCNT(tmpref) < 2) { - /* tmpref is not kept alive! */ - SvREFCNT(sv)--; - SvRV_set(tmpref, NULL); - SvROK_off(tmpref); - } - SvREFCNT_dec(tmpref); - } - } while (SvOBJECT(sv) && SvSTASH(sv) != stash); - - - if (SvREFCNT(sv)) { - if (PL_in_clean_objs) - Perl_croak(aTHX_ - "DESTROY created new reference to dead object '%s'", - HvNAME_get(stash)); - /* DESTROY gave object new lease on life */ - goto get_next_sv; - } - } + assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */ + if (type >= SVt_PVMG) { if (SvOBJECT(sv)) { - SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */ - SvOBJECT_off(sv); /* Curse the object. */ - if (type != SVt_PVIO) - --PL_sv_objcount;/* XXX Might want something more general */ + if (!curse(sv, 1)) goto get_next_sv; + type = SvTYPE(sv); /* destructor may have changed it */ } - } - if (type >= SVt_PVMG) { - if (type == SVt_PVMG && SvPAD_OUR(sv)) { + /* Free back-references before magic, in case the magic calls + * Perl code that has weak references to sv. */ + if (type == SVt_PVHV) { + Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); + if (SvMAGIC(sv)) + mg_free(sv); + } + else if (type == SVt_PVMG && SvPAD_OUR(sv)) { SvREFCNT_dec(SvOURSTASH(sv)); - } else if (SvMAGIC(sv)) + } else if (SvMAGIC(sv)) { + /* Free back-references before other types of magic. */ + sv_unmagic(sv, PERL_MAGIC_backref); mg_free(sv); + } if (type == SVt_PVMG && SvPAD_TYPED(sv)) SvREFCNT_dec(SvSTASH(sv)); } @@ -6073,8 +5989,38 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) if (PL_last_swash_hv == (const HV *)sv) { PL_last_swash_hv = NULL; } - Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); + if (HvTOTALKEYS((HV*)sv) > 0) { + const char *name; + /* this statement should match the one at the beginning of + * hv_undef_flags() */ + if ( PL_phase != PERL_PHASE_DESTRUCT + && (name = HvNAME((HV*)sv))) + { + if (PL_stashcache) + (void)hv_delete(PL_stashcache, name, + HvNAMELEN_get((HV*)sv), G_DISCARD); + hv_name_set((HV*)sv, NULL, 0, 0); + } + + /* save old iter_sv in unused SvSTASH field */ + assert(!SvOBJECT(sv)); + SvSTASH(sv) = (HV*)iter_sv; + iter_sv = sv; + + /* XXX ideally we should save the old value of hash_index + * too, but I can't think of any place to hide it. The + * effect of not saving it is that for freeing hashes of + * hashes, we become quadratic in scanning the HvARRAY of + * the top hash looking for new entries to free; but + * hopefully this will be dwarfed by the freeing of all + * the nested hashes. */ + hash_index = 0; + next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index); + goto get_next_sv; /* process this new sv */ + } + /* free empty hash */ Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL); + assert(!HvARRAY((HV*)sv)); break; case SVt_PVAV: { @@ -6223,6 +6169,25 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) Safefree(AvALLOC(av)); goto free_body; } + } else if (SvTYPE(iter_sv) == SVt_PVHV) { + sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index); + if (!sv && !HvTOTALKEYS((HV *)iter_sv)) { + /* no more elements of current HV to free */ + sv = iter_sv; + type = SvTYPE(sv); + /* Restore previous value of iter_sv, squirrelled away */ + assert(!SvOBJECT(sv)); + iter_sv = (SV*)SvSTASH(sv); + + /* ideally we should restore the old hash_index here, + * but we don't currently save the old value */ + hash_index = 0; + + /* free any remaining detritus from the hash struct */ + Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL); + assert(!HvARRAY((HV*)sv)); + goto free_body; + } } /* unrolled SvREFCNT_dec and sv_free2 follows: */ @@ -6254,6 +6219,78 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) } /* while sv */ } +/* This routine curses the sv itself, not the object referenced by sv. So + sv does not have to be ROK. */ + +static bool +S_curse(pTHX_ SV * const sv, const bool check_refcnt) { + dVAR; + + PERL_ARGS_ASSERT_CURSE; + assert(SvOBJECT(sv)); + + if (PL_defstash && /* Still have a symbol table? */ + SvDESTROYABLE(sv)) + { + dSP; + HV* stash; + do { + CV* destructor; + stash = SvSTASH(sv); + destructor = StashHANDLER(stash,DESTROY); + if (destructor + /* A constant subroutine can have no side effects, so + don't bother calling it. */ + && !CvCONST(destructor) + /* Don't bother calling an empty destructor */ + && (CvISXSUB(destructor) + || (CvSTART(destructor) + && (CvSTART(destructor)->op_next->op_type + != OP_LEAVESUB)))) + { + SV* const tmpref = newRV(sv); + SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ + ENTER; + PUSHSTACKi(PERLSI_DESTROY); + EXTEND(SP, 2); + PUSHMARK(SP); + PUSHs(tmpref); + PUTBACK; + call_sv(MUTABLE_SV(destructor), + G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); + POPSTACK; + SPAGAIN; + LEAVE; + if(SvREFCNT(tmpref) < 2) { + /* tmpref is not kept alive! */ + SvREFCNT(sv)--; + SvRV_set(tmpref, NULL); + SvROK_off(tmpref); + } + SvREFCNT_dec(tmpref); + } + } while (SvOBJECT(sv) && SvSTASH(sv) != stash); + + + if (check_refcnt && SvREFCNT(sv)) { + if (PL_in_clean_objs) + Perl_croak(aTHX_ + "DESTROY created new reference to dead object '%s'", + HvNAME_get(stash)); + /* DESTROY gave object new lease on life */ + return FALSE; + } + } + + if (SvOBJECT(sv)) { + SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */ + SvOBJECT_off(sv); /* Curse the object. */ + if (SvTYPE(sv) != SVt_PVIO) + --PL_sv_objcount;/* XXX Might want something more general */ + } + return TRUE; +} + /* =for apidoc sv_newref @@ -6825,7 +6862,7 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN b /* Cache has 2 slots in use, and we know three potential pairs. Keep the two that give the lowest RMS distance. Do the - calcualation in bytes simply because we always know the byte + calculation in bytes simply because we always know the byte length. squareroot has the same ordering as the positive value, so don't bother with the actual square root. */ const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen); @@ -7718,7 +7755,7 @@ screamer2: } else { cnt = PerlIO_read(fp,(char*)buf, sizeof(buf)); - /* Accomodate broken VAXC compiler, which applies U8 cast to + /* Accommodate broken VAXC compiler, which applies U8 cast to * both args of ?: operator, causing EOF to change into 255 */ if (cnt > 0) @@ -7818,7 +7855,7 @@ Perl_sv_inc_nomg(pTHX_ register SV *const sv) } if (SvROK(sv)) { IV i; - if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) + if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg)) return; i = PTR2IV(SvRV(sv)); sv_unref(sv); @@ -7999,7 +8036,7 @@ Perl_sv_dec_nomg(pTHX_ register SV *const sv) } if (SvROK(sv)) { IV i; - if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) + if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg)) return; i = PTR2IV(SvRV(sv)); sv_unref(sv); @@ -8189,11 +8226,11 @@ Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags sv_setpvn(sv,s,len); /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal() - * and do what it does outselves here. + * and do what it does ourselves here. * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we - * eleminate quite a few steps than it looks - Yves (explaining patch by gfx) + * eliminate quite a few steps than it looks - Yves (explaining patch by gfx) */ SvFLAGS(sv) |= flags; @@ -8950,6 +8987,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) } if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) || isGV_with_GP(sv)) + /* diag_listed_as: Can't coerce %s to %s in %s */ Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), OP_DESC(PL_op)); s = sv_2pv_flags(sv, &len, flags); @@ -9050,7 +9088,7 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) case SVt_PVLV: return (char *) (SvROK(sv) ? "REF" /* tied lvalues should appear to be - * scalars for backwards compatitbility */ + * scalars for backwards compatibility */ : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T') ? "SCALAR" : "LVALUE"); case SVt_PVAV: return "ARRAY"; @@ -9437,6 +9475,7 @@ Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags) =for apidoc sv_untaint Untaint an SV. Use C instead. + =cut */ @@ -9456,6 +9495,7 @@ Perl_sv_untaint(pTHX_ SV *const sv) =for apidoc sv_tainted Test an SV for taintedness. Use C instead. + =cut */ @@ -10143,59 +10183,28 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, width = expect_number(&q); } - if (vectorize) { - if (vectorarg) { - if (args) - vecsv = va_arg(*args, SV*); - else if (evix) { - vecsv = (evix > 0 && evix <= svmax) - ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX); - } else { - vecsv = svix < svmax - ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX); - } - dotstr = SvPV_const(vecsv, dotstrlen); - /* Keep the DO_UTF8 test *after* the SvPV call, else things go - bad with tied or overloaded values that return UTF8. */ - if (DO_UTF8(vecsv)) - is_utf8 = TRUE; - else if (has_utf8) { - vecsv = sv_mortalcopy(vecsv); - sv_utf8_upgrade(vecsv); - dotstr = SvPV_const(vecsv, dotstrlen); - is_utf8 = TRUE; - } - } - if (args) { - VECTORIZE_ARGS - } - else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) { - vecsv = svargs[efix ? efix-1 : svix++]; - vecstr = (U8*)SvPV_const(vecsv,veclen); - vec_utf8 = DO_UTF8(vecsv); - - /* if this is a version object, we need to convert - * back into v-string notation and then let the - * vectorize happen normally - */ - if (sv_derived_from(vecsv, "version")) { - char *version = savesvpv(vecsv); - if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) { - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "vector argument not supported with alpha versions"); - goto unknown; - } - vecsv = sv_newmortal(); - scan_vstring(version, version + veclen, vecsv); - vecstr = (U8*)SvPV_const(vecsv, veclen); - vec_utf8 = DO_UTF8(vecsv); - Safefree(version); - } - } - else { - vecstr = (U8*)""; - veclen = 0; + if (vectorize && vectorarg) { + /* vectorizing, but not with the default "." */ + if (args) + vecsv = va_arg(*args, SV*); + else if (evix) { + vecsv = (evix > 0 && evix <= svmax) + ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX); + } else { + vecsv = svix < svmax + ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX); } + dotstr = SvPV_const(vecsv, dotstrlen); + /* Keep the DO_UTF8 test *after* the SvPV call, else things go + bad with tied or overloaded values that return UTF8. */ + if (DO_UTF8(vecsv)) + is_utf8 = TRUE; + else if (has_utf8) { + vecsv = sv_mortalcopy(vecsv); + sv_utf8_upgrade(vecsv); + dotstr = SvPV_const(vecsv, dotstrlen); + is_utf8 = TRUE; + } } if (asterisk) { @@ -10236,6 +10245,39 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, } } + if (vectorize) { + if (args) { + VECTORIZE_ARGS + } + else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) { + vecsv = svargs[efix ? efix-1 : svix++]; + vecstr = (U8*)SvPV_const(vecsv,veclen); + vec_utf8 = DO_UTF8(vecsv); + + /* if this is a version object, we need to convert + * back into v-string notation and then let the + * vectorize happen normally + */ + if (sv_derived_from(vecsv, "version")) { + char *version = savesvpv(vecsv); + if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) { + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), + "vector argument not supported with alpha versions"); + goto unknown; + } + vecsv = sv_newmortal(); + scan_vstring(version, version + veclen, vecsv); + vecstr = (U8*)SvPV_const(vecsv, veclen); + vec_utf8 = DO_UTF8(vecsv); + Safefree(version); + } + } + else { + vecstr = (U8*)""; + veclen = 0; + } + } + /* SIZE */ switch (*q) { @@ -10269,17 +10311,30 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, break; #endif case 'l': + ++q; #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE) - if (*(q + 1) == 'l') { /* lld, llf */ + if (*q == 'l') { /* lld, llf */ intsize = 'q'; - q += 2; - break; - } + ++q; + } + else #endif - /*FALLTHROUGH*/ + intsize = 'l'; + break; case 'h': - /*FALLTHROUGH*/ + if (*++q == 'h') { /* hhd, hhu */ + intsize = 'c'; + ++q; + } + else + intsize = 'h'; + break; case 'V': + case 'z': + case 't': +#if HAS_C99 + case 'j': +#endif intsize = *q++; break; } @@ -10405,10 +10460,16 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, } else if (args) { switch (intsize) { + case 'c': iv = (char)va_arg(*args, int); break; case 'h': iv = (short)va_arg(*args, int); break; case 'l': iv = va_arg(*args, long); break; case 'V': iv = va_arg(*args, IV); break; + case 'z': iv = va_arg(*args, SSize_t); break; + case 't': iv = va_arg(*args, ptrdiff_t); break; default: iv = va_arg(*args, int); break; +#if HAS_C99 + case 'j': iv = va_arg(*args, intmax_t); break; +#endif case 'q': #ifdef HAS_QUAD iv = va_arg(*args, Quad_t); break; @@ -10420,6 +10481,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, else { IV tiv = SvIV(argsv); /* work around GCC bug #13488 */ switch (intsize) { + case 'c': iv = (char)tiv; break; case 'h': iv = (short)tiv; break; case 'l': iv = (long)tiv; break; case 'V': @@ -10496,9 +10558,15 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, } else if (args) { switch (intsize) { + case 'c': uv = (unsigned char)va_arg(*args, unsigned); break; case 'h': uv = (unsigned short)va_arg(*args, unsigned); break; case 'l': uv = va_arg(*args, unsigned long); break; case 'V': uv = va_arg(*args, UV); break; + case 'z': uv = va_arg(*args, Size_t); break; + case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */ +#if HAS_C99 + case 'j': uv = va_arg(*args, uintmax_t); break; +#endif default: uv = va_arg(*args, unsigned); break; case 'q': #ifdef HAS_QUAD @@ -10511,6 +10579,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, else { UV tuv = SvUV(argsv); /* work around GCC bug #13488 */ switch (intsize) { + case 'c': uv = (unsigned char)tuv; break; case 'h': uv = (unsigned short)tuv; break; case 'l': uv = (unsigned long)tuv; break; case 'V': @@ -10621,7 +10690,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, #else /*FALLTHROUGH*/ #endif + case 'c': case 'h': + case 'z': + case 't': + case 'j': goto unknown; } @@ -10801,10 +10874,16 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, i = SvCUR(sv) - origlen; if (args) { switch (intsize) { + case 'c': *(va_arg(*args, char*)) = i; break; case 'h': *(va_arg(*args, short*)) = i; break; default: *(va_arg(*args, int*)) = i; break; case 'l': *(va_arg(*args, long*)) = i; break; case 'V': *(va_arg(*args, IV*)) = i; break; + case 'z': *(va_arg(*args, SSize_t*)) = i; break; + case 't': *(va_arg(*args, ptrdiff_t*)) = i; break; +#if HAS_C99 + case 'j': *(va_arg(*args, intmax_t*)) = i; break; +#endif case 'q': #ifdef HAS_QUAD *(va_arg(*args, Quad_t*)) = i; break; @@ -11550,7 +11629,7 @@ Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const pa SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1)); if (SvREADONLY(sstr) && SvFAKE(sstr)) { /* Not that normal - actually sstr is copy on write. - But we are a true, independant SV, so: */ + But we are a true, independent SV, so: */ SvREADONLY_off(dstr); SvFAKE_off(dstr); } @@ -11776,7 +11855,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); if (param->flags & CLONEf_JOIN_IN) Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr); - GvGP(dstr) = gp_dup(GvGP(sstr), param); + GvGP_set(dstr, gp_dup(GvGP(sstr), param)); (void)GpREFCNT_inc(GvGP(dstr)); } break; @@ -12053,7 +12132,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) ncx->blk_loop.state_u.lazysv.end = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param); /* We are taking advantage of av_dup_inc and sv_dup_inc - actually being the same function, and order equivalance of + actually being the same function, and order equivalence of the two unions. We can assert the later [but only at run time :-(] */ assert ((void *) &ncx->blk_loop.state_u.ary.ary == @@ -12625,6 +12704,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PoisonNew(my_perl, 1, PerlInterpreter); PL_op = NULL; PL_curcop = NULL; + PL_defstash = NULL; /* may be used by perl malloc() */ PL_markstack = 0; PL_scopestack = 0; PL_scopestack_name = 0; @@ -12678,67 +12758,23 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_hash_seed = proto_perl->Ihash_seed; PL_rehash_seed = proto_perl->Irehash_seed; -#ifdef USE_REENTRANT_API - /* XXX: things like -Dm will segfault here in perlio, but doing - * PERL_SET_CONTEXT(proto_perl); - * breaks too many other things - */ - Perl_reentrant_init(aTHX); -#endif - - /* create SV map for pointer relocation */ - PL_ptr_table = ptr_table_new(); - - /* initialize these special pointers as early as possible */ SvANY(&PL_sv_undef) = NULL; SvREFCNT(&PL_sv_undef) = (~(U32)0)/2; SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; - ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); - - SvANY(&PL_sv_no) = new_XPVNV(); SvREFCNT(&PL_sv_no) = (~(U32)0)/2; SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; - SvPV_set(&PL_sv_no, savepvn(PL_No, 0)); - SvCUR_set(&PL_sv_no, 0); - SvLEN_set(&PL_sv_no, 1); - SvIV_set(&PL_sv_no, 0); - SvNV_set(&PL_sv_no, 0); - ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); SvANY(&PL_sv_yes) = new_XPVNV(); SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; - SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1)); - SvCUR_set(&PL_sv_yes, 1); - SvLEN_set(&PL_sv_yes, 2); - SvIV_set(&PL_sv_yes, 1); - 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); - hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab)); - ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab); - PL_compiling = proto_perl->Icompiling; - /* These two PVs will be free'd special way so must set them same way op.c does */ - PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv); - ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv); - - PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file); - ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file); - - ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); - PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); - CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling))); - PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl); #ifdef PERL_DEBUG_READONLY_OPS PL_slabs = NULL; PL_slab_count = 0; @@ -12748,6 +12784,265 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_origargc = proto_perl->Iorigargc; PL_origargv = proto_perl->Iorigargv; + /* Set tainting stuff before PerlIO_debug can possibly get called */ + PL_tainting = proto_perl->Itainting; + PL_taint_warn = proto_perl->Itaint_warn; + + PL_minus_c = proto_perl->Iminus_c; + + PL_localpatches = proto_perl->Ilocalpatches; + PL_splitstr = proto_perl->Isplitstr; + PL_minus_n = proto_perl->Iminus_n; + PL_minus_p = proto_perl->Iminus_p; + PL_minus_l = proto_perl->Iminus_l; + PL_minus_a = proto_perl->Iminus_a; + PL_minus_E = proto_perl->Iminus_E; + PL_minus_F = proto_perl->Iminus_F; + PL_doswitches = proto_perl->Idoswitches; + PL_dowarn = proto_perl->Idowarn; + PL_sawampersand = proto_perl->Isawampersand; + PL_unsafe = proto_perl->Iunsafe; + PL_perldb = proto_perl->Iperldb; + PL_perl_destruct_level = proto_perl->Iperl_destruct_level; + PL_exit_flags = proto_perl->Iexit_flags; + + /* XXX time(&PL_basetime) when asked for? */ + PL_basetime = proto_perl->Ibasetime; + + PL_maxsysfd = proto_perl->Imaxsysfd; + PL_statusvalue = proto_perl->Istatusvalue; +#ifdef VMS + PL_statusvalue_vms = proto_perl->Istatusvalue_vms; +#else + PL_statusvalue_posix = proto_perl->Istatusvalue_posix; +#endif + + /* RE engine related */ + Zero(&PL_reg_state, 1, struct re_save_state); + PL_reginterp_cnt = 0; + PL_regmatch_slab = NULL; + + PL_sub_generation = proto_perl->Isub_generation; + + /* funky return mechanisms */ + PL_forkprocess = proto_perl->Iforkprocess; + + /* internal state */ + PL_maxo = proto_perl->Imaxo; + + PL_main_start = proto_perl->Imain_start; + PL_eval_root = proto_perl->Ieval_root; + PL_eval_start = proto_perl->Ieval_start; + + PL_filemode = proto_perl->Ifilemode; + PL_lastfd = proto_perl->Ilastfd; + PL_oldname = proto_perl->Ioldname; /* XXX not quite right */ + PL_Argv = NULL; + PL_Cmd = NULL; + PL_gensym = proto_perl->Igensym; + + PL_laststatval = proto_perl->Ilaststatval; + PL_laststype = proto_perl->Ilaststype; + PL_mess_sv = NULL; + + PL_profiledata = NULL; + + PL_generation = proto_perl->Igeneration; + + PL_in_clean_objs = proto_perl->Iin_clean_objs; + PL_in_clean_all = proto_perl->Iin_clean_all; + + PL_uid = proto_perl->Iuid; + PL_euid = proto_perl->Ieuid; + PL_gid = proto_perl->Igid; + PL_egid = proto_perl->Iegid; + PL_nomemok = proto_perl->Inomemok; + PL_an = proto_perl->Ian; + PL_evalseq = proto_perl->Ievalseq; + PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */ + PL_origalen = proto_perl->Iorigalen; + + PL_sighandlerp = proto_perl->Isighandlerp; + + PL_runops = proto_perl->Irunops; + + PL_subline = proto_perl->Isubline; + +#ifdef FCRYPT + PL_cryptseen = proto_perl->Icryptseen; +#endif + + PL_hints = proto_perl->Ihints; + + PL_amagic_generation = proto_perl->Iamagic_generation; + +#ifdef USE_LOCALE_COLLATE + PL_collation_ix = proto_perl->Icollation_ix; + PL_collation_standard = proto_perl->Icollation_standard; + PL_collxfrm_base = proto_perl->Icollxfrm_base; + PL_collxfrm_mult = proto_perl->Icollxfrm_mult; +#endif /* USE_LOCALE_COLLATE */ + +#ifdef USE_LOCALE_NUMERIC + PL_numeric_standard = proto_perl->Inumeric_standard; + PL_numeric_local = proto_perl->Inumeric_local; +#endif /* !USE_LOCALE_NUMERIC */ + + /* Did the locale setup indicate UTF-8? */ + PL_utf8locale = proto_perl->Iutf8locale; + /* Unicode features (see perlrun/-C) */ + PL_unicode = proto_perl->Iunicode; + + /* Pre-5.8 signals control */ + PL_signals = proto_perl->Isignals; + + /* times() ticks per second */ + PL_clocktick = proto_perl->Iclocktick; + + /* Recursion stopper for PerlIO_find_layer */ + PL_in_load_module = proto_perl->Iin_load_module; + + /* sort() routine */ + PL_sort_RealCmp = proto_perl->Isort_RealCmp; + + /* Not really needed/useful since the reenrant_retint is "volatile", + * but do it for consistency's sake. */ + PL_reentrant_retint = proto_perl->Ireentrant_retint; + + /* Hooks to shared SVs and locks. */ + PL_sharehook = proto_perl->Isharehook; + PL_lockhook = proto_perl->Ilockhook; + PL_unlockhook = proto_perl->Iunlockhook; + PL_threadhook = proto_perl->Ithreadhook; + PL_destroyhook = proto_perl->Idestroyhook; + PL_signalhook = proto_perl->Isignalhook; + +#ifdef THREADS_HAVE_PIDS + PL_ppid = proto_perl->Ippid; +#endif + + /* swatch cache */ + PL_last_swash_hv = NULL; /* reinits on demand */ + PL_last_swash_klen = 0; + PL_last_swash_key[0]= '\0'; + PL_last_swash_tmps = (U8*)NULL; + PL_last_swash_slen = 0; + + PL_glob_index = proto_perl->Iglob_index; + PL_srand_called = proto_perl->Isrand_called; + + if (flags & CLONEf_COPY_STACKS) { + /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ + PL_tmps_ix = proto_perl->Itmps_ix; + PL_tmps_max = proto_perl->Itmps_max; + PL_tmps_floor = proto_perl->Itmps_floor; + + /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] + * NOTE: unlike the others! */ + PL_scopestack_ix = proto_perl->Iscopestack_ix; + PL_scopestack_max = proto_perl->Iscopestack_max; + + /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] + * NOTE: unlike the others! */ + PL_savestack_ix = proto_perl->Isavestack_ix; + PL_savestack_max = proto_perl->Isavestack_max; + } + + PL_start_env = proto_perl->Istart_env; /* XXXXXX */ + PL_top_env = &PL_start_env; + + PL_op = proto_perl->Iop; + + PL_Sv = NULL; + PL_Xpv = (XPV*)NULL; + my_perl->Ina = proto_perl->Ina; + + PL_statbuf = proto_perl->Istatbuf; + PL_statcache = proto_perl->Istatcache; + +#ifdef HAS_TIMES + PL_timesbuf = proto_perl->Itimesbuf; +#endif + + PL_tainted = proto_perl->Itainted; + PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */ + + PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */ + + PL_restartjmpenv = proto_perl->Irestartjmpenv; + PL_restartop = proto_perl->Irestartop; + PL_in_eval = proto_perl->Iin_eval; + PL_delaymagic = proto_perl->Idelaymagic; + PL_phase = proto_perl->Iphase; + PL_localizing = proto_perl->Ilocalizing; + + PL_hv_fetch_ent_mh = NULL; + PL_modcount = proto_perl->Imodcount; + PL_lastgotoprobe = NULL; + PL_dumpindent = proto_perl->Idumpindent; + + PL_efloatbuf = NULL; /* reinits on demand */ + PL_efloatsize = 0; /* reinits on demand */ + + /* regex stuff */ + + 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->Ipeepp; + PL_rpeepp = proto_perl->Irpeepp; + /* op_free() hook */ + PL_opfreehook = proto_perl->Iopfreehook; + +#ifdef USE_REENTRANT_API + /* XXX: things like -Dm will segfault here in perlio, but doing + * PERL_SET_CONTEXT(proto_perl); + * breaks too many other things + */ + Perl_reentrant_init(aTHX); +#endif + + /* create SV map for pointer relocation */ + PL_ptr_table = ptr_table_new(); + + /* initialize these special pointers as early as possible */ + ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); + + SvANY(&PL_sv_no) = new_XPVNV(); + SvPV_set(&PL_sv_no, savepvn(PL_No, 0)); + SvCUR_set(&PL_sv_no, 0); + SvLEN_set(&PL_sv_no, 1); + SvIV_set(&PL_sv_no, 0); + SvNV_set(&PL_sv_no, 0); + ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); + + SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1)); + SvCUR_set(&PL_sv_yes, 1); + SvLEN_set(&PL_sv_yes, 2); + SvIV_set(&PL_sv_yes, 1); + SvNV_set(&PL_sv_yes, 1); + ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); + + /* create (a non-shared!) shared string table */ + PL_strtab = newHV(); + HvSHAREKEYS_off(PL_strtab); + hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab)); + ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab); + + /* These two PVs will be free'd special way so must set them same way op.c does */ + PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv); + ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv); + + PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file); + ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file); + + ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); + PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); + CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling))); + PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl); + param->stashes = newAV(); /* Setup array of objects to call clone on */ /* This makes no difference to the implementation, as it always pushes and shifts pointers to other SVs without changing their reference @@ -12761,10 +13056,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, param->unreferenced = newAV(); } - /* Set tainting stuff before PerlIO_debug can possibly get called */ - PL_tainting = proto_perl->Itainting; - PL_taint_warn = proto_perl->Itaint_warn; - #ifdef PERLIO_LAYERS /* Clone PerlIO tables as soon as we can handle general xx_dup() */ PerlIO_clone(aTHX_ proto_perl, param); @@ -12778,39 +13069,14 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param); /* switches */ - PL_minus_c = proto_perl->Iminus_c; PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param); PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param); - PL_localpatches = proto_perl->Ilocalpatches; - PL_splitstr = proto_perl->Isplitstr; - PL_minus_n = proto_perl->Iminus_n; - PL_minus_p = proto_perl->Iminus_p; - PL_minus_l = proto_perl->Iminus_l; - PL_minus_a = proto_perl->Iminus_a; - PL_minus_E = proto_perl->Iminus_E; - PL_minus_F = proto_perl->Iminus_F; - PL_doswitches = proto_perl->Idoswitches; - PL_dowarn = proto_perl->Idowarn; - PL_sawampersand = proto_perl->Isawampersand; - PL_unsafe = proto_perl->Iunsafe; PL_inplace = SAVEPV(proto_perl->Iinplace); PL_e_script = sv_dup_inc(proto_perl->Ie_script, param); - PL_perldb = proto_perl->Iperldb; - PL_perl_destruct_level = proto_perl->Iperl_destruct_level; - PL_exit_flags = proto_perl->Iexit_flags; /* magical thingies */ - /* XXX time(&PL_basetime) when asked for? */ - PL_basetime = proto_perl->Ibasetime; PL_formfeed = sv_dup(proto_perl->Iformfeed, param); - PL_maxsysfd = proto_perl->Imaxsysfd; - PL_statusvalue = proto_perl->Istatusvalue; -#ifdef VMS - PL_statusvalue_vms = proto_perl->Istatusvalue_vms; -#else - PL_statusvalue_posix = proto_perl->Istatusvalue_posix; -#endif PL_encoding = sv_dup(proto_perl->Iencoding, param); sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */ @@ -12818,11 +13084,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, sv_setpvs(PERL_DEBUG_PAD(2), ""); /* 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 */ /* ORANGE FIXME for plugins, probably in the SV dup code. newSViv(PTR2IV(CALLREGDUPE( @@ -12870,17 +13131,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_checkav = av_dup_inc(proto_perl->Icheckav, param); 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); - /* funky return mechanisms */ - PL_forkprocess = proto_perl->Iforkprocess; - /* subprocess state */ PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param); - /* internal state */ - PL_maxo = proto_perl->Imaxo; if (proto_perl->Iop_mask) PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo); else @@ -12892,23 +13147,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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; /* runtime control stuff */ PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl); - PL_filemode = proto_perl->Ifilemode; - PL_lastfd = proto_perl->Ilastfd; - PL_oldname = proto_perl->Ioldname; /* XXX not quite right */ - PL_Argv = NULL; - PL_Cmd = NULL; - PL_gensym = proto_perl->Igensym; PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param); - PL_laststatval = proto_perl->Ilaststatval; - PL_laststype = proto_perl->Ilaststype; - PL_mess_sv = NULL; PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param); @@ -12941,8 +13184,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param); PL_custom_ops = hv_dup_inc(proto_perl->Icustom_ops, param); - PL_profiledata = NULL; - PL_compcv = cv_dup(proto_perl->Icompcv, param); PAD_CLONE_VARS(proto_perl, param); @@ -12951,30 +13192,12 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); #endif - /* more statics moved here */ - PL_generation = proto_perl->Igeneration; PL_DBcv = cv_dup(proto_perl->IDBcv, param); - PL_in_clean_objs = proto_perl->Iin_clean_objs; - PL_in_clean_all = proto_perl->Iin_clean_all; - - PL_uid = proto_perl->Iuid; - PL_euid = proto_perl->Ieuid; - PL_gid = proto_perl->Igid; - PL_egid = proto_perl->Iegid; - PL_nomemok = proto_perl->Inomemok; - PL_an = proto_perl->Ian; - PL_evalseq = proto_perl->Ievalseq; - PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */ - PL_origalen = proto_perl->Iorigalen; #ifdef PERL_USES_PL_PIDSTATUS PL_pidstatus = newHV(); /* XXX flag for cloning? */ #endif PL_osname = SAVEPV(proto_perl->Iosname); - PL_sighandlerp = proto_perl->Isighandlerp; - - PL_runops = proto_perl->Irunops; - PL_parser = parser_dup(proto_perl->Iparser, param); /* XXX this only works if the saved cop has already been cloned */ @@ -12984,29 +13207,14 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, proto_perl); } - PL_subline = proto_perl->Isubline; PL_subname = sv_dup_inc(proto_perl->Isubname, param); -#ifdef FCRYPT - PL_cryptseen = proto_perl->Icryptseen; -#endif - - PL_hints = proto_perl->Ihints; - - PL_amagic_generation = proto_perl->Iamagic_generation; - #ifdef USE_LOCALE_COLLATE - PL_collation_ix = proto_perl->Icollation_ix; PL_collation_name = SAVEPV(proto_perl->Icollation_name); - PL_collation_standard = proto_perl->Icollation_standard; - PL_collxfrm_base = proto_perl->Icollxfrm_base; - PL_collxfrm_mult = proto_perl->Icollxfrm_mult; #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC PL_numeric_name = SAVEPV(proto_perl->Inumeric_name); - PL_numeric_standard = proto_perl->Inumeric_standard; - PL_numeric_local = proto_perl->Inumeric_local; PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param); #endif /* !USE_LOCALE_NUMERIC */ @@ -13039,50 +13247,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param); PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param); PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param); + PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, param); PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param); + PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param); + PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, param); - /* Did the locale setup indicate UTF-8? */ - PL_utf8locale = proto_perl->Iutf8locale; - /* Unicode features (see perlrun/-C) */ - PL_unicode = proto_perl->Iunicode; - - /* Pre-5.8 signals control */ - PL_signals = proto_perl->Isignals; - - /* times() ticks per second */ - PL_clocktick = proto_perl->Iclocktick; - - /* Recursion stopper for PerlIO_find_layer */ - PL_in_load_module = proto_perl->Iin_load_module; - - /* sort() routine */ - PL_sort_RealCmp = proto_perl->Isort_RealCmp; - - /* Not really needed/useful since the reenrant_retint is "volatile", - * but do it for consistency's sake. */ - PL_reentrant_retint = proto_perl->Ireentrant_retint; - - /* Hooks to shared SVs and locks. */ - PL_sharehook = proto_perl->Isharehook; - PL_lockhook = proto_perl->Ilockhook; - PL_unlockhook = proto_perl->Iunlockhook; - PL_threadhook = proto_perl->Ithreadhook; - PL_destroyhook = proto_perl->Idestroyhook; - PL_signalhook = proto_perl->Isignalhook; - -#ifdef THREADS_HAVE_PIDS - PL_ppid = proto_perl->Ippid; -#endif - - /* swatch cache */ - PL_last_swash_hv = NULL; /* reinits on demand */ - PL_last_swash_klen = 0; - PL_last_swash_key[0]= '\0'; - PL_last_swash_tmps = (U8*)NULL; - PL_last_swash_slen = 0; - - PL_glob_index = proto_perl->Iglob_index; - PL_srand_called = proto_perl->Isrand_called; if (proto_perl->Ipsig_pend) { Newxz(PL_psig_pend, SIG_SIZE, int); @@ -13102,13 +13271,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_psig_name = (SV**)NULL; } - /* intrpvar.h stuff */ - if (flags & CLONEf_COPY_STACKS) { - /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ - PL_tmps_ix = proto_perl->Itmps_ix; - PL_tmps_max = proto_perl->Itmps_max; - PL_tmps_floor = proto_perl->Itmps_floor; Newx(PL_tmps_stack, PL_tmps_max, SV*); sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, PL_tmps_ix+1, param); @@ -13125,8 +13288,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] * NOTE: unlike the others! */ - PL_scopestack_ix = proto_perl->Iscopestack_ix; - PL_scopestack_max = proto_perl->Iscopestack_max; Newxz(PL_scopestack, PL_scopestack_max, I32); Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32); @@ -13147,10 +13308,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, - 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->Isavestack_ix; - PL_savestack_max = proto_perl->Isavestack_max; /*Newxz(PL_savestack, PL_savestack_max, ANY);*/ PL_savestack = ss_dup(proto_perl, param); } @@ -13159,72 +13316,22 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ENTER; /* perl_destruct() wants to LEAVE; */ } - PL_start_env = proto_perl->Istart_env; /* XXXXXX */ - PL_top_env = &PL_start_env; - - PL_op = proto_perl->Iop; - - PL_Sv = NULL; - PL_Xpv = (XPV*)NULL; - my_perl->Ina = proto_perl->Ina; - - 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->Itimesbuf; -#endif - 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_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_restartjmpenv = proto_perl->Irestartjmpenv; - PL_restartop = proto_perl->Irestartop; - PL_in_eval = proto_perl->Iin_eval; - PL_delaymagic = proto_perl->Idelaymagic; - PL_phase = proto_perl->Iphase; - PL_localizing = proto_perl->Ilocalizing; - PL_errors = sv_dup_inc(proto_perl->Ierrors, param); - PL_hv_fetch_ent_mh = NULL; - PL_modcount = proto_perl->Imodcount; - PL_lastgotoprobe = NULL; - PL_dumpindent = proto_perl->Idumpindent; 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 */ - - /* regex stuff */ - - PL_screamfirst = NULL; - PL_screamnext = NULL; - PL_maxscream = -1; /* reinits on demand */ - PL_lastscream = NULL; - - - 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->Ipeepp; - PL_rpeepp = proto_perl->Irpeepp; - /* op_free() hook */ - PL_opfreehook = proto_perl->Iopfreehook; PL_stashcache = newHV(); @@ -13446,6 +13553,14 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) } FREETMPS; LEAVE; + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + /* clear pos and any utf8 cache */ + MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); + if (mg) + mg->mg_len = -1; + if ((mg = mg_find(sv, PERL_MAGIC_utf8))) + magic_setutf8(sv,mg); /* clear UTF8 cache */ + } SvUTF8_on(sv); return SvPVX(sv); } @@ -13737,21 +13852,20 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, break; return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE); - case OP_AELEMFAST: - if (obase->op_flags & OPf_SPECIAL) { /* lexical array */ - if (match) { - SV **svp; - AV *av = MUTABLE_AV(PAD_SV(obase->op_targ)); - if (!av || SvRMAGICAL(av)) - break; - svp = av_fetch(av, (I32)obase->op_private, FALSE); - if (!svp || *svp != uninit_sv) - break; - } - return varname(NULL, '$', obase->op_targ, - NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); + case OP_AELEMFAST_LEX: + if (match) { + SV **svp; + AV *av = MUTABLE_AV(PAD_SV(obase->op_targ)); + if (!av || SvRMAGICAL(av)) + break; + svp = av_fetch(av, (I32)obase->op_private, FALSE); + if (!svp || *svp != uninit_sv) + break; } - else { + return varname(NULL, '$', obase->op_targ, + NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); + case OP_AELEMFAST: + { gv = cGVOPx_gv(obase); if (!gv) break;