X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=c2b41714acbfca6637a28bc771d4a8d6589188ea;hb=e27835eefa408ae52d4ae22eec67eea282a87949;hp=c621b2ab70f6627efc1f1698048b485a89c1ca74;hpb=af828c019524ef5fdaaaa6e3b76d5e2381d0ae6b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index c621b2a..c2b4171 100644 --- a/sv.c +++ b/sv.c @@ -249,13 +249,12 @@ 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; @@ -516,6 +515,10 @@ static void do_clean_all(pTHX_ SV *const sv) { dVAR; + if (sv == (SV*) PL_fdpid || sv == (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); @@ -1488,7 +1491,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) { @@ -1540,6 +1543,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: @@ -1647,6 +1652,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: @@ -3159,13 +3166,21 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *const sv, const I32 flags) const U8 ch = *t++; /* Check for hi bit */ 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; } } @@ -3549,7 +3564,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 */ @@ -3714,8 +3728,10 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) GvMULTI_on(dstr); return; } - glob_assign_glob(dstr, sstr, dtype); - return; + if (isGV_with_GP(sstr)) { + glob_assign_glob(dstr, sstr, dtype); + return; + } } if (dtype >= SVt_PV) { @@ -4373,6 +4389,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; @@ -4383,8 +4400,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. */ + 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); + max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(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 */ @@ -5136,14 +5162,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; @@ -5153,11 +5182,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); @@ -5882,7 +5911,8 @@ S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start boffset = real_boffset; } - S_utf8_mg_pos_cache_update(aTHX_ sv, mgp, boffset, uoffset, send - start); + if (PL_utf8cache) + utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start); return boffset; } @@ -5970,8 +6000,8 @@ Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp from. */ static void -S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8, - STRLEN blen) +S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte, + const STRLEN utf8, const STRLEN blen) { STRLEN *cache; @@ -6110,8 +6140,8 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8, assumption is made as in S_sv_pos_u2b_midway(), namely that walking backward is half the speed of walking forward. */ static STRLEN -S_sv_pos_b2u_midway(pTHX_ const U8 *s, const U8 *const target, const U8 *end, - STRLEN endu) +S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target, + const U8 *end, STRLEN endu) { const STRLEN forw = target - s; STRLEN backw = end - target; @@ -6149,7 +6179,7 @@ Handles magic and type coercion. * */ void -Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) +Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp) { const U8* s; const STRLEN byte = *offsetp; @@ -6237,7 +6267,8 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) } *offsetp = len; - S_utf8_mg_pos_cache_update(aTHX_ sv, &mg, byte, len, blen); + if (PL_utf8cache) + utf8_mg_pos_cache_update(sv, &mg, byte, len, blen); } /* @@ -6352,7 +6383,7 @@ coerce its args to strings if necessary. See also C. */ I32 -Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) +Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2) { dVAR; STRLEN cur1, cur2; @@ -6434,7 +6465,7 @@ if necessary. See also C. */ I32 -Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2) +Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2) { dVAR; #ifdef USE_LOCALE_COLLATE @@ -6499,7 +6530,7 @@ settings. */ char * -Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) +Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp) { dVAR; MAGIC *mg; @@ -6557,7 +6588,7 @@ appending to the currently-stored string. */ char * -Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) +Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append) { dVAR; const char *rsptr; @@ -6627,6 +6658,9 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *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. */ @@ -6638,7 +6672,13 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *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 @@ -6915,7 +6955,7 @@ if necessary. Handles 'get' magic. */ void -Perl_sv_inc(pTHX_ register SV *sv) +Perl_sv_inc(pTHX_ register SV *const sv) { dVAR; register char *d; @@ -7079,7 +7119,7 @@ if necessary. Handles 'get' magic. */ void -Perl_sv_dec(pTHX_ register SV *sv) +Perl_sv_dec(pTHX_ register SV *const sv) { dVAR; int flags; @@ -7208,7 +7248,7 @@ statement boundaries. See also C and C. * permanent location. */ SV * -Perl_sv_mortalcopy(pTHX_ SV *oldstr) +Perl_sv_mortalcopy(pTHX_ SV *const oldstr) { dVAR; register SV *sv; @@ -7265,7 +7305,7 @@ C is a convenience wrapper for this function, defined as */ SV * -Perl_newSVpvn_flags(pTHX_ const char *s, STRLEN len, U32 flags) +Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags) { dVAR; register SV *sv; @@ -7292,7 +7332,7 @@ and C. */ SV * -Perl_sv_2mortal(pTHX_ register SV *sv) +Perl_sv_2mortal(pTHX_ register SV *const sv) { dVAR; if (!sv) @@ -7316,7 +7356,7 @@ strlen(). For efficiency, consider using C instead. */ SV * -Perl_newSVpv(pTHX_ const char *s, STRLEN len) +Perl_newSVpv(pTHX_ const char *const s, const STRLEN len) { dVAR; register SV *sv; @@ -7338,7 +7378,7 @@ C bytes long. If the C argument is NULL the new SV will be undefined. */ SV * -Perl_newSVpvn(pTHX_ const char *s, STRLEN len) +Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len) { dVAR; register SV *sv; @@ -7359,7 +7399,7 @@ SV if the hek is NULL. */ SV * -Perl_newSVhek(pTHX_ const HEK *hek) +Perl_newSVhek(pTHX_ const HEK *const hek) { dVAR; if (!hek) { @@ -7475,7 +7515,7 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) */ SV * -Perl_newSVpvf_nocontext(const char* pat, ...) +Perl_newSVpvf_nocontext(const char *const pat, ...) { dTHX; register SV *sv; @@ -7500,7 +7540,7 @@ C. */ SV * -Perl_newSVpvf(pTHX_ const char* pat, ...) +Perl_newSVpvf(pTHX_ const char *const pat, ...) { register SV *sv; va_list args; @@ -7516,7 +7556,7 @@ Perl_newSVpvf(pTHX_ const char* pat, ...) /* backend for newSVpvf() and newSVpvf_nocontext() */ SV * -Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args) +Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args) { dVAR; register SV *sv; @@ -7538,7 +7578,7 @@ The reference count for the SV is set to 1. */ SV * -Perl_newSVnv(pTHX_ NV n) +Perl_newSVnv(pTHX_ const NV n) { dVAR; register SV *sv; @@ -7558,7 +7598,7 @@ SV is set to 1. */ SV * -Perl_newSViv(pTHX_ IV i) +Perl_newSViv(pTHX_ const IV i) { dVAR; register SV *sv; @@ -7578,7 +7618,7 @@ The reference count for the SV is set to 1. */ SV * -Perl_newSVuv(pTHX_ UV u) +Perl_newSVuv(pTHX_ const UV u) { dVAR; register SV *sv; @@ -7617,7 +7657,7 @@ SV is B incremented. */ SV * -Perl_newRV_noinc(pTHX_ SV *tmpRef) +Perl_newRV_noinc(pTHX_ SV *const tmpRef) { dVAR; register SV *sv = newSV_type(SVt_IV); @@ -7635,7 +7675,7 @@ Perl_newRV_noinc(pTHX_ SV *tmpRef) */ SV * -Perl_newRV(pTHX_ SV *sv) +Perl_newRV(pTHX_ SV *const sv) { dVAR; @@ -7654,7 +7694,7 @@ Creates a new SV which is an exact duplicate of the original SV. */ SV * -Perl_newSVsv(pTHX_ register SV *old) +Perl_newSVsv(pTHX_ register SV *const old) { dVAR; register SV *sv; @@ -7684,7 +7724,7 @@ Note that the perl-level function is vaguely deprecated. */ void -Perl_sv_reset(pTHX_ register const char *s, HV *stash) +Perl_sv_reset(pTHX_ register const char *s, HV *const stash) { dVAR; char todo[PERL_UCHAR_MAX+1]; @@ -7788,7 +7828,7 @@ named after the PV if we're a string. */ IO* -Perl_sv_2io(pTHX_ SV *sv) +Perl_sv_2io(pTHX_ SV *const sv) { IO* io; GV* gv; @@ -7800,11 +7840,14 @@ Perl_sv_2io(pTHX_ SV *sv) io = (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 = (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"); @@ -7833,7 +7876,7 @@ The flags in C are passed to sv_fetchsv. */ CV * -Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) +Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) { dVAR; GV *gv = NULL; @@ -7857,15 +7900,18 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) *gvp = NULL; return NULL; case SVt_PVGV: - gv = (GV*)sv; - *gvp = gv; - *st = GvESTASH(gv); - goto fix_gv; + if (isGV_with_GP(sv)) { + gv = (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); @@ -7875,22 +7921,24 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) *st = CvSTASH(cv); return cv; } - else if(isGV(sv)) + else if(isGV_with_GP(sv)) gv = (GV*)sv; else Perl_croak(aTHX_ "Not a subroutine reference"); } - else if (isGV(sv)) + else if (isGV_with_GP(sv)) { + SvGETMAGIC(sv); gv = (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; } @@ -7910,7 +7958,7 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) LEAVE; if (!GvCVu(gv)) Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"", - SVfARG(sv)); + SVfARG(SvOK(sv) ? sv : &PL_sv_no)); } return GvCVu(gv); } @@ -7927,7 +7975,7 @@ instead use an in-line version. */ I32 -Perl_sv_true(pTHX_ register SV *sv) +Perl_sv_true(pTHX_ register SV *const sv) { if (!sv) return 0; @@ -7972,7 +8020,7 @@ C and C */ char * -Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) +Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) { dVAR; @@ -8033,7 +8081,7 @@ The backend for the C macro. Always use the macro instead. */ char * -Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) +Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp) { PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE; @@ -8052,7 +8100,7 @@ The backend for the C macro. Always use the macro instead. */ char * -Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp) +Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp) { PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE; @@ -8071,7 +8119,7 @@ Returns a string describing what the SV is a reference to. */ const char * -Perl_sv_reftype(pTHX_ const SV *sv, int ob) +Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) { PERL_ARGS_ASSERT_SV_REFTYPE; @@ -8105,7 +8153,8 @@ Perl_sv_reftype(pTHX_ const SV *sv, 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"; @@ -8150,7 +8199,7 @@ an inheritance relationship. */ int -Perl_sv_isa(pTHX_ SV *sv, const char *name) +Perl_sv_isa(pTHX_ SV *sv, const char *const name) { const char *hvname; @@ -8183,7 +8232,7 @@ reference count is 1. */ SV* -Perl_newSVrv(pTHX_ SV *rv, const char *classname) +Perl_newSVrv(pTHX_ SV *const rv, const char *const classname) { dVAR; SV *sv; @@ -8239,7 +8288,7 @@ Note that C copies the string while this copies the pointer. */ SV* -Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv) +Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv) { dVAR; @@ -8267,7 +8316,7 @@ will have a reference count of 1, and the RV will be returned. */ SV* -Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv) +Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv) { PERL_ARGS_ASSERT_SV_SETREF_IV; @@ -8288,7 +8337,7 @@ will have a reference count of 1, and the RV will be returned. */ SV* -Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv) +Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv) { PERL_ARGS_ASSERT_SV_SETREF_UV; @@ -8309,7 +8358,7 @@ will have a reference count of 1, and the RV will be returned. */ SV* -Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv) +Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv) { PERL_ARGS_ASSERT_SV_SETREF_NV; @@ -8333,7 +8382,8 @@ Note that C copies the pointer while this copies the string. */ SV* -Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n) +Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname, + const char *const pv, const STRLEN n) { PERL_ARGS_ASSERT_SV_SETREF_PVN; @@ -8352,7 +8402,7 @@ of the SV is unaffected. */ SV* -Perl_sv_bless(pTHX_ SV *sv, HV *stash) +Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) { dVAR; SV *tmpRef; @@ -8397,7 +8447,7 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) */ STATIC void -S_sv_unglob(pTHX_ SV *sv) +S_sv_unglob(pTHX_ SV *const sv) { dVAR; void *xpvmg; @@ -8454,7 +8504,7 @@ See C. */ void -Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags) +Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags) { SV* const target = SvRV(ref); @@ -8484,7 +8534,7 @@ Untaint an SV. Use C instead. */ void -Perl_sv_untaint(pTHX_ SV *sv) +Perl_sv_untaint(pTHX_ SV *const sv) { PERL_ARGS_ASSERT_SV_UNTAINT; @@ -8503,7 +8553,7 @@ Test an SV for taintedness. Use C instead. */ bool -Perl_sv_tainted(pTHX_ SV *sv) +Perl_sv_tainted(pTHX_ SV *const sv) { PERL_ARGS_ASSERT_SV_TAINTED; @@ -8525,7 +8575,7 @@ Does not handle 'set' magic. See C. */ void -Perl_sv_setpviv(pTHX_ SV *sv, IV iv) +Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv) { char buf[TYPE_CHARS(UV)]; char *ebuf; @@ -8545,7 +8595,7 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) +Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv) { PERL_ARGS_ASSERT_SV_SETPVIV_MG; @@ -8561,7 +8611,7 @@ Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) */ void -Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...) +Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...) { dTHX; va_list args; @@ -8579,7 +8629,7 @@ Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...) */ void -Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...) +Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...) { dTHX; va_list args; @@ -8602,7 +8652,7 @@ appending it. Does not handle 'set' magic. See C. */ void -Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...) +Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...) { va_list args; @@ -8625,7 +8675,7 @@ Usually used via its frontend C. */ void -Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args) +Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args) { PERL_ARGS_ASSERT_SV_VSETPVF; @@ -8641,7 +8691,7 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...) +Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...) { va_list args; @@ -8663,7 +8713,7 @@ Usually used via its frontend C. */ void -Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) +Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args) { PERL_ARGS_ASSERT_SV_VSETPVF_MG; @@ -8679,7 +8729,7 @@ Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) */ void -Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...) +Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...) { dTHX; va_list args; @@ -8697,7 +8747,7 @@ Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...) */ void -Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...) +Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...) { dTHX; va_list args; @@ -8724,7 +8774,7 @@ valid UTF-8; if the original SV was bytes, the pattern should be too. =cut */ void -Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...) +Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...) { va_list args; @@ -8747,7 +8797,7 @@ Usually used via its frontend C. */ void -Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args) +Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args) { PERL_ARGS_ASSERT_SV_VCATPVF; @@ -8763,7 +8813,7 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...) +Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...) { va_list args; @@ -8785,7 +8835,7 @@ Usually used via its frontend C. */ void -Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) +Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args) { PERL_ARGS_ASSERT_SV_VCATPVF_MG; @@ -8805,7 +8855,8 @@ Usually used via one of its frontends C and C. */ void -Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted) +Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, + va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted) { PERL_ARGS_ASSERT_SV_VSETPVFN; @@ -8814,7 +8865,7 @@ Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } STATIC I32 -S_expect_number(pTHX_ char** pattern) +S_expect_number(pTHX_ char **const pattern) { dVAR; I32 var = 0; @@ -8837,7 +8888,7 @@ S_expect_number(pTHX_ char** pattern) } STATIC char * -S_F0convert(NV nv, char *endbuf, STRLEN *len) +S_F0convert(NV nv, char *const endbuf, STRLEN *const len) { const int neg = nv < 0; UV uv; @@ -8887,7 +8938,8 @@ Usually used via one of its frontends C and C. /* XXX maybe_tainted is never assigned to, so the doc above is lying. */ void -Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted) +Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, + va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted) { dVAR; char *p; @@ -9996,7 +10048,7 @@ ptr_table_* functions. /* clone a parser */ yy_parser * -Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param) +Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) { yy_parser *parser; @@ -10115,7 +10167,7 @@ Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param) /* duplicate a file handle */ PerlIO * -Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param) +Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param) { PerlIO *ret; @@ -10139,7 +10191,7 @@ Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param) /* duplicate a directory handle */ DIR * -Perl_dirp_dup(pTHX_ DIR *dp) +Perl_dirp_dup(pTHX_ DIR *const dp) { PERL_UNUSED_CONTEXT; if (!dp) @@ -10151,7 +10203,7 @@ Perl_dirp_dup(pTHX_ DIR *dp) /* duplicate a typeglob */ GP * -Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param) +Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param) { GP *ret; @@ -10186,7 +10238,7 @@ Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param) /* duplicate a chain of magic */ MAGIC * -Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) +Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param) { MAGIC *mgprev = (MAGIC*)NULL; MAGIC *mgret; @@ -10285,7 +10337,7 @@ Perl_ptr_table_new(pTHX) /* map an existing pointer using a table */ STATIC PTR_TBL_ENT_t * -S_ptr_table_find(PTR_TBL_t *tbl, const void *sv) +S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv) { PTR_TBL_ENT_t *tblent; const UV hash = PTR_TABLE_HASH(sv); @@ -10301,7 +10353,7 @@ S_ptr_table_find(PTR_TBL_t *tbl, const void *sv) } void * -Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv) +Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv) { PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv); @@ -10314,7 +10366,7 @@ Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv) /* add a new entry to a pointer-mapping table */ void -Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv) +Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv) { PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv); @@ -10341,7 +10393,7 @@ Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv) /* double the hash bucket size of an existing ptr table */ void -Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) +Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl) { PTR_TBL_ENT_t **ary = tbl->tbl_ary; const UV oldsize = tbl->tbl_max + 1; @@ -10376,7 +10428,7 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) /* remove all the entries from a ptr table */ void -Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl) +Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl) { if (tbl && tbl->tbl_items) { register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary; @@ -10399,7 +10451,7 @@ Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl) /* clear and free a ptr table */ void -Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl) +Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl) { if (!tbl) { return; @@ -10412,7 +10464,7 @@ Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl) #if defined(USE_ITHREADS) void -Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param) +Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param) { PERL_ARGS_ASSERT_RVPV_DUP; @@ -10460,7 +10512,7 @@ Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param) /* duplicate an SV of any type (including AV, HV etc) */ SV * -Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) +Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) { dVAR; SV *dstr; @@ -12301,8 +12353,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; } @@ -12560,6 +12614,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) @@ -12569,8 +12624,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: @@ -12582,6 +12710,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))