X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d17ea59705db215628334e7846dd1056ff795f97..7a21560e6db00d9523852707b381ad4dd45a8b81:/sv.c diff --git a/sv.c b/sv.c index 8d986b7..cfae3b7 100644 --- a/sv.c +++ b/sv.c @@ -1,12 +1,21 @@ /* sv.c * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * "I wonder what the Entish is for 'yes' and 'no'," he thought. + */ + +/* + * 'I wonder what the Entish is for "yes" and "no",' he thought. + * --Pippin + * + * [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"] + */ + +/* * * * This file contains the code that creates, manipulates and destroys @@ -173,14 +182,29 @@ Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size) } } +#ifdef PERL_MEM_LOG +# define MEM_LOG_NEW_SV(sv, file, line, func) \ + Perl_mem_log_new_sv(sv, file, line, func) +# define MEM_LOG_DEL_SV(sv, file, line, func) \ + Perl_mem_log_del_sv(sv, file, line, func) +#else +# define MEM_LOG_NEW_SV(sv, file, line, func) NOOP +# define MEM_LOG_DEL_SV(sv, file, line, func) NOOP +#endif + #ifdef DEBUG_LEAKING_SCALARS # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file) +# define DEBUG_SV_SERIAL(sv) \ + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \ + PTR2UV(sv), (long)(sv)->sv_debug_serial)) #else # define FREE_SV_DEBUG_FILE(sv) +# define DEBUG_SV_SERIAL(sv) NOOP #endif #ifdef PERL_POISON # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv) +# define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val)) /* Whilst I'd love to do this, it seems that things like to check on unreferenced scalars # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV) @@ -189,23 +213,36 @@ Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size) PoisonNew(&SvREFCNT(sv), 1, U32) #else # define SvARENA_CHAIN(sv) SvANY(sv) +# define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val) # define POSION_SV_HEAD(sv) #endif +/* Mark an SV head as unused, and add to free list. + * + * If SVf_BREAK is set, skip adding it to the free list, as this SV had + * its refcount artificially decremented during global destruction, so + * there may be dangling pointers to it. The last thing we want in that + * case is for it to be reused. */ + #define plant_SV(p) \ STMT_START { \ + const U32 old_flags = SvFLAGS(p); \ + MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \ + DEBUG_SV_SERIAL(p); \ FREE_SV_DEBUG_FILE(p); \ POSION_SV_HEAD(p); \ - SvARENA_CHAIN(p) = (void *)PL_sv_root; \ SvFLAGS(p) = SVTYPEMASK; \ - PL_sv_root = (p); \ + if (!(old_flags & SVf_BREAK)) { \ + SvARENA_CHAIN_SET(p, PL_sv_root); \ + PL_sv_root = (p); \ + } \ --PL_sv_count; \ } STMT_END #define uproot_SV(p) \ STMT_START { \ (p) = PL_sv_root; \ - PL_sv_root = (SV*)SvARENA_CHAIN(p); \ + PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \ ++PL_sv_count; \ } STMT_END @@ -237,7 +274,7 @@ S_more_sv(pTHX) #ifdef DEBUG_LEAKING_SCALARS /* provide a real function for a debugger to play with */ STATIC SV* -S_new_SV(pTHX) +S_new_SV(pTHX_ const char *file, int line, const char *func) { SV* sv; @@ -249,20 +286,25 @@ S_new_SV(pTHX) SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; - sv->sv_debug_line = (U16) (PL_parser - ? PL_parser->copline == NOLINE - ? PL_curcop + sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE + ? PL_parser->copline + : PL_curcop ? CopLINE(PL_curcop) : 0 - : PL_parser->copline - : 0); + ); sv->sv_debug_inpad = 0; sv->sv_debug_cloned = 0; sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL; - + + sv->sv_debug_serial = PL_sv_serial++; + + MEM_LOG_NEW_SV(sv, file, line, func); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n", + PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func)); + return sv; } -# define new_SV(p) (p)=S_new_SV(aTHX) +# define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__) #else # define new_SV(p) \ @@ -274,6 +316,7 @@ S_new_SV(pTHX) SvANY(p) = 0; \ SvREFCNT(p) = 1; \ SvFLAGS(p) = 0; \ + MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \ } STMT_END #endif @@ -300,7 +343,7 @@ S_del_sv(pTHX_ SV *p) if (DEBUG_D_TEST) { SV* sva; bool ok = 0; - for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { + for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { const SV * const sv = sva + 1; const SV * const svend = &sva[SvREFCNT(sva)]; if (p >= sv && p < svend) { @@ -337,11 +380,11 @@ and split it into a list of free SVs. =cut */ -void -Perl_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) +static void +S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) { dVAR; - SV* const sva = (SV*)ptr; + SV *const sva = MUTABLE_SV(ptr); register SV* sv; register SV* svend; @@ -358,7 +401,7 @@ Perl_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) svend = &sva[SvREFCNT(sva) - 1]; sv = sva + 1; while (sv < svend) { - SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1); + SvARENA_CHAIN_SET(sv, (sv + 1)); #ifdef DEBUGGING SvREFCNT(sv) = 0; #endif @@ -367,7 +410,7 @@ Perl_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) SvFLAGS(sv) = SVTYPEMASK; sv++; } - SvARENA_CHAIN(sv) = 0; + SvARENA_CHAIN_SET(sv, 0); #ifdef DEBUGGING SvREFCNT(sv) = 0; #endif @@ -386,7 +429,7 @@ S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask) PERL_ARGS_ASSERT_VISIT; - for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { + for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { register const SV * const svend = &sva[SvREFCNT(sva)]; register SV* sv; for (sv = sva + 1; sv < svend; ++sv) { @@ -516,8 +559,10 @@ static void do_clean_all(pTHX_ SV *const sv) { dVAR; - if (sv == PL_fdpid || sv == PL_strtab) /* don't clean pid table and strtab */ + if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) { + /* don't clean pid table and strtab */ return; + } DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); SvFLAGS(sv) |= SVf_BREAK; SvREFCNT_dec(sv); @@ -601,9 +646,9 @@ Perl_sv_free_arenas(pTHX) contiguity of the fake ones with the corresponding real ones.) */ for (sva = PL_sv_arenaroot; sva; sva = svanext) { - svanext = (SV*) SvANY(sva); + svanext = MUTABLE_SV(SvANY(sva)); while (svanext && SvFAKE(svanext)) - svanext = (SV*) SvANY(svanext); + svanext = MUTABLE_SV(SvANY(svanext)); if (!SvFAKE(sva)) Safefree(sva); @@ -881,7 +926,7 @@ struct xpv { #define copy_length(type, last_member) \ STRUCT_OFFSET(type, last_member) \ - + sizeof (((type*)SvANY((SV*)0))->last_member) + + sizeof (((type*)SvANY((const SV *)0))->last_member) static const struct body_details bodies_by_type[] = { { sizeof(HE), 0, 0, SVt_NULL, @@ -1490,7 +1535,7 @@ Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen) s = SvPVX_mutable(sv); if (newlen > SvLEN(sv)) { /* need more room? */ -#ifndef MYMALLOC +#ifndef Perl_safesysmalloc_size newlen = PERL_STRLEN_ROUNDUP(newlen); #endif if (SvLEN(sv) && s) { @@ -1542,6 +1587,8 @@ Perl_sv_setiv(pTHX_ register SV *const sv, const IV i) break; case SVt_PVGV: + if (!isGV_with_GP(sv)) + break; case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: @@ -1649,6 +1696,8 @@ Perl_sv_setnv(pTHX_ register SV *const sv, const NV num) break; case SVt_PVGV: + if (!isGV_with_GP(sv)) + break; case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: @@ -2224,7 +2273,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv) } else { if (isGV_with_GP(sv)) - return glob_2number((GV *)sv); + return glob_2number(MUTABLE_GV(sv)); if (!(SvFLAGS(sv) & SVs_PADTMP)) { if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) @@ -2595,7 +2644,7 @@ Perl_sv_2nv(pTHX_ register SV *const sv) } else { if (isGV_with_GP(sv)) { - glob_2number((GV *)sv); + glob_2number(MUTABLE_GV(sv)); return 0.0; } @@ -2791,13 +2840,13 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags STRLEN len; char *retval; char *buffer; - const SV *const referent = (SV*)SvRV(sv); + SV *const referent = SvRV(sv); if (!referent) { len = 7; retval = buffer = savepvn("NULLREF", len); } else if (SvTYPE(referent) == SVt_REGEXP) { - const REGEXP * const re = (REGEXP *)referent; + REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent); I32 seen_evals = 0; assert(re); @@ -2909,7 +2958,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags *s = '\0'; } else if (SvNOKp(sv)) { - const int olderrno = errno; + dSAVE_ERRNO; if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); /* The +20 is pure guesswork. Configure test needed. --jhi */ @@ -2923,7 +2972,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags { Gconvert(SvNVX(sv), NV_DIG, 0, s); } - errno = olderrno; + RESTORE_ERRNO; #ifdef FIXNEGATIVEZERO if (*s == '-' && s[1] == '0' && !s[2]) { s[0] = '0'; @@ -2938,7 +2987,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags } else { if (isGV_with_GP(sv)) - return glob_2pv((GV *)sv, lp); + return glob_2pv(MUTABLE_GV(sv), lp); if (lp) *lp = 0; @@ -3097,8 +3146,10 @@ Perl_sv_2bool(pTHX_ register SV *const sv) Converts the PV of an SV to its UTF-8-encoded form. Forces the SV to string form if it is not already. +Will C on C if appropriate. Always sets the SvUTF8 flag to avoid future validity checks even -if all the bytes have hibit clear. +if the whole string is the same in UTF-8 as not. +Returns the number of bytes in the converted string This is not as a general purpose byte encoding to Unicode interface: use the Encode extension for that. @@ -3108,8 +3159,10 @@ use the Encode extension for that. Converts the PV of an SV to its UTF-8-encoded form. Forces the SV to string form if it is not already. Always sets the SvUTF8 flag to avoid future validity checks even -if all the bytes have hibit clear. If C has C bit set, -will C on C if appropriate, else not. C and +if all the bytes are invariant in UTF-8. If C has C bit set, +will C on C if appropriate, else not. +Returns the number of bytes in the converted string +C and C are implemented in terms of this function. This is not as a general purpose byte encoding to Unicode interface: @@ -3150,7 +3203,7 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *const sv, const I32 flags) sv_recode_to_utf8(sv, PL_encoding); else { /* Assume Latin-1/EBCDIC */ /* This function could be much more efficient if we - * had a FLAG in SVs to signal if there are any hibit + * had a FLAG in SVs to signal if there are any variant * chars in the PV. Given that there isn't such a flag * make the loop as fast as possible. */ const U8 * const s = (U8 *) SvPVX_const(sv); @@ -3159,19 +3212,27 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *const sv, const I32 flags) while (t < e) { const U8 ch = *t++; - /* Check for hi bit */ + /* Check for variant */ if (!NATIVE_IS_INVARIANT(ch)) { - STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */ + STRLEN len = SvCUR(sv); + /* *Currently* bytes_to_utf8() adds a '\0' after every string + it converts. This isn't documented. It's not clear if it's + a bad thing to be doing, and should be changed to do exactly + what the documentation says. If so, this code will have to + be changed. + As is, we mustn't rely on our incoming SV being well formed + and having a trailing '\0', as certain code in pp_formline + can send us partially built SVs. */ U8 * const recoded = bytes_to_utf8((U8*)s, &len); SvPV_free(sv); /* No longer using what was there before. */ SvPV_set(sv, (char*)recoded); - SvCUR_set(sv, len - 1); - SvLEN_set(sv, len); /* No longer know the real size. */ + SvCUR_set(sv, len); + SvLEN_set(sv, len + 1); /* No longer know the real size. */ break; } } - /* Mark as UTF-8 even if no hibit - saves scanning loop */ + /* Mark as UTF-8 even if no variant - saves scanning loop */ SvUTF8_on(sv); } return SvCUR(sv); @@ -3181,7 +3242,8 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *const sv, const I32 flags) =for apidoc sv_utf8_downgrade Attempts to convert the PV of an SV from characters to bytes. -If the PV contains a character beyond byte, this conversion will fail; +If the PV contains a character that cannot fit +in a byte, this conversion will fail; in this case, either returns false or, if C is not true, croaks. @@ -3243,7 +3305,7 @@ Perl_sv_utf8_encode(pTHX_ register SV *const sv) sv_force_normal_flags(sv, 0); } if (SvREADONLY(sv)) { - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); } (void) sv_utf8_upgrade(sv); SvUTF8_off(sv); @@ -3354,18 +3416,18 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) } GvSTASH(dstr) = GvSTASH(sstr); if (GvSTASH(dstr)) - Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr); - gv_name_set((GV *)dstr, name, len, GV_ADD); + Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr); + gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD); SvFAKE_on(dstr); /* can coerce to non-glob */ } #ifdef GV_UNIQUE_CHECK - if (GvUNIQUE((GV*)dstr)) { - Perl_croak(aTHX_ PL_no_modify); + if (GvUNIQUE((const GV *)dstr)) { + Perl_croak(aTHX_ "%s", PL_no_modify); } #endif - if(GvGP((GV*)sstr)) { + if(GvGP(MUTABLE_GV(sstr))) { /* If source has method cache entry, clear it */ if(GvCVGEN(sstr)) { SvREFCNT_dec(GvCV(sstr)); @@ -3374,20 +3436,20 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) } /* If source has a real method, then a method is going to change */ - else if(GvCV((GV*)sstr)) { + else if(GvCV((const GV *)sstr)) { mro_changes = 1; } } /* If dest already had a real method, that's a change as well */ - if(!mro_changes && GvGP((GV*)dstr) && GvCVu((GV*)dstr)) { + if(!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)) { mro_changes = 1; } - if(strEQ(GvNAME((GV*)dstr),"ISA")) + if(strEQ(GvNAME((const GV *)dstr),"ISA")) mro_changes = 2; - gp_free((GV*)dstr); + gp_free(MUTABLE_GV(dstr)); isGV_with_GP_off(dstr); (void)SvOK_off(dstr); isGV_with_GP_on(dstr); @@ -3419,15 +3481,15 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) PERL_ARGS_ASSERT_GLOB_ASSIGN_REF; #ifdef GV_UNIQUE_CHECK - if (GvUNIQUE((GV*)dstr)) { - Perl_croak(aTHX_ PL_no_modify); + if (GvUNIQUE((const GV *)dstr)) { + Perl_croak(aTHX_ "%s", PL_no_modify); } #endif if (intro) { GvINTRO_off(dstr); /* one-shot flag */ GvLINE(dstr) = CopLINE(PL_curcop); - GvEGV(dstr) = (GV*)dstr; + GvEGV(dstr) = MUTABLE_GV(dstr); } GvMULTI_on(dstr); switch (stype) { @@ -3454,7 +3516,7 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) common: if (intro) { if (stype == SVt_PVCV) { - /*if (GvCVGEN(dstr) && (GvCV(dstr) != (CV*)sref || GvCVGEN(dstr))) {*/ + /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/ if (GvCVGEN(dstr)) { SvREFCNT_dec(GvCV(dstr)); GvCV(dstr) = NULL; @@ -3466,15 +3528,16 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) else dref = *location; if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) { - CV* const cv = (CV*)*location; + CV* const cv = MUTABLE_CV(*location); if (cv) { - if (!GvCVGEN((GV*)dstr) && + if (!GvCVGEN((const GV *)dstr) && (CvROOT(cv) || CvXSUB(cv))) { /* Redefining a sub - warning is mandatory if it was a const and its value changed. */ - if (CvCONST(cv) && CvCONST((CV*)sref) - && cv_const_sv(cv) == cv_const_sv((CV*)sref)) { + if (CvCONST(cv) && CvCONST((const CV *)sref) + && cv_const_sv(cv) + == cv_const_sv((const CV *)sref)) { NOOP; /* They are 2 constant subroutines generated from the same constant. This probably means that @@ -3485,20 +3548,21 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) } else if (ckWARN(WARN_REDEFINE) || (CvCONST(cv) - && (!CvCONST((CV*)sref) + && (!CvCONST((const CV *)sref) || sv_cmp(cv_const_sv(cv), - cv_const_sv((CV*)sref))))) { + cv_const_sv((const CV *) + sref))))) { Perl_warner(aTHX_ packWARN(WARN_REDEFINE), (const char *) (CvCONST(cv) ? "Constant subroutine %s::%s redefined" : "Subroutine %s::%s redefined"), - HvNAME_get(GvSTASH((GV*)dstr)), - GvENAME((GV*)dstr)); + HvNAME_get(GvSTASH((const GV *)dstr)), + GvENAME(MUTABLE_GV(dstr))); } } if (!intro) - cv_ckproto_len(cv, (GV*)dstr, + cv_ckproto_len(cv, (const GV *)dstr, SvPOK(sref) ? SvPVX_const(sref) : NULL, SvPOK(sref) ? SvCUR(sref) : 0); } @@ -3551,7 +3615,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) { /* need to nuke the magic */ mg_free(dstr); - SvRMAGICAL_off(dstr); } /* There's a lot of redundancy below but we're going for speed here */ @@ -3705,7 +3768,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) Perl_croak(aTHX_ "Cannot copy to %s", type); } else if (sflags & SVf_ROK) { if (isGV_with_GP(dstr) && dtype == SVt_PVGV - && SvTYPE(SvRV(sstr)) == SVt_PVGV) { + && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) { sstr = SvRV(sstr); if (sstr == dstr) { if (GvIMPORTED(dstr) != GVf_IMPORTED @@ -3747,9 +3810,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } else { GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV); - if (dstr != (SV*)gv) { + if (dstr != (const SV *)gv) { if (GvGP(dstr)) - gp_free((GV*)dstr); + gp_free(MUTABLE_GV(dstr)); GvGP(dstr) = gp_ref(GvGP(gv)); } } @@ -3938,7 +4001,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) /* FAKE globs can get coerced, so need to turn this off temporarily if it is on. */ SvFAKE_off(sstr); - gv_efullname3(dstr, (GV *)sstr, "*"); + gv_efullname3(dstr, MUTABLE_GV(sstr), "*"); SvFLAGS(sstr) |= wasfake; } else @@ -4326,7 +4389,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) } } else if (IN_PERL_RUNTIME) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); /* At this point I believe that I can drop the global SV mutex. */ } #else @@ -4344,7 +4407,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); } else if (IN_PERL_RUNTIME) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); } #endif if (SvROK(sv)) @@ -4375,6 +4438,7 @@ Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr) #ifdef DEBUGGING const U8 *real_start; #endif + STRLEN max_delta; PERL_ARGS_ASSERT_SV_CHOP; @@ -4385,8 +4449,17 @@ Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr) /* Nothing to do. */ return; } - assert(ptr > SvPVX_const(sv)); + /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line, + nothing uses the value of ptr any more. */ + max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv); + if (ptr <= SvPVX_const(sv)) + Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p", + ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta); SV_CHECK_THINKFIRST(sv); + if (delta > max_delta) + Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p", + SvPVX_const(sv) + delta, ptr, SvPVX_const(sv), + SvPVX_const(sv) + max_delta); if (!SvOOK(sv)) { if (!SvLEN(sv)) { /* make copy of shared string */ @@ -4657,9 +4730,9 @@ Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, how == PERL_MAGIC_arylen || how == PERL_MAGIC_symtab || (SvTYPE(obj) == SVt_PVGV && - (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv || - GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv || - GvFORM(obj) == (CV*)sv))) + (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv + || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv + || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv))) { mg->mg_obj = obj; } @@ -4677,7 +4750,7 @@ Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, */ if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO && - obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv) + obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv) { sv_rvweaken(obj); } @@ -4687,9 +4760,13 @@ Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, if (name) { if (namlen > 0) mg->mg_ptr = savepvn(name, namlen); - else if (namlen == HEf_SVKEY) - mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV*)name); - else + 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 + 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); + } else mg->mg_ptr = (char *) name; } mg->mg_virtual = (MGVTBL *) vtable; @@ -4743,7 +4820,7 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, && how != PERL_MAGIC_backref ) { - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); } } if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) { @@ -4924,7 +5001,7 @@ Perl_sv_unmagic(pTHX_ SV *const sv, const int type) if (mg->mg_len > 0) Safefree(mg->mg_ptr); else if (mg->mg_len == HEf_SVKEY) - SvREFCNT_dec((SV*)mg->mg_ptr); + SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); else if (mg->mg_type == PERL_MAGIC_utf8) Safefree(mg->mg_ptr); } @@ -4983,6 +5060,24 @@ Perl_sv_rvweaken(pTHX_ SV *const sv) * back-reference to sv onto the array associated with the backref magic. */ +/* 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 + * of 2. This means that if during global destruction the array gets + * picked on first to have its refcount decremented by the random zapper, + * it won't actually be freed, meaning it's still theere for when its + * parent gets freed. + * When the parent SV is freed, in the case of magic, the magic is freed, + * Perl_magic_killbackrefs is called which decrements one refcount, then + * mg_obj is freed which kills the second count. + * In the vase of a HV being freed, one ref is removed by + * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it + * calls. + */ + void Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) { @@ -4992,7 +5087,7 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) PERL_ARGS_ASSERT_SV_ADD_BACKREF; if (SvTYPE(tsv) == SVt_PVHV) { - AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv); + AV **const avp = Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); av = *avp; if (!av) { @@ -5001,7 +5096,7 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) if (mg) { /* Aha. They've got it stowed in magic. Bring it back. */ - av = (AV*)mg->mg_obj; + av = MUTABLE_AV(mg->mg_obj); /* Stop mg_free decreasing the refernce count. */ mg->mg_obj = NULL; /* Stop mg_free even calling the destructor, given that @@ -5011,7 +5106,7 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) } else { av = newAV(); AvREAL_off(av); - SvREFCNT_inc_simple_void(av); + SvREFCNT_inc_simple_void(av); /* see discussion above */ } *avp = av; } @@ -5019,14 +5114,12 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) const MAGIC *const mg = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; if (mg) - av = (AV*)mg->mg_obj; + av = MUTABLE_AV(mg->mg_obj); else { av = newAV(); AvREAL_off(av); - sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0); - /* av now has a refcnt of 2, which avoids it getting freed - * before us during global cleanup. The extra ref is removed - * by magic_killbackrefs() when tsv is being freed */ + sv_magic(tsv, MUTABLE_SV(av), PERL_MAGIC_backref, NULL, 0); + /* av now has a refcnt of 2; see discussion above */ } } if (AvFILLp(av) >= AvMAX(av)) { @@ -5050,7 +5143,7 @@ S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv) PERL_ARGS_ASSERT_SV_DEL_BACKREF; if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) { - av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv); + av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); /* We mustn't attempt to "fix up" the hash here by moving the backreference array back to the hv_aux structure, as that is stored in the main HvARRAY(), and hfreentries assumes that no-one @@ -5060,16 +5153,13 @@ S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv) const MAGIC *const mg = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; if (mg) - av = (AV *)mg->mg_obj; + av = MUTABLE_AV(mg->mg_obj); } - if (!av) { - if (PL_in_clean_all) - return; + + if (!av) Perl_croak(aTHX_ "panic: del_backref"); - } - if (SvIS_FREED(av)) - return; + assert(!SvIS_FREED(av)); svp = AvARRAY(av); /* We shouldn't be in here more than once, but for paranoia reasons lets @@ -5099,9 +5189,8 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av) PERL_ARGS_ASSERT_SV_KILL_BACKREFS; PERL_UNUSED_ARG(sv); - /* Not sure why the av can get freed ahead of its sv, but somehow it does - in ext/B/t/bytecode.t test 15 (involving print ) */ - if (svp && !SvIS_FREED(av)) { + assert(!svp || !SvIS_FREED(av)); + if (svp) { SV *const *const last = svp + AvFILLp(av); while (svp <= last) { @@ -5117,7 +5206,7 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av) SvTYPE(referrer) == SVt_PVLV) { /* You lookin' at me? */ assert(GvSTASH(referrer)); - assert(GvSTASH(referrer) == (HV*)sv); + assert(GvSTASH(referrer) == (const HV *)sv); GvSTASH(referrer) = 0; } else { Perl_croak(aTHX_ @@ -5138,14 +5227,17 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av) =for apidoc sv_insert Inserts a string at the specified offset/length within the SV. Similar to -the Perl substr() function. +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. =cut */ void -Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, - const char *const little, const STRLEN littlelen) +Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags) { dVAR; register char *big; @@ -5155,11 +5247,11 @@ Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, register I32 i; STRLEN curlen; - PERL_ARGS_ASSERT_SV_INSERT; + PERL_ARGS_ASSERT_SV_INSERT_FLAGS; if (!bigstr) Perl_croak(aTHX_ "Can't modify non-existent substring"); - SvPV_force(bigstr, curlen); + SvPV_force_flags(bigstr, curlen, flags); (void)SvPOK_only_UTF8(bigstr); if (offset + len > curlen) { SvGROW(bigstr, offset+len+1); @@ -5371,7 +5463,7 @@ Perl_sv_clear(pTHX_ register SV *const sv) PUSHMARK(SP); PUSHs(tmpref); PUTBACK; - call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); + call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); POPSTACK; @@ -5420,7 +5512,7 @@ Perl_sv_clear(pTHX_ register SV *const sv) IoIFP(sv) != PerlIO_stdout() && IoIFP(sv) != PerlIO_stderr()) { - io_close((IO*)sv, FALSE); + io_close(MUTABLE_IO(sv), FALSE); } if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP)) PerlDir_close(IoDIRP(sv)); @@ -5435,18 +5527,21 @@ Perl_sv_clear(pTHX_ register SV *const sv) goto freescalar; case SVt_PVCV: case SVt_PVFM: - cv_undef((CV*)sv); + cv_undef(MUTABLE_CV(sv)); goto freescalar; case SVt_PVHV: - Perl_hv_kill_backrefs(aTHX_ (HV*)sv); - hv_undef((HV*)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)); break; case SVt_PVAV: - if (PL_comppad == (AV*)sv) { + if (PL_comppad == MUTABLE_AV(sv)) { PL_comppad = NULL; PL_curpad = NULL; } - av_undef((AV*)sv); + av_undef(MUTABLE_AV(sv)); break; case SVt_PVLV: if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ @@ -5458,20 +5553,21 @@ Perl_sv_clear(pTHX_ register SV *const sv) SvREFCNT_dec(LvTARG(sv)); case SVt_PVGV: if (isGV_with_GP(sv)) { - if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash)) + if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) + && HvNAME_get(stash)) mro_method_changed_in(stash); - gp_free((GV*)sv); + gp_free(MUTABLE_GV(sv)); if (GvNAME_HEK(sv)) unshare_hek(GvNAME_HEK(sv)); /* If we're in a stash, we don't own a reference to it. However it does have a back reference to us, which needs to be cleared. */ if (!SvVALID(sv) && (stash = GvSTASH(sv))) - sv_del_backref((SV*)stash, sv); + sv_del_backref(MUTABLE_SV(stash), sv); } /* FIXME. There are probably more unreferenced pointers to SVs in the interpreter struct that we should check and tidy in a similar fashion to this: */ - if ((GV*)sv == PL_last_in_gv) + if ((const GV *)sv == PL_last_in_gv) PL_last_in_gv = NULL; case SVt_PVMG: case SVt_PVNV: @@ -6631,6 +6727,9 @@ Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append) 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. */ @@ -6642,13 +6741,19 @@ Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append) /* doing, but we've got no other real choice - except avoid stdio as implementation - perhaps write a :vms layer ? */ - bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize); + 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); + SvCUR_set(sv, bytesread + append); buffer[bytesread] = '\0'; goto return_string_or_null; } @@ -6933,7 +7038,7 @@ Perl_sv_inc(pTHX_ register SV *const sv) sv_force_normal_flags(sv, 0); if (SvREADONLY(sv)) { if (IN_PERL_RUNTIME) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); } if (SvROK(sv)) { IV i; @@ -7096,7 +7201,7 @@ Perl_sv_dec(pTHX_ register SV *const sv) sv_force_normal_flags(sv, 0); if (SvREADONLY(sv)) { if (IN_PERL_RUNTIME) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); } if (SvROK(sv)) { IV i; @@ -7456,6 +7561,8 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) if (!hash) PERL_HASH(hash, src, len); new_SV(sv); + /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it + changes here, update it there too. */ sv_upgrade(sv, SVt_PV); SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash)); SvCUR_set(sv, len); @@ -7699,7 +7806,7 @@ Perl_sv_reset(pTHX_ register const char *s, HV *const stash) return; if (!*s) { /* reset ?? searches */ - MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab); + MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab); if (mg) { const U32 count = mg->mg_len / sizeof(PMOP**); PMOP **pmp = (PMOP**) mg->mg_ptr; @@ -7744,7 +7851,7 @@ Perl_sv_reset(pTHX_ register const char *s, HV *const stash) if (!todo[(U8)*HeKEY(entry)]) continue; - gv = (GV*)HeVAL(entry); + gv = MUTABLE_GV(HeVAL(entry)); sv = GvSV(gv); if (sv) { if (SvTHINKFIRST(sv)) { @@ -7801,14 +7908,17 @@ Perl_sv_2io(pTHX_ SV *const sv) switch (SvTYPE(sv)) { case SVt_PVIO: - io = (IO*)sv; + io = MUTABLE_IO(sv); break; case SVt_PVGV: - gv = (GV*)sv; - io = GvIO(gv); - if (!io) - Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv)); - break; + if (isGV_with_GP(sv)) { + gv = MUTABLE_GV(sv); + io = GvIO(gv); + if (!io) + Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv)); + break; + } + /* FALL THROUGH */ default: if (!SvOK(sv)) Perl_croak(aTHX_ PL_no_usym, "filehandle"); @@ -7854,47 +7964,52 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) case SVt_PVCV: *st = CvSTASH(sv); *gvp = NULL; - return (CV*)sv; + return MUTABLE_CV(sv); case SVt_PVHV: case SVt_PVAV: *st = NULL; *gvp = NULL; return NULL; case SVt_PVGV: - gv = (GV*)sv; - *gvp = gv; - *st = GvESTASH(gv); - goto fix_gv; + if (isGV_with_GP(sv)) { + gv = MUTABLE_GV(sv); + *gvp = gv; + *st = GvESTASH(gv); + goto fix_gv; + } + /* FALL THROUGH */ default: - SvGETMAGIC(sv); if (SvROK(sv)) { SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */ + SvGETMAGIC(sv); tryAMAGICunDEREF(to_cv); sv = SvRV(sv); if (SvTYPE(sv) == SVt_PVCV) { - cv = (CV*)sv; + cv = MUTABLE_CV(sv); *gvp = NULL; *st = CvSTASH(cv); return cv; } - else if(isGV(sv)) - gv = (GV*)sv; + else if(isGV_with_GP(sv)) + gv = MUTABLE_GV(sv); else Perl_croak(aTHX_ "Not a subroutine reference"); } - else if (isGV(sv)) - gv = (GV*)sv; + else if (isGV_with_GP(sv)) { + SvGETMAGIC(sv); + gv = MUTABLE_GV(sv); + } else - gv = gv_fetchsv(sv, lref, SVt_PVCV); + gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */ *gvp = gv; if (!gv) { *st = NULL; return NULL; } /* Some flags to gv_fetchsv mean don't really create the GV */ - if (SvTYPE(gv) != SVt_PVGV) { + if (!isGV_with_GP(gv)) { *st = NULL; return NULL; } @@ -8109,7 +8224,8 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) case SVt_PVAV: return "ARRAY"; case SVt_PVHV: return "HASH"; case SVt_PVCV: return "CODE"; - case SVt_PVGV: return "GLOB"; + case SVt_PVGV: return (char *) (isGV_with_GP(sv) + ? "GLOB" : "SCALAR"); case SVt_PVFM: return "FORMAT"; case SVt_PVIO: return "IO"; case SVt_BIND: return "BIND"; @@ -8137,7 +8253,7 @@ Perl_sv_isobject(pTHX_ SV *sv) SvGETMAGIC(sv); if (!SvROK(sv)) return 0; - sv = (SV*)SvRV(sv); + sv = SvRV(sv); if (!SvOBJECT(sv)) return 0; return 1; @@ -8165,7 +8281,7 @@ Perl_sv_isa(pTHX_ SV *sv, const char *const name) SvGETMAGIC(sv); if (!SvROK(sv)) return 0; - sv = (SV*)SvRV(sv); + sv = SvRV(sv); if (!SvOBJECT(sv)) return 0; hvname = HvNAME_get(SvSTASH(sv)); @@ -8371,7 +8487,7 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) if (SvIsCOW(tmpRef)) sv_force_normal_flags(tmpRef, 0); if (SvREADONLY(tmpRef)) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); if (SvOBJECT(tmpRef)) { if (SvTYPE(tmpRef) != SVt_PVIO) --PL_sv_objcount; @@ -8382,7 +8498,7 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) if (SvTYPE(tmpRef) != SVt_PVIO) ++PL_sv_objcount; SvUPGRADE(tmpRef, SVt_PVMG); - SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc_simple(stash)); + SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash))); if (Gv_AMG(stash)) SvAMAGIC_on(sv); @@ -8413,15 +8529,16 @@ S_sv_unglob(pTHX_ SV *const sv) assert(SvTYPE(sv) == SVt_PVGV); SvFAKE_off(sv); - gv_efullname3(temp, (GV *) sv, "*"); + gv_efullname3(temp, MUTABLE_GV(sv), "*"); if (GvGP(sv)) { - if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash)) + if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) + && HvNAME_get(stash)) mro_method_changed_in(stash); - gp_free((GV*)sv); + gp_free(MUTABLE_GV(sv)); } if (GvSTASH(sv)) { - sv_del_backref((SV*)GvSTASH(sv), sv); + sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv); GvSTASH(sv) = NULL; } GvMULTI_off(sv); @@ -8815,7 +8932,7 @@ Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, { PERL_ARGS_ASSERT_SV_VSETPVFN; - sv_setpvn(sv, "", 0); + sv_setpvs(sv, ""); sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted); } @@ -8935,7 +9052,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, } if (args && patlen == 3 && pat[0] == '%' && pat[1] == '-' && pat[2] == 'p') { - argsv = (SV*)va_arg(*args, void*); + argsv = MUTABLE_SV(va_arg(*args, void*)); sv_catsv(sv, argsv); return; } @@ -9010,6 +9127,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, STRLEN esignlen = 0; const char *eptr = NULL; + const char *fmtstart; STRLEN elen = 0; SV *vecsv = NULL; const U8 *vecstr = NULL; @@ -9050,6 +9168,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, if (q++ >= patend) break; + fmtstart = q; + /* We allow format specification elements in this order: \d+\$ explicit format parameter index @@ -9092,7 +9212,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, precis = n; has_precis = TRUE; } - argsv = (SV*)va_arg(*args, void*); + argsv = MUTABLE_SV(va_arg(*args, void*)); eptr = SvPV_const(argsv, elen); if (DO_UTF8(argsv)) is_utf8 = TRUE; @@ -9212,7 +9332,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, */ if (sv_derived_from(vecsv, "version")) { char *version = savesvpv(vecsv); - if ( hv_exists((HV*)SvRV(vecsv), "alpha", 5 ) ) { + if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) { Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "vector argument not supported with alpha versions"); goto unknown; @@ -9445,8 +9565,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, case 'l': iv = va_arg(*args, long); break; case 'V': iv = va_arg(*args, IV); break; default: iv = va_arg(*args, int); break; + case 'q': #ifdef HAS_QUAD - case 'q': iv = va_arg(*args, Quad_t); break; + iv = va_arg(*args, Quad_t); break; +#else + goto unknown; #endif } } @@ -9457,8 +9580,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, case 'l': iv = (long)tiv; break; case 'V': default: iv = tiv; break; + case 'q': #ifdef HAS_QUAD - case 'q': iv = (Quad_t)tiv; break; + iv = (Quad_t)tiv; break; +#else + goto unknown; #endif } } @@ -9530,8 +9656,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, case 'l': uv = va_arg(*args, unsigned long); break; case 'V': uv = va_arg(*args, UV); break; default: uv = va_arg(*args, unsigned); break; + case 'q': #ifdef HAS_QUAD - case 'q': uv = va_arg(*args, Uquad_t); break; + uv = va_arg(*args, Uquad_t); break; +#else + goto unknown; #endif } } @@ -9542,8 +9671,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, case 'l': uv = (unsigned long)tuv; break; case 'V': default: uv = tuv; break; + case 'q': #ifdef HAS_QUAD - case 'q': uv = (Uquad_t)tuv; break; + uv = (Uquad_t)tuv; break; +#else + goto unknown; #endif } } @@ -9829,8 +9961,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, default: *(va_arg(*args, int*)) = i; break; case 'l': *(va_arg(*args, long*)) = i; break; case 'V': *(va_arg(*args, IV*)) = i; break; + case 'q': #ifdef HAS_QUAD - case 'q': *(va_arg(*args, Quad_t*)) = i; break; + *(va_arg(*args, Quad_t*)) = i; break; +#else + goto unknown; #endif } } @@ -9849,16 +9984,22 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, SV * const msg = sv_newmortal(); Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ", (PL_op->op_type == OP_PRTF) ? "" : "s"); - if (c) { - if (isPRINT(c)) - Perl_sv_catpvf(aTHX_ msg, - "\"%%%c\"", c & 0xFF); - else - Perl_sv_catpvf(aTHX_ msg, - "\"%%\\%03"UVof"\"", - (UV)c & 0xFF); - } else + if (fmtstart < patend) { + const char * const fmtend = q < patend ? q : patend; + const char * f; + sv_catpvs(msg, "\"%"); + for (f = fmtstart; f < fmtend; f++) { + if (isPRINT(*f)) { + sv_catpvn(msg, f, 1); + } else { + Perl_sv_catpvf(aTHX_ msg, + "\\%03"UVof, (UV)*f & 0xFF); + } + } + sv_catpvs(msg, "\""); + } else { sv_catpvs(msg, "end of string"); + } Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */ } @@ -9900,13 +10041,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, have = esignlen + zeros + elen; if (have < zeros) - Perl_croak_nocontext(PL_memory_wrap); + Perl_croak_nocontext("%s", PL_memory_wrap); need = (have > width ? have : width); gap = need - have; if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1)) - Perl_croak_nocontext(PL_memory_wrap); + Perl_croak_nocontext("%s", PL_memory_wrap); SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1); p = SvEND(sv); if (esignlen && fill == '0') { @@ -9987,16 +10128,16 @@ ptr_table_* functions. If this changes, please unmerge ss_dup. */ #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t)) #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t)) -#define av_dup(s,t) (AV*)sv_dup((SV*)s,t) -#define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t)) -#define hv_dup(s,t) (HV*)sv_dup((SV*)s,t) -#define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t)) -#define cv_dup(s,t) (CV*)sv_dup((SV*)s,t) -#define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t)) -#define io_dup(s,t) (IO*)sv_dup((SV*)s,t) -#define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t)) -#define gv_dup(s,t) (GV*)sv_dup((SV*)s,t) -#define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t)) +#define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t)) +#define av_dup_inc(s,t) MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t)) +#define hv_dup_inc(s,t) MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t)) +#define cv_dup_inc(s,t) MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t)) +#define io_dup_inc(s,t) MUTABLE_IO(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t)) +#define gv_dup_inc(s,t) MUTABLE_GV(SvREFCNT_inc(sv_dup((const SV *)s,t))) #define SAVEPV(p) ((p) ? savepv(p) : NULL) #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL) @@ -10220,14 +10361,15 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param) nmg->mg_flags = mg->mg_flags; /* FIXME for plugins if (mg->mg_type == PERL_MAGIC_qr) { - nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param); + nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)mg->mg_obj, param)); } else */ if(mg->mg_type == PERL_MAGIC_backref) { /* The backref AV has its reference count deliberately bumped by 1. */ - nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param)); + nmg->mg_obj + = SvREFCNT_inc(av_dup_inc((const AV *) mg->mg_obj, param)); } else { nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED) @@ -10251,7 +10393,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param) } } else if (mg->mg_len == HEf_SVKEY) - nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param); + nmg->mg_ptr = (char*)sv_dup_inc((const SV *)mg->mg_ptr, param); } if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) { CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param); @@ -10425,8 +10567,8 @@ Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const pa if (SvROK(sstr)) { SvRV_set(dstr, SvWEAKREF(sstr) - ? sv_dup(SvRV(sstr), param) - : sv_dup_inc(SvRV(sstr), param)); + ? sv_dup(SvRV_const(sstr), param) + : sv_dup_inc(SvRV_const(sstr), param)); } else if (SvPVX_const(sstr)) { @@ -10454,7 +10596,7 @@ Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const pa } else { /* Some other special case - random pointer */ - SvPV_set(dstr, SvPVX(sstr)); + SvPV_set(dstr, (char *) SvPVX_const(sstr)); } } } @@ -10483,7 +10625,7 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) return NULL; } /* look for it in the table first */ - dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr); + dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr)); if (dstr) return dstr; @@ -10494,7 +10636,7 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) const HEK * const hvname = HvNAME_HEK(sstr); if (hvname) /** don't clone stashes if they already exist **/ - return (SV*)gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0); + return MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0)); } } @@ -10559,7 +10701,7 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) break; case SVt_PVGV: - if (GvUNIQUE((GV*)sstr)) { + if (GvUNIQUE((const GV *)sstr)) { NOOP; /* Do sharing here, and fall through */ } case SVt_PVIO: @@ -10632,7 +10774,7 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */ LvTARG(dstr) = dstr; else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */ - LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param); + LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param)); else LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param); case SVt_PVGV: @@ -10680,16 +10822,16 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr)); break; case SVt_PVAV: - if (AvARRAY((AV*)sstr)) { + if (AvARRAY((const AV *)sstr)) { SV **dst_ary, **src_ary; - SSize_t items = AvFILLp((AV*)sstr) + 1; + SSize_t items = AvFILLp((const AV *)sstr) + 1; - src_ary = AvARRAY((AV*)sstr); - Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*); + src_ary = AvARRAY((const AV *)sstr); + Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*); ptr_table_store(PL_ptr_table, src_ary, dst_ary); - AvARRAY((AV*)dstr) = dst_ary; - AvALLOC((AV*)dstr) = dst_ary; - if (AvREAL((AV*)sstr)) { + AvARRAY(MUTABLE_AV(dstr)) = dst_ary; + AvALLOC((const AV *)dstr) = dst_ary; + if (AvREAL((const AV *)sstr)) { while (items-- > 0) *dst_ary++ = sv_dup_inc(*src_ary++, param); } @@ -10697,18 +10839,18 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) while (items-- > 0) *dst_ary++ = sv_dup(*src_ary++, param); } - items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr); + items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr); while (items-- > 0) { *dst_ary++ = &PL_sv_undef; } } else { - AvARRAY((AV*)dstr) = NULL; - AvALLOC((AV*)dstr) = (SV**)NULL; + AvARRAY(MUTABLE_AV(dstr)) = NULL; + AvALLOC((const AV *)dstr) = (SV**)NULL; } break; case SVt_PVHV: - if (HvARRAY((HV*)sstr)) { + if (HvARRAY((const HV *)sstr)) { STRLEN i = 0; const bool sharekeys = !!HvSHAREKEYS(sstr); XPVHV * const dxhv = (XPVHV*)SvANY(dstr); @@ -10739,10 +10881,11 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) daux->xhv_eiter = saux->xhv_eiter ? he_dup(saux->xhv_eiter, (bool)!!HvSHAREKEYS(sstr), param) : 0; + /* backref array needs refcnt=2; see sv_add_backref */ daux->xhv_backreferences = saux->xhv_backreferences - ? (AV*) SvREFCNT_inc( - sv_dup((SV*)saux->xhv_backreferences, param)) + ? MUTABLE_AV(SvREFCNT_inc( + sv_dup_inc((const SV *)saux->xhv_backreferences, param))) : 0; daux->xhv_mro_meta = saux->xhv_mro_meta @@ -10755,7 +10898,7 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) } } else - HvARRAY((HV*)dstr) = NULL; + HvARRAY(MUTABLE_HV(dstr)) = NULL; break; case SVt_PVCV: if (!(param->flags & CLONEf_COPY_STACKS)) { @@ -10771,7 +10914,7 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) if (CvCONST(dstr) && CvISXSUB(dstr)) { CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ? SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) : - sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param); + sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param); } /* don't dup if copying back - CvGV isn't refcounted, so the * duped GV may never be freed. A bit of a hack! DAPM */ @@ -10862,7 +11005,8 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) ncx->blk_loop.oldcomppad); } else { ncx->blk_loop.oldcomppad - = (PAD*)gv_dup((GV*)ncx->blk_loop.oldcomppad, param); + = (PAD*)gv_dup((const GV *)ncx->blk_loop.oldcomppad, + param); } break; case CXt_FORMAT: @@ -10973,10 +11117,10 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) const I32 max = proto_perl->Isavestack_max; I32 ix = proto_perl->Isavestack_ix; ANY *nss; - SV *sv; - GV *gv; - AV *av; - HV *hv; + const SV *sv; + const GV *gv; + const AV *av; + const HV *hv; void* ptr; int intval; long longval; @@ -10996,17 +11140,17 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPINT(nss,ix) = type; switch (type) { case SAVEt_HELEM: /* hash element */ - sv = (SV*)POPPTR(ss,ix); + sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); /* fall through */ case SAVEt_ITEM: /* normal string */ case SAVEt_SV: /* scalar reference */ - sv = (SV*)POPPTR(ss,ix); + sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); /* fall through */ case SAVEt_FREESV: case SAVEt_MORTALIZESV: - sv = (SV*)POPPTR(ss,ix); + sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); break; case SAVEt_SHARED_PVREF: /* char* in shared space */ @@ -11017,19 +11161,19 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) break; case SAVEt_GENERIC_SVREF: /* generic sv */ case SAVEt_SVREF: /* scalar reference */ - sv = (SV*)POPPTR(ss,ix); + sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ break; case SAVEt_HV: /* hash reference */ case SAVEt_AV: /* array reference */ - sv = (SV*) POPPTR(ss,ix); + sv = (const SV *) POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); /* fall through */ case SAVEt_COMPPAD: case SAVEt_NSTAB: - sv = (SV*) POPPTR(ss,ix); + sv = (const SV *) POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup(sv, param); break; case SAVEt_INT: /* int reference */ @@ -11066,7 +11210,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) case SAVEt_SPTR: /* SV* reference */ ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - sv = (SV*)POPPTR(ss,ix); + sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup(sv, param); break; case SAVEt_VPTR: /* random* reference */ @@ -11086,7 +11230,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) gp = (GP*)POPPTR(ss,ix); TOPPTR(nss,ix) = gp = gp_dup(gp, param); (void)GpREFCNT_inc(gp); - gv = (GV*)POPPTR(ss,ix); + gv = (const GV *)POPPTR(ss,ix); TOPPTR(nss,ix) = gv_dup_inc(gv, param); break; case SAVEt_FREEOP: @@ -11115,16 +11259,16 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) else TOPPTR(nss,ix) = NULL; break; - case SAVEt_FREEPV: - c = (char*)POPPTR(ss,ix); - TOPPTR(nss,ix) = pv_dup_inc(c); - break; case SAVEt_DELETE: - hv = (HV*)POPPTR(ss,ix); + hv = (const HV *)POPPTR(ss,ix); TOPPTR(nss,ix) = hv_dup_inc(hv, param); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + /* Fall through */ + case SAVEt_FREEPV: c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = pv_dup_inc(c); - /* fall through */ + break; case SAVEt_STACK_POS: /* Position on Perl stack */ i = POPINT(ss,ix); TOPINT(nss,ix) = i; @@ -11152,11 +11296,11 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) ix -= i; break; case SAVEt_AELEM: /* array element */ - sv = (SV*)POPPTR(ss,ix); + sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); i = POPINT(ss,ix); TOPINT(nss,ix) = i; - av = (AV*)POPPTR(ss,ix); + av = (const AV *)POPPTR(ss,ix); TOPPTR(nss,ix) = av_dup_inc(av, param); break; case SAVEt_OP: @@ -11164,8 +11308,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPPTR(nss,ix) = ptr; break; case SAVEt_HINTS: - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; ptr = POPPTR(ss,ix); if (ptr) { HINTS_REFCNT_LOCK; @@ -11173,8 +11315,10 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) HINTS_REFCNT_UNLOCK; } TOPPTR(nss,ix) = ptr; + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; if (i & HINT_LOCALIZE_HH) { - hv = (HV*)POPPTR(ss,ix); + hv = (const HV *)POPPTR(ss,ix); TOPPTR(nss,ix) = hv_dup_inc(hv, param); } break; @@ -11183,7 +11327,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPLONG(nss,ix) = longval; ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - sv = (SV*)POPPTR(ss,ix); + sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); break; case SAVEt_BOOL: @@ -11197,7 +11341,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPINT(nss,ix) = i; i = POPINT(ss,ix); TOPINT(nss,ix) = i; - sv = (SV*)POPPTR(ss,ix); + sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup(sv, param); break; case SAVEt_RE_STATE: @@ -11286,9 +11430,9 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) static void do_mark_cloneable_stash(pTHX_ SV *const sv) { - const HEK * const hvname = HvNAME_HEK((HV*)sv); + const HEK * const hvname = HvNAME_HEK((const HV *)sv); if (hvname) { - GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0); + GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0); SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */ if (cloner && GvCV(cloner)) { dSP; @@ -11299,7 +11443,7 @@ do_mark_cloneable_stash(pTHX_ SV *const sv) PUSHMARK(SP); mXPUSHs(newSVhek(hvname)); PUTBACK; - call_sv((SV*)GvCV(cloner), G_SCALAR); + call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR); SPAGAIN; status = POPu; PUTBACK; @@ -11603,9 +11747,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif PL_encoding = sv_dup(proto_perl->Iencoding, param); - sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */ - sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */ - sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */ + sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */ + sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */ + sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */ /* RE engine related */ @@ -11622,6 +11766,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_regex_pad = AvARRAY(PL_regex_padav); /* shortcuts to various I/O objects */ + PL_ofsgv = gv_dup(proto_perl->Iofsgv, param); PL_stdingv = gv_dup(proto_perl->Istdingv, param); PL_stderrgv = gv_dup(proto_perl->Istderrgv, param); PL_defgv = gv_dup(proto_perl->Idefgv, param); @@ -11938,8 +12083,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, * orphaned */ for (i = 0; i<= proto_perl->Itmps_ix; i++) { - SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table, - proto_perl->Itmps_stack[i]); + SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, + proto_perl->Itmps_stack[i])); if (nsv && !SvREFCNT(nsv)) { EXTEND_MORTAL(1); PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv); @@ -11968,7 +12113,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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_ofs_sv = sv_dup_inc(proto_perl->Iofs_sv, 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); @@ -12032,7 +12176,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, identified by sv_dup() above. */ while(av_len(param->stashes) != -1) { - HV* const stash = (HV*) av_shift(param->stashes); + HV* const stash = MUTABLE_HV(av_shift(param->stashes)); GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0); if (cloner && GvCV(cloner)) { dSP; @@ -12041,7 +12185,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PUSHMARK(SP); mXPUSHs(newSVhek(HvNAME_HEK(stash))); PUTBACK; - call_sv((SV*)GvCV(cloner), G_DISCARD); + call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD); FREETMPS; LEAVE; } @@ -12193,7 +12337,7 @@ Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, * If so, return a mortal copy of the key. */ STATIC SV* -S_find_hash_subscript(pTHX_ HV *hv, SV* val) +S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val) { dVAR; register HE **array; @@ -12229,7 +12373,7 @@ S_find_hash_subscript(pTHX_ HV *hv, SV* val) * If so, return the index, otherwise return -1. */ STATIC I32 -S_find_array_subscript(pTHX_ AV *av, SV* val) +S_find_array_subscript(pTHX_ const AV *const av, const SV *const val) { dVAR; @@ -12262,8 +12406,8 @@ S_find_array_subscript(pTHX_ AV *av, SV* val) #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */ STATIC SV* -S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, - SV* keyname, I32 aindex, int subscript_type) +S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, + const SV *const keyname, I32 aindex, int subscript_type) { SV * const name = sv_newmortal(); @@ -12292,7 +12436,7 @@ S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, if (!cv || !CvPADLIST(cv)) return NULL; - av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE)); + av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE))); sv = *av_fetch(av, targ, FALSE); sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv)); } @@ -12308,8 +12452,10 @@ S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, *SvPVX(name) = '$'; Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex); } - else if (subscript_type == FUV_SUBSCRIPT_WITHIN) - Perl_sv_insert(aTHX_ name, 0, 0, STR_WITH_LEN("within ")); + else if (subscript_type == FUV_SUBSCRIPT_WITHIN) { + /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */ + Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0); + } return name; } @@ -12336,13 +12482,13 @@ PL_comppad/PL_curpad points to the currently executing pad. */ STATIC SV * -S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) +S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, + bool match) { dVAR; SV *sv; - AV *av; - GV *gv; - OP *o, *o2, *kid; + const GV *gv; + const OP *o, *o2, *kid; if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef || uninit_sv == &PL_sv_placeholder))) @@ -12371,7 +12517,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) gv = cGVOPx_gv(cUNOPx(obase)->op_first); if (!gv) break; - sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv); + sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv)); } else /* @{expr}, %{expr} */ return find_uninit_var(cUNOPx(obase)->op_first, @@ -12380,12 +12526,12 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) /* attempt to find a match within the aggregate */ if (hash) { - keysv = find_hash_subscript((HV*)sv, uninit_sv); + keysv = find_hash_subscript((const HV*)sv, uninit_sv); if (keysv) subscript_type = FUV_SUBSCRIPT_HASH; } else { - index = find_array_subscript((AV*)sv, uninit_sv); + index = find_array_subscript((const AV *)sv, uninit_sv); if (index >= 0) subscript_type = FUV_SUBSCRIPT_ARRAY; } @@ -12413,7 +12559,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) if (obase->op_flags & OPf_SPECIAL) { /* lexical array */ if (match) { SV **svp; - av = (AV*)PAD_SV(obase->op_targ); + AV *av = MUTABLE_AV(PAD_SV(obase->op_targ)); if (!av || SvRMAGICAL(av)) break; svp = av_fetch(av, (I32)obase->op_private, FALSE); @@ -12429,7 +12575,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) break; if (match) { SV **svp; - av = GvAV(gv); + AV *const av = GvAV(gv); if (!av || SvRMAGICAL(av)) break; svp = av_fetch(av, (I32)obase->op_private, FALSE); @@ -12469,7 +12615,8 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) gv = cGVOPx_gv(cUNOPo->op_first); if (!gv) break; - sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv); + sv = o->op_type + == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv)); } if (!sv) break; @@ -12480,12 +12627,12 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) if (SvMAGICAL(sv)) break; if (obase->op_type == OP_HELEM) { - HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0); + HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0); if (!he || HeVAL(he) != uninit_sv) break; } else { - SV * const * const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE); + SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE); if (!svp || *svp != uninit_sv) break; } @@ -12501,13 +12648,14 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) /* index is an expression; * attempt to find a match within the aggregate */ if (obase->op_type == OP_HELEM) { - SV * const keysv = find_hash_subscript((HV*)sv, uninit_sv); + SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv); if (keysv) return varname(gv, '%', o->op_targ, keysv, 0, FUV_SUBSCRIPT_HASH); } else { - const I32 index = find_array_subscript((AV*)sv, uninit_sv); + const I32 index + = find_array_subscript((const AV *)sv, uninit_sv); if (index >= 0) return varname(gv, '@', o->op_targ, NULL, index, FUV_SUBSCRIPT_ARRAY); @@ -12558,7 +12706,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) : DEFSV)) { sv = sv_newmortal(); - sv_setpvn(sv, "$_", 2); + sv_setpvs(sv, "$_"); return sv; } } @@ -12567,6 +12715,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) case OP_PRTF: case OP_PRINT: case OP_SAY: + match = 1; /* print etc can return undef on defined args */ /* skip filehandle as it can't produce 'undef' warning */ o = cUNOPx(obase)->op_first; if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK) @@ -12576,8 +12725,81 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */ case OP_RV2SV: - case OP_CUSTOM: - match = 1; /* XS or custom code could trigger random warnings */ + case OP_CUSTOM: /* XS or custom code could trigger random warnings */ + + /* the following ops are capable of returning PL_sv_undef even for + * defined arg(s) */ + + case OP_BACKTICK: + case OP_PIPE_OP: + case OP_FILENO: + case OP_BINMODE: + case OP_TIED: + case OP_GETC: + case OP_SYSREAD: + case OP_SEND: + case OP_IOCTL: + case OP_SOCKET: + case OP_SOCKPAIR: + case OP_BIND: + case OP_CONNECT: + case OP_LISTEN: + case OP_ACCEPT: + case OP_SHUTDOWN: + case OP_SSOCKOPT: + case OP_GETPEERNAME: + case OP_FTRREAD: + case OP_FTRWRITE: + case OP_FTREXEC: + case OP_FTROWNED: + case OP_FTEREAD: + case OP_FTEWRITE: + case OP_FTEEXEC: + case OP_FTEOWNED: + case OP_FTIS: + case OP_FTZERO: + case OP_FTSIZE: + case OP_FTFILE: + case OP_FTDIR: + case OP_FTLINK: + case OP_FTPIPE: + case OP_FTSOCK: + case OP_FTBLK: + case OP_FTCHR: + case OP_FTTTY: + case OP_FTSUID: + case OP_FTSGID: + case OP_FTSVTX: + case OP_FTTEXT: + case OP_FTBINARY: + case OP_FTMTIME: + case OP_FTATIME: + case OP_FTCTIME: + case OP_READLINK: + case OP_OPEN_DIR: + case OP_READDIR: + case OP_TELLDIR: + case OP_SEEKDIR: + case OP_REWINDDIR: + case OP_CLOSEDIR: + case OP_GMTIME: + case OP_ALARM: + case OP_SEMGET: + case OP_GETLOGIN: + case OP_UNDEF: + case OP_SUBSTR: + case OP_AEACH: + case OP_EACH: + case OP_SORT: + case OP_CALLER: + case OP_DOFILE: + case OP_PROTOTYPE: + case OP_NCMP: + case OP_SMARTMATCH: + case OP_UNPACK: + case OP_SYSOPEN: + case OP_SYSSEEK: + match = 1; goto do_op; case OP_ENTERSUB: @@ -12589,6 +12811,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) Need a better fix at dome point. DAPM 11/2007 */ break; + case OP_POS: /* def-ness of rval pos() is independent of the def-ness of its arg */ if ( !(obase->op_flags & OPf_MOD)) @@ -12653,7 +12876,7 @@ Print appropriate "Use of uninitialized variable" warning */ void -Perl_report_uninit(pTHX_ SV* uninit_sv) +Perl_report_uninit(pTHX_ const SV *uninit_sv) { dVAR; if (PL_op) {