X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/73b42cee7a0466e4aa372ad35c8c09e0ad5e4a6f..85ca3be751f142ad43c1dabcac68ab17a69c4c4d:/sv.c diff --git a/sv.c b/sv.c index 14ef56b..cf29ffa 100644 --- a/sv.c +++ b/sv.c @@ -3645,8 +3645,8 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) } SvUPGRADE(dstr, SVt_PVGV); (void)SvOK_off(dstr); - /* FIXME - why are we doing this, then turning it off and on again - below? */ + /* We have to turn this on here, even though we turn it off + below, as GvSTASH will fail an assertion otherwise. */ isGV_with_GP_on(dstr); } GvSTASH(dstr) = GvSTASH(sstr); @@ -3711,7 +3711,7 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) } gp_free(MUTABLE_GV(dstr)); - isGV_with_GP_off(dstr); + isGV_with_GP_off(dstr); /* SvOK_off does not like globs. */ (void)SvOK_off(dstr); isGV_with_GP_on(dstr); GvINTRO_off(dstr); /* one-shot flag */ @@ -4583,8 +4583,10 @@ Perl_sv_sethek(pTHX_ register SV *const sv, const HEK *const hek) return; } { + SV_CHECK_THINKFIRST_COW_DROP(sv); SvUPGRADE(sv, SVt_PV); - sv_usepvn_flags(sv, (char *)HEK_KEY(share_hek_hek(hek)), HEK_LEN(hek), SV_HAS_TRAILING_NUL); + SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek))); + SvCUR_set(sv, HEK_LEN(hek)); SvLEN_set(sv, 0); SvREADONLY_on(sv); SvFAKE_on(sv); @@ -4604,7 +4606,9 @@ Perl_sv_sethek(pTHX_ register SV *const sv, const HEK *const hek) Tells an SV to use C to find its string value. Normally the string is stored inside the SV but sv_usepvn allows the SV to use an outside string. The C should point to memory that was allocated -by C. The string length, C, must be supplied. By default +by C. It must be the start of a mallocked block +of memory, and not a pointer to the middle of it. The +string length, C, must be supplied. By default this function will realloc (i.e. move) the memory pointed to by C, so that pointer should not be freed or used by the programmer after giving it to sv_usepvn, and neither should any pointers from "behind" @@ -4794,9 +4798,14 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) SvREADONLY_off(sv); SvPV_set(sv, NULL); SvLEN_set(sv, 0); - SvGROW(sv, len + 1); - Move(pvx,SvPVX(sv),len,char); - *SvEND(sv) = '\0'; + if (flags & SV_COW_DROP_PV) { + /* OK, so we don't need to copy our buffer. */ + SvPOK_off(sv); + } else { + SvGROW(sv, len + 1); + Move(pvx,SvPVX(sv),len,char); + *SvEND(sv) = '\0'; + } unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); } else if (IN_PERL_RUNTIME) @@ -4806,7 +4815,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) if (SvROK(sv)) sv_unref_flags(sv, flags); else if (SvFAKE(sv) && isGV_with_GP(sv)) - sv_unglob(sv); + sv_unglob(sv, flags); else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) { /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous to sv_unglob. We only need it here, so inline it. */ @@ -4902,7 +4911,7 @@ Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr) Move(pvx,SvPVX(sv),len,char); *SvEND(sv) = '\0'; } - SvFLAGS(sv) |= SVf_OOK; + SvOOK_on(sv); old_delta = 0; } else { SvOOK_offset(sv, old_delta); @@ -5294,9 +5303,8 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, #endif if (SvREADONLY(sv)) { if ( - /* its okay to attach magic to shared strings; the subsequent - * upgrade to PVMG will unshare the string */ - !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG) + /* its okay to attach magic to shared strings */ + (!SvFAKE(sv) || isGV_with_GP(sv)) && IN_PERL_RUNTIME && !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how) @@ -5711,7 +5719,8 @@ the Perl substr() function. Handles get magic. =for apidoc sv_insert_flags -Same as C, but the extra C are passed the C that applies to C. +Same as C, but the extra C are passed to the +C that applies to C. =cut */ @@ -8435,7 +8444,7 @@ Creates a new SV with its SvPVX_const pointing to a shared string in the string table. If the string does not already exist in the table, it is created first. Turns on READONLY and FAKE. If the C parameter is non-zero, that value is used; otherwise the hash is computed. -The string's hash can be later be retrieved from the SV +The string's hash can later be retrieved from the SV with the C macro. The idea here is that as the string table is used for shared hash keys these strings will have SvPVX_const == HeKEY and hash lookup will avoid string compare. @@ -8901,8 +8910,6 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) if (SvROK(sv)) { 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... */ sv = SvRV(sv); if (SvTYPE(sv) == SVt_PVCV) { @@ -9015,6 +9022,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS; + if (flags & SV_GMAGIC) SvGETMAGIC(sv); if (SvTHINKFIRST(sv) && !SvROK(sv)) sv_force_normal_flags(sv, 0); @@ -9039,7 +9047,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) /* 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); + s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC); if (lp) *lp = len; @@ -9463,8 +9471,8 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) * as it is after unglobbing it. */ -STATIC void -S_sv_unglob(pTHX_ SV *const sv) +PERL_STATIC_INLINE void +S_sv_unglob(pTHX_ SV *const sv, U32 flags) { dVAR; void *xpvmg; @@ -9475,7 +9483,8 @@ S_sv_unglob(pTHX_ SV *const sv) assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV); SvFAKE_off(sv); - gv_efullname3(temp, MUTABLE_GV(sv), "*"); + if (!(flags & SV_COW_DROP_PV)) + gv_efullname3(temp, MUTABLE_GV(sv), "*"); if (GvGP(sv)) { if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) @@ -9506,7 +9515,8 @@ S_sv_unglob(pTHX_ SV *const sv) /* Intentionally not calling any local SET magic, as this isn't so much a set operation as merely an internal storage change. */ - sv_setsv_flags(sv, temp, 0); + if (flags & SV_COW_DROP_PV) SvOK_off(sv); + else sv_setsv_flags(sv, temp, 0); } /* @@ -10344,7 +10354,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, * back into v-string notation and then let the * vectorize happen normally */ - if (sv_derived_from(vecsv, "version")) { + if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) { char *version = savesvpv(vecsv); if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) { Perl_warner(aTHX_ packWARN(WARN_INTERNAL), @@ -12027,8 +12037,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) 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; + SvOOK_on(dstr); if (saux->xhv_name_count) { HEK ** const sname = saux->xhv_name_u.xhvnameu_names; @@ -14258,8 +14267,13 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, if (!o) break; - /* if all except one arg are constant, or have no side-effects, - * or are optimized away, then it's unambiguous */ + /* This loop checks all the kid ops, skipping any that cannot pos- + * sibly be responsible for the uninitialized value; i.e., defined + * constants and ops that return nothing. If there is only one op + * left that is not skipped, then we *know* it is responsible for + * the uninitialized value. If there is more than one op left, we + * have to look for an exact match in the while() loop below. + */ o2 = NULL; for (kid=o; kid; kid = kid->op_sibling) { if (kid) {