X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/31c72c81d58f35758d79ae5790bfaf21252bb22e..3573d64908b2432595567c9e3562b0ee4a6af9fe:/sv.c diff --git a/sv.c b/sv.c index 27b4bd6..f330e5e 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,17 @@ do_clean_named_io_objs(pTHX_ SV *const sv) SvREFCNT_dec(sv); /* undo the inc above */ } +/* Void wrapper to pass to visit() */ +/* XXX +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 +582,11 @@ 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.... */ + /* XXX This line breaks Tk and Gtk2. See [perl #82542]. + visit(do_curse, SVs_OBJECT, SVs_OBJECT); + */ olddef = PL_defoutgv; PL_defoutgv = NULL; /* disable skip of PL_defoutgv */ if (olddef && isGV_with_GP(olddef)) @@ -1047,7 +1072,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 +1580,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 +1690,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; @@ -2290,7 +2317,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); } @@ -2369,7 +2396,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); } @@ -2443,7 +2470,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 +2669,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 +2788,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 +2896,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 +3111,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 +3225,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 +3433,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 +3490,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; @@ -3505,7 +3572,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 +3584,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 +3595,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 +3685,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 @@ -3631,11 +3714,13 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) /* The stash may have been detached from the symbol table, so check its name. */ && GvSTASH(dstr) && HvENAME(GvSTASH(dstr)) + && GvAV((const GV *)sstr) ) 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 @@ -3654,7 +3739,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 @@ -3663,13 +3748,26 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) GvIMPORTED_on(dstr); } GvMULTI_on(dstr); - if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr)); + if(mro_changes == 2) { + MAGIC *mg; + SV * const sref = (SV *)GvAV((const GV *)dstr); + if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) { + if (SvTYPE(mg->mg_obj) != SVt_PVAV) { + AV * const ary = newAV(); + av_push(ary, mg->mg_obj); /* takes the refcount */ + mg->mg_obj = (SV *)ary; + } + av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr)); + } + else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0); + mro_isa_changed_in(GvSTASH(dstr)); + } else if(mro_changes == 3) { HV * const stash = GvHV(dstr); if(old_stash ? (HV *)HvENAME_get(old_stash) : stash) mro_package_moved( stash, old_stash, - (GV *)dstr, NULL, 0 + (GV *)dstr, 0 ); } else if(mro_changes) mro_method_changed_in(GvSTASH(dstr)); @@ -3696,7 +3794,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: @@ -3722,7 +3820,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. */ } } @@ -3782,23 +3880,67 @@ 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( (HV *)sref, (HV *)dref, - (GV *)dstr, NULL, 0 + (GV *)dstr, 0 ); } } else if ( - stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA") + stype == SVt_PVAV && sref != dref + && strEQ(GvNAME((GV*)dstr), "ISA") /* The stash may have been detached from the symbol table, so check its name before doing anything. */ && GvSTASH(dstr) && HvENAME(GvSTASH(dstr)) ) { - sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0); - mro_isa_changed_in(GvSTASH(dstr)); + MAGIC *mg; + MAGIC * const omg = dref && SvSMAGICAL(dref) + ? mg_find(dref, PERL_MAGIC_isa) + : NULL; + if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) { + if (SvTYPE(mg->mg_obj) != SVt_PVAV) { + AV * const ary = newAV(); + av_push(ary, mg->mg_obj); /* takes the refcount */ + mg->mg_obj = (SV *)ary; + } + if (omg) { + if (SvTYPE(omg->mg_obj) == SVt_PVAV) { + SV **svp = AvARRAY((AV *)omg->mg_obj); + I32 items = AvFILLp((AV *)omg->mg_obj) + 1; + while (items--) + av_push( + (AV *)mg->mg_obj, + SvREFCNT_inc_simple_NN(*svp++) + ); + } + else + av_push( + (AV *)mg->mg_obj, + SvREFCNT_inc_simple_NN(omg->mg_obj) + ); + } + else + av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr)); + } + else + { + sv_magic( + sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0 + ); + mg = mg_find(sref, PERL_MAGIC_isa); + } + /* Since the *ISA assignment could have affected more than + one stash, don’t call mro_isa_changed_in directly, but let + magic_clearisa do it for us, as it already has the logic for + dealing with globs vs arrays of globs. */ + assert(mg); + Perl_magic_clearisa(aTHX_ NULL, mg); } break; } @@ -4039,7 +4181,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))) { @@ -4053,7 +4196,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); @@ -4062,7 +4205,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) ) mro_package_moved( stash, old_stash, - (GV *)dstr, NULL, 0 + (GV *)dstr, 0 ); } } @@ -4502,7 +4645,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. */ @@ -4579,7 +4722,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 @@ -4658,7 +4801,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); @@ -5063,7 +5206,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); @@ -5275,31 +5418,23 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, } } -/* -=for apidoc sv_unmagic - -Removes all magic of type C from an SV. - -=cut -*/ - int -Perl_sv_unmagic(pTHX_ SV *const sv, const int type) +S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags) { MAGIC* mg; MAGIC** mgp; - PERL_ARGS_ASSERT_SV_UNMAGIC; + assert(flags <= 1); if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) return 0; mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic); for (mg = *mgp; mg; mg = *mgp) { - if (mg->mg_type == type) { - const MGVTBL* const vtbl = mg->mg_virtual; + const MGVTBL* const virt = mg->mg_virtual; + if (mg->mg_type == type && (!flags || virt == vtbl)) { *mgp = mg->mg_moremagic; - if (vtbl && vtbl->svt_free) - vtbl->svt_free(aTHX_ sv, mg); + if (virt && virt->svt_free) + virt->svt_free(aTHX_ sv, mg); if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { if (mg->mg_len > 0) Safefree(mg->mg_ptr); @@ -5327,6 +5462,36 @@ Perl_sv_unmagic(pTHX_ SV *const sv, const int type) } /* +=for apidoc sv_unmagic + +Removes all magic of type C from an SV. + +=cut +*/ + +int +Perl_sv_unmagic(pTHX_ SV *const sv, const int type) +{ + PERL_ARGS_ASSERT_SV_UNMAGIC; + return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0); +} + +/* +=for apidoc sv_unmagicext + +Removes all magic of type C with the specified C from an SV. + +=cut +*/ + +int +Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl) +{ + PERL_ARGS_ASSERT_SV_UNMAGICEXT; + return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1); +} + +/* =for apidoc sv_rvweaken Weaken a reference: set the C flag on this RV; give the @@ -5559,6 +5724,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)); @@ -5831,7 +6007,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); @@ -5893,71 +6070,20 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) } 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; - } - } - - 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; } if (type >= SVt_PVMG) { + /* 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 (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)); } @@ -5996,8 +6122,7 @@ 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)); - hv_undef(MUTABLE_HV(sv)); + Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL); break; case SVt_PVAV: { @@ -6177,6 +6302,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 @@ -6748,7 +6945,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); @@ -7044,28 +7241,15 @@ Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const U32 flags) } } else { - bool is_utf8 = TRUE; - if (SvUTF8(sv1)) { - /* sv1 is the UTF-8 one, - * if is equal it must be downgrade-able */ - char * const pv = (char*)bytes_from_utf8((const U8*)pv1, - &cur1, &is_utf8); - if (pv != pv1) - pv1 = tpv = pv; + /* sv1 is the UTF-8 one */ + return bytes_cmp_utf8((const U8*)pv2, cur2, + (const U8*)pv1, cur1) == 0; } else { - /* sv2 is the UTF-8 one, - * if is equal it must be downgrade-able */ - char * const pv = (char *)bytes_from_utf8((const U8*)pv2, - &cur2, &is_utf8); - if (pv != pv2) - pv2 = tpv = pv; - } - if (is_utf8) { - /* Downgrade not possible - cannot be eq */ - assert (tpv == 0); - return FALSE; + /* sv2 is the UTF-8 one */ + return bytes_cmp_utf8((const U8*)pv1, cur1, + (const U8*)pv2, cur2) == 0; } } } @@ -7140,7 +7324,9 @@ Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2, pv2 = SvPV_const(svrecode, cur2); } else { - pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2); + const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2, + (const U8*)pv1, cur1); + return retval ? retval < 0 ? -1 : +1 : 0; } } else { @@ -7150,7 +7336,9 @@ Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2, pv1 = SvPV_const(svrecode, cur1); } else { - pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1); + const int retval = bytes_cmp_utf8((const U8*)pv1, cur1, + (const U8*)pv2, cur2); + return retval ? retval < 0 ? -1 : +1 : 0; } } } @@ -7321,6 +7509,55 @@ Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags) #endif /* USE_LOCALE_COLLATE */ +static char * +S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append) +{ + SV * const tsv = newSV(0); + ENTER; + SAVEFREESV(tsv); + sv_gets(tsv, fp, 0); + sv_utf8_upgrade_nomg(tsv); + SvCUR_set(sv,append); + sv_catsv(sv,tsv); + LEAVE; + return (SvCUR(sv) - append) ? SvPVX(sv) : NULL; +} + +static char * +S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append) +{ + I32 bytesread; + const U32 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */ + /* Grab the size of the record we're getting */ + char *const buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append; +#ifdef VMS + int fd; +#endif + + /* Go yank in */ +#ifdef VMS + /* VMS wants read instead of fread, because fread doesn't respect */ + /* RMS record boundaries. This is not necessarily a good thing to be */ + /* doing, but we've got no other real choice - except avoid stdio + as implementation - perhaps write a :vms layer ? + */ + fd = PerlIO_fileno(fp); + if (fd != -1) { + bytesread = PerlLIO_read(fd, buffer, recsize); + } + else /* in-memory file from PerlIO::Scalar */ +#endif + { + bytesread = PerlIO_read(fp, buffer, recsize); + } + + if (bytesread < 0) + bytesread = 0; + SvCUR_set(sv, bytesread + append); + buffer[bytesread] = '\0'; + return (SvCUR(sv) - append) ? SvPVX(sv) : NULL; +} + /* =for apidoc sv_gets @@ -7362,15 +7599,7 @@ Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append) sv_pos_u2b(sv,&append,0); } } else if (SvUTF8(sv)) { - SV * const tsv = newSV(0); - ENTER; - SAVEFREESV(tsv); - sv_gets(tsv, fp, 0); - sv_utf8_upgrade_nomg(tsv); - SvCUR_set(sv,append); - sv_catsv(sv,tsv); - LEAVE; - goto return_string_or_null; + return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append); } } @@ -7403,38 +7632,7 @@ Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append) rslen = 0; } else if (RsRECORD(PL_rs)) { - I32 bytesread; - char *buffer; - U32 recsize; -#ifdef VMS - int fd; -#endif - - /* Grab the size of the record we're getting */ - recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */ - buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append; - /* Go yank in */ -#ifdef VMS - /* VMS wants read instead of fread, because fread doesn't respect */ - /* RMS record boundaries. This is not necessarily a good thing to be */ - /* doing, but we've got no other real choice - except avoid stdio - as implementation - perhaps write a :vms layer ? - */ - fd = PerlIO_fileno(fp); - if (fd == -1) { /* in-memory file from PerlIO::Scalar */ - bytesread = PerlIO_read(fp, buffer, recsize); - } - else { - bytesread = PerlLIO_read(fd, buffer, recsize); - } -#else - bytesread = PerlIO_read(fp, buffer, recsize); -#endif - if (bytesread < 0) - bytesread = 0; - SvCUR_set(sv, bytesread + append); - buffer[bytesread] = '\0'; - goto return_string_or_null; + return S_sv_gets_read_record(aTHX_ sv, fp, append); } else if (RsPARA(PL_rs)) { rsptr = "\n\n"; @@ -7544,6 +7742,8 @@ Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append) bp += cnt; /* screams | dust */ ptr += cnt; /* louder | sed :-) */ cnt = 0; + assert (!shortbuffered); + goto cannot_be_shortbuffered; } } @@ -7557,26 +7757,27 @@ Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append) continue; } + cannot_be_shortbuffered: DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n", PTR2UV(ptr),(long)cnt)); PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */ -#if 0 - DEBUG_P(PerlIO_printf(Perl_debug_log, + + DEBUG_Pv(PerlIO_printf(Perl_debug_log, "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); -#endif + /* This used to call 'filbuf' in stdio form, but as that behaves like getc when cnt <= 0 we use PerlIO_getc here to avoid introducing another abstraction. */ i = PerlIO_getc(fp); /* get more characters */ -#if 0 - DEBUG_P(PerlIO_printf(Perl_debug_log, + + DEBUG_Pv(PerlIO_printf(Perl_debug_log, "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); -#endif + cnt = PerlIO_get_cnt(fp); ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ DEBUG_P(PerlIO_printf(Perl_debug_log, @@ -7637,7 +7838,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) @@ -7689,7 +7890,6 @@ screamer2: } } -return_string_or_null: return (SvCUR(sv) - append) ? SvPVX(sv) : NULL; } @@ -7738,7 +7938,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); @@ -7919,7 +8119,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); @@ -8109,11 +8309,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; @@ -8223,11 +8423,11 @@ Perl_newSVhek(pTHX_ const HEK *const hek) Andreas would like keys he put in as utf8 to come back as utf8 */ STRLEN utf8_len = HEK_LEN(hek); - const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); - SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len); - + SV * const sv = newSV_type(SVt_PV); + char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); + /* bytes_to_utf8() allocates a new string, which we can repurpose: */ + sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL); SvUTF8_on (sv); - Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */ return sv; } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) { /* We don't have a pointer to the hv, so we have to replicate the @@ -8732,7 +8932,8 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) default: if (SvROK(sv)) { SvGETMAGIC(sv); - sv = amagic_deref_call(sv, to_cv_amg); + if (SvAMAGIC(sv)) + sv = amagic_deref_call(sv, to_cv_amg); /* At this point I'd like to do SPAGAIN, but really I need to force it upon my callers. Hmmm. This is a mess... */ @@ -8869,6 +9070,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); @@ -8969,7 +9171,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"; @@ -10062,59 +10264,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) { @@ -10155,6 +10326,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) { @@ -10188,17 +10392,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; } @@ -10324,10 +10541,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; @@ -10339,6 +10562,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': @@ -10415,9 +10639,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 @@ -10430,6 +10660,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': @@ -10540,7 +10771,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; } @@ -10720,10 +10955,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; @@ -11469,7 +11710,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); } @@ -11695,7 +11936,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; @@ -11777,30 +12018,32 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) ++i; } if (SvOOK(sstr)) { - HEK *hvname; const struct xpvhv_aux * const saux = HvAUX(sstr); struct xpvhv_aux * const daux = HvAUX(dstr); /* This flag isn't copied. */ /* SvOOK_on(hv) attacks the IV flags. */ SvFLAGS(dstr) |= SVf_OOK; - hvname = saux->xhv_name; if (saux->xhv_name_count) { - HEK ** const sname = (HEK **)saux->xhv_name; + HEK ** const sname = saux->xhv_name_u.xhvnameu_names; const I32 count = saux->xhv_name_count < 0 ? -saux->xhv_name_count : saux->xhv_name_count; HEK **shekp = sname + count; HEK **dhekp; - Newxc(daux->xhv_name, count, HEK *, HEK); - dhekp = (HEK **)daux->xhv_name + count; + Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *); + dhekp = daux->xhv_name_u.xhvnameu_names + count; while (shekp-- > sname) { dhekp--; *dhekp = hek_dup(*shekp, param); } } - else daux->xhv_name = hek_dup(hvname, param); + else { + daux->xhv_name_u.xhvnameu_name + = hek_dup(saux->xhv_name_u.xhvnameu_name, + param); + } daux->xhv_name_count = saux->xhv_name_count; daux->xhv_riter = saux->xhv_riter; @@ -11832,7 +12075,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) : 0; /* Record stashes for possible cloning in Perl_clone(). */ - if (hvname) + if (HvNAME(sstr)) av_push(param->stashes, dstr); } } @@ -11850,11 +12093,12 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) hv_dup(CvSTASH(dstr), param); if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr)) Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr); - OP_REFCNT_LOCK; - if (!CvISXSUB(dstr)) + if (!CvISXSUB(dstr)) { + OP_REFCNT_LOCK; CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr)); - OP_REFCNT_UNLOCK; - if (CvCONST(dstr) && CvISXSUB(dstr)) { + OP_REFCNT_UNLOCK; + CvFILE(dstr) = SAVEPV(CvFILE(dstr)); + } else if (CvCONST(dstr)) { CvXSUBANY(dstr).any_ptr = sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param); } @@ -11872,8 +12116,6 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) CvWEAKOUTSIDE(sstr) ? cv_dup( CvOUTSIDE(dstr), param) : cv_dup_inc(CvOUTSIDE(dstr), param); - if (!CvISXSUB(dstr)) - CvFILE(dstr) = SAVEPV(CvFILE(dstr)); break; } } @@ -11971,7 +12213,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 == @@ -12218,13 +12460,11 @@ 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); - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; + gv = (const GV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup_inc(gv, param); break; case SAVEt_FREEOP: ptr = POPPTR(ss,ix); @@ -12859,6 +13099,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param); PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param); PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param); + PL_custom_ops = hv_dup_inc(proto_perl->Icustom_ops, param); PL_profiledata = NULL; @@ -12958,7 +13199,10 @@ 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 = hv_dup_inc(proto_perl->Iutf8_foldable, param); /* Did the locale setup indicate UTF-8? */ PL_utf8locale = proto_perl->Iutf8locale; @@ -13109,7 +13353,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_restartop = proto_perl->Irestartop; PL_in_eval = proto_perl->Iin_eval; PL_delaymagic = proto_perl->Idelaymagic; - PL_dirty = proto_perl->Idirty; + PL_phase = proto_perl->Iphase; PL_localizing = proto_perl->Ilocalizing; PL_errors = sv_dup_inc(proto_perl->Ierrors, param); @@ -13365,6 +13609,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); } @@ -13652,7 +13904,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, case OP_GVSV: gv = cGVOPx_gv(obase); - if (!gv || (match && GvSV(gv) != uninit_sv)) + if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv)) break; return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE); @@ -13951,6 +14203,12 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid))) || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) || (type == OP_PUSHMARK) + || ( + /* @$a and %$a, but not @a or %a */ + (type == OP_RV2AV || type == OP_RV2HV) + && cUNOPx(kid)->op_first + && cUNOPx(kid)->op_first->op_type != OP_GV + ) ) continue; }