X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=9b23592845582152882bf975ab44c58d2e7d39de;hb=597c4554ca87aa4325a00c70a0fbb22acbfcfa07;hp=d0f9edb477f5f6642b18f873477481267bb2525c;hpb=7918f24d20384771923d344a382e1d16d9552018;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index d0f9edb..9b23592 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; @@ -407,7 +406,7 @@ S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask) /* called by sv_report_used() for each live SV */ static void -do_report_used(pTHX_ SV *sv) +do_report_used(pTHX_ SV *const sv) { if (SvTYPE(sv) != SVTYPEMASK) { PerlIO_printf(Perl_debug_log, "****\n"); @@ -464,7 +463,7 @@ do_clean_objs(pTHX_ SV *const ref) #ifndef DISABLE_DESTRUCTOR_KLUDGE static void -do_clean_named_objs(pTHX_ SV *sv) +do_clean_named_objs(pTHX_ SV *const sv) { dVAR; assert(SvTYPE(sv) == SVt_PVGV); @@ -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); @@ -1045,6 +1048,7 @@ S_more_bodies (pTHX_ const svtype sv_type) const size_t body_size = bdp->body_size; char *start; const char *end; + const size_t arena_size = Perl_malloc_good_size(bdp->arena_size); #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) static bool done_sanity_check; @@ -1062,20 +1066,28 @@ S_more_bodies (pTHX_ const svtype sv_type) assert(bdp->arena_size); - start = (char*) Perl_get_arena(aTHX_ bdp->arena_size, sv_type); + start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type); - end = start + bdp->arena_size - body_size; + end = start + arena_size - 2 * body_size; /* computed count doesnt reflect the 1st slot reservation */ +#if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE) + DEBUG_m(PerlIO_printf(Perl_debug_log, + "arena %p end %p arena-size %d (from %d) type %d " + "size %d ct %d\n", + (void*)start, (void*)end, (int)arena_size, + (int)bdp->arena_size, sv_type, (int)body_size, + (int)arena_size / (int)body_size)); +#else DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %p end %p arena-size %d type %d size %d ct %d\n", (void*)start, (void*)end, (int)bdp->arena_size, sv_type, (int)body_size, (int)bdp->arena_size / (int)body_size)); - +#endif *root = (void *)start; - while (start < end) { + while (start <= end) { char * const next = start + body_size; *(void**) start = (void *)next; start = next; @@ -1479,15 +1491,10 @@ Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen) s = SvPVX_mutable(sv); if (newlen > SvLEN(sv)) { /* need more room? */ +#ifndef Perl_safesysmalloc_size newlen = PERL_STRLEN_ROUNDUP(newlen); - if (SvLEN(sv) && s) { -#ifdef MYMALLOC - const STRLEN l = malloced_size((void*)SvPVX_const(sv)); - if (newlen <= l) { - SvLEN_set(sv, l); - return s; - } else #endif + if (SvLEN(sv) && s) { s = (char*)saferealloc(s, newlen); } else { @@ -1497,7 +1504,14 @@ Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen) } } SvPV_set(sv, s); +#ifdef Perl_safesysmalloc_size + /* Do this here, do it once, do it right, and then we will never get + called back into sv_grow() unless there really is some growing + needed. */ + SvLEN_set(sv, Perl_safesysmalloc_size(s)); +#else SvLEN_set(sv, newlen); +#endif } return s; } @@ -3016,7 +3030,7 @@ Usually accessed via the C macro. */ char * -Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) +Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp) { PERL_ARGS_ASSERT_SV_2PVUTF8; @@ -3035,7 +3049,7 @@ sv_true() or its macro equivalent. */ bool -Perl_sv_2bool(pTHX_ register SV *sv) +Perl_sv_2bool(pTHX_ register SV *const sv) { dVAR; @@ -3106,7 +3120,7 @@ use the Encode extension for that. */ STRLEN -Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) +Perl_sv_utf8_upgrade_flags(pTHX_ register SV *const sv, const I32 flags) { dVAR; @@ -3179,7 +3193,7 @@ use the Encode extension for that. */ bool -Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) +Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok) { dVAR; @@ -3222,7 +3236,7 @@ flag off so that it looks like octets again. */ void -Perl_sv_utf8_encode(pTHX_ register SV *sv) +Perl_sv_utf8_encode(pTHX_ register SV *const sv) { PERL_ARGS_ASSERT_SV_UTF8_ENCODE; @@ -3249,7 +3263,7 @@ Scans PV for validity and returns false if the PV is invalid UTF-8. */ bool -Perl_sv_utf8_decode(pTHX_ register SV *sv) +Perl_sv_utf8_decode(pTHX_ register SV *const sv) { PERL_ARGS_ASSERT_SV_UTF8_DECODE; @@ -3317,7 +3331,7 @@ copy-ish functions and macros use this underneath. */ static void -S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) +S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) { I32 mro_changes = 0; /* 1 = method, 2 = isa */ @@ -3394,7 +3408,7 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) } static void -S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) +S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) { SV * const sref = SvREFCNT_inc(SvRV(sstr)); SV *dref = NULL; @@ -3507,7 +3521,7 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) } void -Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) +Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) { dVAR; register U32 sflags; @@ -3538,7 +3552,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, 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 */ @@ -3703,8 +3716,10 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, 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) { @@ -3944,7 +3959,7 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr) +Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr) { PERL_ARGS_ASSERT_SV_SETSV_MG; @@ -4034,7 +4049,7 @@ undefined. Does not handle 'set' magic. See C. */ void -Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) +Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len) { dVAR; register char *dptr; @@ -4071,7 +4086,7 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) +Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len) { PERL_ARGS_ASSERT_SV_SETPVN_MG; @@ -4089,7 +4104,7 @@ handle 'set' magic. See C. */ void -Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr) +Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr) { dVAR; register STRLEN len; @@ -4120,7 +4135,7 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr) +Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr) { PERL_ARGS_ASSERT_SV_SETPV_MG; @@ -4149,7 +4164,7 @@ C, and already meets the requirements for storing in C) */ void -Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) +Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags) { dVAR; STRLEN allocate; @@ -4173,7 +4188,12 @@ Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) #endif allocate = (flags & SV_HAS_TRAILING_NUL) - ? len + 1: PERL_STRLEN_ROUNDUP(len + 1); + ? len + 1 : +#ifdef Perl_safesysmalloc_size + len + 1; +#else + PERL_STRLEN_ROUNDUP(len + 1); +#endif if (flags & SV_HAS_TRAILING_NUL) { /* It's long enough - do nothing. Specfically Perl_newCONSTSUB is relying on this. */ @@ -4189,9 +4209,13 @@ Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) ptr = (char*) saferealloc (ptr, allocate); #endif } - SvPV_set(sv, ptr); - SvCUR_set(sv, len); +#ifdef Perl_safesysmalloc_size + SvLEN_set(sv, Perl_safesysmalloc_size(ptr)); +#else SvLEN_set(sv, allocate); +#endif + SvCUR_set(sv, len); + SvPV_set(sv, ptr); if (!(flags & SV_HAS_TRAILING_NUL)) { ptr[len] = '\0'; } @@ -4256,7 +4280,7 @@ with flags set to 0. */ void -Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) +Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) { dVAR; @@ -4345,7 +4369,7 @@ refer to the same chunk of data. */ void -Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) +Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr) { STRLEN delta; STRLEN old_delta; @@ -4431,7 +4455,7 @@ in terms of this function. */ void -Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags) +Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags) { dVAR; STRLEN dlen; @@ -4468,7 +4492,7 @@ and C are implemented in terms of this function. =cut */ void -Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) +Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags) { dVAR; @@ -4520,7 +4544,7 @@ valid UTF-8. Handles 'get' magic, but not 'set' magic. See C. =cut */ void -Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr) +Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr) { dVAR; register STRLEN len; @@ -4551,7 +4575,7 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr) +Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr) { PERL_ARGS_ASSERT_SV_CATPV_MG; @@ -4577,7 +4601,7 @@ modules supporting older perls. */ SV * -Perl_newSV(pTHX_ STRLEN len) +Perl_newSV(pTHX_ const STRLEN len) { dVAR; register SV *sv; @@ -4609,8 +4633,8 @@ to contain an C and is stored as-is with its REFCNT incremented. =cut */ MAGIC * -Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, - const char* name, I32 namlen) +Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, + const MGVTBL *const vtable, const char *const name, const I32 namlen) { dVAR; MAGIC* mg; @@ -4694,7 +4718,8 @@ to add more than one instance of the same 'how'. */ void -Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen) +Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, + const char *const name, const I32 namlen) { dVAR; const MGVTBL *vtable; @@ -4881,7 +4906,7 @@ Removes all magic of type C from an SV. */ int -Perl_sv_unmagic(pTHX_ SV *sv, int type) +Perl_sv_unmagic(pTHX_ SV *const sv, const int type) { MAGIC* mg; MAGIC** mgp; @@ -4934,7 +4959,7 @@ called after the RV is cleared. */ SV * -Perl_sv_rvweaken(pTHX_ SV *sv) +Perl_sv_rvweaken(pTHX_ SV *const sv) { SV *tsv; @@ -4961,7 +4986,7 @@ Perl_sv_rvweaken(pTHX_ SV *sv) */ void -Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) +Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) { dVAR; AV *av; @@ -5017,7 +5042,7 @@ Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) */ STATIC void -S_sv_del_backref(pTHX_ SV *tsv, SV *sv) +S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv) { dVAR; AV *av = NULL; @@ -5069,7 +5094,7 @@ S_sv_del_backref(pTHX_ SV *tsv, SV *sv) } int -Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av) +Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av) { SV **svp = AvARRAY(av); @@ -5115,13 +5140,17 @@ Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *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 *bigstr, STRLEN offset, STRLEN len, const char *little, 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; @@ -5131,11 +5160,11 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, 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); @@ -5218,7 +5247,7 @@ time you'll want to use C or one of its many macro front-ends. */ void -Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) +Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv) { dVAR; const U32 refcnt = SvREFCNT(sv); @@ -5300,7 +5329,7 @@ instead. */ void -Perl_sv_clear(pTHX_ register SV *sv) +Perl_sv_clear(pTHX_ register SV *const sv) { dVAR; const U32 type = SvTYPE(sv); @@ -5524,7 +5553,7 @@ instead. */ SV * -Perl_sv_newref(pTHX_ SV *sv) +Perl_sv_newref(pTHX_ SV *const sv) { PERL_UNUSED_CONTEXT; if (sv) @@ -5544,7 +5573,7 @@ Normally called via a wrapper macro C. */ void -Perl_sv_free(pTHX_ SV *sv) +Perl_sv_free(pTHX_ SV *const sv) { dVAR; if (!sv) @@ -5592,7 +5621,7 @@ Perl_sv_free(pTHX_ SV *sv) } void -Perl_sv_free2(pTHX_ SV *sv) +Perl_sv_free2(pTHX_ SV *const sv) { dVAR; @@ -5627,7 +5656,7 @@ coercion. See also C, which gives raw access to the xpv_cur slot. */ STRLEN -Perl_sv_len(pTHX_ register SV *sv) +Perl_sv_len(pTHX_ register SV *const sv) { STRLEN len; @@ -5660,7 +5689,7 @@ UTF-8 bytes as a single character. Handles magic and type coercion. */ STRLEN -Perl_sv_len_utf8(pTHX_ register SV *sv) +Perl_sv_len_utf8(pTHX_ register SV *const sv) { if (!sv) return 0; @@ -5734,7 +5763,7 @@ S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, the passed in UTF-8 offset. */ static STRLEN S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, - STRLEN uoffset, STRLEN uend) + const STRLEN uoffset, const STRLEN uend) { STRLEN backw = uend - uoffset; @@ -5764,8 +5793,8 @@ S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, will be used to reduce the amount of linear searching. The cache will be created if necessary, and the found value offered to it for update. */ static STRLEN -S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, - const U8 *const send, STRLEN uoffset, +S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start, + const U8 *const send, const STRLEN uoffset, STRLEN uoffset0, STRLEN boffset0) { STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */ @@ -5860,7 +5889,8 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **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; } @@ -5885,7 +5915,7 @@ type coercion. */ void -Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) +Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp) { const U8 *start; STRLEN len; @@ -5948,8 +5978,8 @@ Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* 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; @@ -6088,8 +6118,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; @@ -6127,7 +6157,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; @@ -6215,7 +6245,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); } /* @@ -6330,7 +6361,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; @@ -6412,7 +6443,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 @@ -6477,7 +6508,7 @@ settings. */ char * -Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) +Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp) { dVAR; MAGIC *mg; @@ -6494,11 +6525,6 @@ Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) Safefree(mg->mg_ptr); s = SvPV_const(sv, len); if ((xf = mem_collxfrm(s, len, &xlen))) { - if (SvREADONLY(sv)) { - SAVEFREEPV(xf); - *nxp = xlen; - return xf + sizeof(PL_collation_ix); - } if (! mg) { #ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(sv)) @@ -6540,7 +6566,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; @@ -6610,6 +6636,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. */ @@ -6621,7 +6650,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 @@ -6898,7 +6933,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; @@ -7062,7 +7097,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; @@ -7191,7 +7226,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; @@ -7248,7 +7283,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; @@ -7275,7 +7310,7 @@ and C. */ SV * -Perl_sv_2mortal(pTHX_ register SV *sv) +Perl_sv_2mortal(pTHX_ register SV *const sv) { dVAR; if (!sv) @@ -7299,7 +7334,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; @@ -7321,7 +7356,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; @@ -7342,7 +7377,7 @@ SV if the hek is NULL. */ SV * -Perl_newSVhek(pTHX_ const HEK *hek) +Perl_newSVhek(pTHX_ const HEK *const hek) { dVAR; if (!hek) { @@ -7458,7 +7493,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; @@ -7483,7 +7518,7 @@ C. */ SV * -Perl_newSVpvf(pTHX_ const char* pat, ...) +Perl_newSVpvf(pTHX_ const char *const pat, ...) { register SV *sv; va_list args; @@ -7499,7 +7534,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; @@ -7521,7 +7556,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; @@ -7541,7 +7576,7 @@ SV is set to 1. */ SV * -Perl_newSViv(pTHX_ IV i) +Perl_newSViv(pTHX_ const IV i) { dVAR; register SV *sv; @@ -7561,7 +7596,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; @@ -7581,7 +7616,7 @@ is set to 1. */ SV * -Perl_newSV_type(pTHX_ svtype type) +Perl_newSV_type(pTHX_ const svtype type) { register SV *sv; @@ -7600,7 +7635,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); @@ -7618,7 +7653,7 @@ Perl_newRV_noinc(pTHX_ SV *tmpRef) */ SV * -Perl_newRV(pTHX_ SV *sv) +Perl_newRV(pTHX_ SV *const sv) { dVAR; @@ -7637,7 +7672,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; @@ -7667,7 +7702,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]; @@ -7771,7 +7806,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; @@ -7816,7 +7851,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; @@ -7846,9 +7881,9 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) goto fix_gv; default: - SvGETMAGIC(sv); if (SvROK(sv)) { SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */ + SvGETMAGIC(sv); tryAMAGICunDEREF(to_cv); sv = SvRV(sv); @@ -7863,10 +7898,12 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) else Perl_croak(aTHX_ "Not a subroutine reference"); } - else if (isGV(sv)) + else if (isGV(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; @@ -7893,7 +7930,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); } @@ -7910,7 +7947,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; @@ -7955,7 +7992,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; @@ -8016,7 +8053,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; @@ -8035,7 +8072,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; @@ -8054,7 +8091,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; @@ -8133,7 +8170,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; @@ -8166,7 +8203,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; @@ -8222,7 +8259,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; @@ -8250,7 +8287,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; @@ -8271,7 +8308,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; @@ -8292,7 +8329,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; @@ -8316,7 +8353,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; @@ -8335,7 +8373,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; @@ -8380,7 +8418,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; @@ -8437,7 +8475,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); @@ -8467,7 +8505,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; @@ -8486,7 +8524,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; @@ -8508,7 +8546,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; @@ -8528,7 +8566,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; @@ -8544,7 +8582,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; @@ -8562,7 +8600,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; @@ -8585,7 +8623,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; @@ -8608,7 +8646,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; @@ -8624,7 +8662,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; @@ -8646,7 +8684,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; @@ -8662,7 +8700,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; @@ -8680,7 +8718,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; @@ -8707,7 +8745,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; @@ -8730,7 +8768,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; @@ -8746,7 +8784,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; @@ -8768,7 +8806,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; @@ -8788,7 +8826,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; @@ -8797,7 +8836,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; @@ -8820,7 +8859,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; @@ -8870,7 +8909,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; @@ -9979,7 +10019,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; @@ -10098,7 +10138,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; @@ -10122,7 +10162,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) @@ -10134,7 +10174,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; @@ -10169,7 +10209,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; @@ -10268,7 +10308,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); @@ -10284,7 +10324,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); @@ -10297,7 +10337,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); @@ -10324,7 +10364,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; @@ -10359,7 +10399,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; @@ -10382,7 +10422,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; @@ -10395,7 +10435,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; @@ -10443,7 +10483,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; @@ -11260,7 +11300,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) * so we know which stashes want their objects cloned */ static void -do_mark_cloneable_stash(pTHX_ SV *sv) +do_mark_cloneable_stash(pTHX_ SV *const sv) { const HEK * const hvname = HvNAME_HEK((HV*)sv); if (hvname) { @@ -12284,8 +12324,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; } @@ -12550,6 +12592,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) goto do_op2; + 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 */