X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/cbb1fbeae87953fd0cb732e37262675ddbb9ffdd..314d39ceeccf6c9ed18a761b1261137e0e8bdc75:/sv.c diff --git a/sv.c b/sv.c index cf42029..065a292 100644 --- a/sv.c +++ b/sv.c @@ -35,13 +35,13 @@ * lib/utf8.t lib/Unicode/Collate/t/index.t * --jhi */ -#define ASSERT_UTF8_CACHE(cache) \ +# define ASSERT_UTF8_CACHE(cache) \ STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \ assert((cache)[2] <= (cache)[3]); \ assert((cache)[3] <= (cache)[1]);} \ } STMT_END #else -#define ASSERT_UTF8_CACHE(cache) NOOP +# define ASSERT_UTF8_CACHE(cache) NOOP #endif #ifdef PERL_OLD_COPY_ON_WRITE @@ -678,6 +678,7 @@ Perl_sv_free_arenas(pTHX) void* Perl_get_arena(pTHX_ int arena_size) { + dVAR; struct arena_desc* adesc; struct arena_set *newroot, **aroot = (struct arena_set**) &PL_body_arenas; int curr; @@ -692,7 +693,7 @@ Perl_get_arena(pTHX_ int arena_size) newroot->set_size = ARENAS_PER_SET; newroot->next = *aroot; *aroot = newroot; - DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", *aroot)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)*aroot)); } /* ok, now have arena-set with at least 1 empty/available arena-desc */ @@ -1031,7 +1032,7 @@ static const struct body_details bodies_by_type[] = { #define new_NOARENAZ(details) \ my_safecalloc((details)->body_size + (details)->offset) -#ifdef DEBUGGING +#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) static bool done_sanity_check; #endif @@ -1047,7 +1048,9 @@ S_more_bodies (pTHX_ svtype sv_type) assert(bdp->arena_size); -#ifdef DEBUGGING +#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) + /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global + * variables like done_sanity_check. */ if (!done_sanity_check) { unsigned int i = SVt_LAST; @@ -1065,8 +1068,9 @@ S_more_bodies (pTHX_ svtype sv_type) /* computed count doesnt reflect the 1st slot reservation */ DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %p end %p arena-size %d type %d size %d ct %d\n", - start, end, bdp->arena_size, sv_type, body_size, - bdp->arena_size / body_size)); + start, end, + (int)bdp->arena_size, sv_type, (int)body_size, + (int)bdp->arena_size / (int)body_size)); *root = (void *)start; @@ -1118,12 +1122,12 @@ You generally want to use the C macro wrapper. See also C. */ void -Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type) +Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) { dVAR; void* old_body; void* new_body; - const U32 old_type = SvTYPE(sv); + const svtype old_type = SvTYPE(sv); const struct body_details *new_type_details; const struct body_details *const old_type_details = bodies_by_type + old_type; @@ -1494,6 +1498,7 @@ Perl_sv_setiv(pTHX_ register SV *sv, IV i) case SVt_PVIO: Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), OP_DESC(PL_op)); + default: NOOP; } (void)SvIOK_only(sv); /* validate number */ SvIV_set(sv, i); @@ -1594,6 +1599,7 @@ Perl_sv_setnv(pTHX_ register SV *sv, NV num) case SVt_PVIO: Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), OP_NAME(PL_op)); + default: NOOP; } SvNV_set(sv, num); (void)SvNOK_only(sv); /* validate number */ @@ -1717,8 +1723,29 @@ Perl_looks_like_number(pTHX_ SV *sv) return grok_number(sbegin, len, NULL); } +STATIC bool +S_glob_2number(pTHX_ GV * const gv) +{ + const U32 wasfake = SvFLAGS(gv) & SVf_FAKE; + SV *const buffer = sv_newmortal(); + + /* FAKE globs can get coerced, so need to turn this off temporarily if it + is on. */ + SvFAKE_off(gv); + gv_efullname3(buffer, gv, "*"); + SvFLAGS(gv) |= wasfake; + + /* We know that all GVs stringify to something that is not-a-number, + so no need to test that. */ + if (ckWARN(WARN_NUMERIC)) + not_a_number(buffer); + /* We just want something true to return, so that S_sv_2iuv_common + can tail call us and return true. */ + return TRUE; +} + STATIC char * -S_glob_2inpuv(pTHX_ GV *gv, STRLEN *len, bool want_number) +S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len) { const U32 wasfake = SvFLAGS(gv) & SVf_FAKE; SV *const buffer = sv_newmortal(); @@ -1729,17 +1756,11 @@ S_glob_2inpuv(pTHX_ GV *gv, STRLEN *len, bool want_number) gv_efullname3(buffer, gv, "*"); SvFLAGS(gv) |= wasfake; - if (want_number) { - /* We know that all GVs stringify to something that is not-a-number, - so no need to test that. */ - if (ckWARN(WARN_NUMERIC)) - not_a_number(buffer); - /* We just want something true to return, so that S_sv_2iuv_common - can tail call us and return true. */ - return (char *) 1; - } else { - return SvPV(buffer, *len); + assert(SvPOK(buffer)); + if (len) { + *len = SvCUR(buffer); } + return SvPVX(buffer); } /* Actually, ISO C leaves conversion of UV to IV undefined, but @@ -2050,7 +2071,7 @@ S_sv_2iuv_common(pTHX_ SV *sv) { if ((NV)(SvIVX(sv)) == SvNVX(sv)) { SvIOK_on(sv); } else { - /*EMPTY*/; /* Integer is imprecise. NOK, IOKp */ + NOOP; /* Integer is imprecise. NOK, IOKp */ } /* UV will not work better than IV */ } else { @@ -2065,7 +2086,7 @@ S_sv_2iuv_common(pTHX_ SV *sv) { if ((NV)(SvUVX(sv)) == SvNVX(sv)) { SvIOK_on(sv); } else { - /*EMPTY*/; /* Integer is imprecise. NOK, IOKp, is UV */ + NOOP; /* Integer is imprecise. NOK, IOKp, is UV */ } } SvIsUV_on(sv); @@ -2109,9 +2130,8 @@ S_sv_2iuv_common(pTHX_ SV *sv) { } } else { - if (isGV_with_GP(sv)) { - return (bool)PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE)); - } + if (isGV_with_GP(sv)) + return glob_2number((GV *)sv); if (!(SvFLAGS(sv) & SVs_PADTMP)) { if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) @@ -2461,7 +2481,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) } else { if (isGV_with_GP(sv)) { - glob_2inpuv((GV *)sv, NULL, TRUE); + glob_2number((GV *)sv); return 0.0; } @@ -2644,8 +2664,9 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) STRLEN len; if (SvIOKp(sv)) { - len = SvIsUV(sv) ? my_sprintf(tbuf,"%"UVuf, (UV)SvUVX(sv)) - : my_sprintf(tbuf,"%"IVdf, (IV)SvIVX(sv)); + len = SvIsUV(sv) + ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv)) + : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv)); } else { Gconvert(SvNVX(sv), NV_DIG, 0, tbuf); len = strlen(tbuf); @@ -2779,7 +2800,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) /* some Xenix systems wipe out errno here */ #ifdef apollo if (SvNVX(sv) == 0.0) - (void)strcpy(s,"0"); + my_strlcpy(s, "0", SvLEN(sv)); else #endif /*apollo*/ { @@ -2788,7 +2809,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) errno = olderrno; #ifdef FIXNEGATIVEZERO if (*s == '-' && s[1] == '0' && !s[2]) - strcpy(s,"0"); + my_strlcpy(s, "0", SvLEN(s)); #endif while (*s) s++; #ifdef hcx @@ -2797,9 +2818,8 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) #endif } else { - if (isGV_with_GP(sv)) { - return glob_2inpuv((GV *)sv, lp, FALSE); - } + if (isGV_with_GP(sv)) + return glob_2pv((GV *)sv, lp); if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); @@ -3080,13 +3100,13 @@ flag off so that it looks like octets again. void Perl_sv_utf8_encode(pTHX_ register SV *sv) { - (void) sv_utf8_upgrade(sv); if (SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); } if (SvREADONLY(sv)) { Perl_croak(aTHX_ PL_no_modify); } + (void) sv_utf8_upgrade(sv); SvUTF8_off(sv); } @@ -3283,7 +3303,7 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { it was a const and its value changed. */ if (CvCONST(cv) && CvCONST((CV*)sref) && cv_const_sv(cv) == cv_const_sv((CV*)sref)) { - /*EMPTY*/ + NOOP; /* They are 2 constant subroutines generated from the same constant. This probably means that they are really the "same" proxy subroutine @@ -3305,8 +3325,9 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { } } if (!intro) - cv_ckproto(cv, (GV*)dstr, - SvPOK(sref) ? SvPVX_const(sref) : NULL); + cv_ckproto_len(cv, (GV*)dstr, + SvPOK(sref) ? SvPVX_const(sref) : NULL, + SvPOK(sref) ? SvCUR(sref) : 0); } GvCVGEN(dstr) = 0; /* Switch off cacheness. */ GvASSUMECV_on(dstr); @@ -3331,7 +3352,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) dVAR; register U32 sflags; register int dtype; - register int stype; + register svtype stype; if (sstr == dstr) return; @@ -3466,7 +3487,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (stype == SVt_PVLV) SvUPGRADE(dstr, SVt_PVNV); else - SvUPGRADE(dstr, (U32)stype); + SvUPGRADE(dstr, (svtype)stype); } /* dstr may have been upgraded. */ @@ -3659,7 +3680,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8 |SVf_AMAGIC); { - const MAGIC * const smg = SvVOK(sstr); + const MAGIC * const smg = SvVSTRING_mg(sstr); if (smg) { sv_magic(dstr, NULL, PERL_MAGIC_vstring, smg->mg_ptr, smg->mg_len); @@ -3881,21 +3902,27 @@ Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr) } /* -=for apidoc sv_usepvn - -Tells an SV to use C to find its string value. Normally the string is -stored inside the SV but sv_usepvn allows the SV to use an outside string. -The C should point to memory that was allocated by C. The -string length, C, must be supplied. This function will realloc the -memory pointed to by C, so that pointer should not be freed or used by -the programmer after giving it to sv_usepvn. Does not handle 'set' magic. -See C. +=for apidoc sv_usepvn_flags + +Tells an SV to use C to find its string value. Normally the +string is stored inside the SV but sv_usepvn allows the SV to use an +outside string. The C should point to memory that was allocated +by C. The string length, C, must be supplied. By default +this function will realloc (i.e. move) the memory pointed to by C, +so that pointer should not be freed or used by the programmer after +giving it to sv_usepvn, and neither should any pointers from "behind" +that pointer (e.g. ptr + 1) be used. + +If C & SV_SMAGIC is true, will call SvSETMAGIC. If C & +SV_HAS_TRAILING_NUL is true, then C must be NUL, and the realloc +will be skipped. (i.e. the buffer is actually at least 1 byte longer than +C, and already meets the requirements for storing in C) =cut */ void -Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len) +Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) { dVAR; STRLEN allocate; @@ -3903,34 +3930,45 @@ Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len) SvUPGRADE(sv, SVt_PV); if (!ptr) { (void)SvOK_off(sv); + if (flags & SV_SMAGIC) + SvSETMAGIC(sv); return; } if (SvPVX_const(sv)) SvPV_free(sv); - allocate = PERL_STRLEN_ROUNDUP(len + 1); - ptr = saferealloc (ptr, allocate); +#ifdef DEBUGGING + if (flags & SV_HAS_TRAILING_NUL) + assert(ptr[len] == '\0'); +#endif + + allocate = (flags & SV_HAS_TRAILING_NUL) + ? len + 1: PERL_STRLEN_ROUNDUP(len + 1); + if (flags & SV_HAS_TRAILING_NUL) { + /* It's long enough - do nothing. + Specfically Perl_newCONSTSUB is relying on this. */ + } else { +#ifdef DEBUGGING + /* Force a move to shake out bugs in callers. */ + char *new_ptr = safemalloc(allocate); + Copy(ptr, new_ptr, len, char); + PoisonFree(ptr,len,char); + Safefree(ptr); + ptr = new_ptr; +#else + ptr = saferealloc (ptr, allocate); +#endif + } SvPV_set(sv, ptr); SvCUR_set(sv, len); SvLEN_set(sv, allocate); - *SvEND(sv) = '\0'; + if (!(flags & SV_HAS_TRAILING_NUL)) { + *SvEND(sv) = '\0'; + } (void)SvPOK_only_UTF8(sv); /* validate pointer */ SvTAINT(sv); -} - -/* -=for apidoc sv_usepvn_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - -void -Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len) -{ - sv_usepvn(sv,ptr,len); - SvSETMAGIC(sv); + if (flags & SV_SMAGIC) + SvSETMAGIC(sv); } #ifdef PERL_OLD_COPY_ON_WRITE @@ -4610,7 +4648,8 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type) Weaken a reference: set the C flag on this RV; give the referred-to SV C magic if it hasn't already; and push a back-reference to this RV onto the array of backreferences -associated with that magic. +associated with that magic. If the RV is magical, set magic will be +called after the RV is cleared. =cut */ @@ -4763,6 +4802,7 @@ Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av) SvRV_set(referrer, 0); SvOK_off(referrer); SvWEAKREF_off(referrer); + SvSETMAGIC(referrer); } else if (SvTYPE(referrer) == SVt_PVGV || SvTYPE(referrer) == SVt_PVLV) { /* You lookin' at me? */ @@ -5043,10 +5083,8 @@ Perl_sv_clear(pTHX_ register SV *sv) } } if (type >= SVt_PVMG) { - HV *ourstash; - if ((type == SVt_PVMG || type == SVt_PVGV) && - (ourstash = OURSTASH(sv))) { - SvREFCNT_dec(ourstash); + if ((type == SVt_PVMG || type == SVt_PVGV) && SvPAD_OUR(sv)) { + SvREFCNT_dec(OURSTASH(sv)); } else if (SvMAGIC(sv)) mg_free(sv); if (type == SVt_PVMG && SvPAD_TYPED(sv)) @@ -5315,7 +5353,7 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) PL_utf8cache = 0; Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVf " real %"UVf" for %"SVf, - (UV) ulen, (UV) real, sv); + (UV) ulen, (UV) real, (void*)sv); } } } @@ -5339,13 +5377,11 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) /* Walk forwards to find the byte corresponding to the passed in UTF-8 offset. */ static STRLEN -S_sv_pos_u2b_forwards(pTHX_ const U8 *const start, const U8 *const send, +S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, STRLEN uoffset) { const U8 *s = start; - PERL_UNUSED_CONTEXT; - while (s < send && uoffset--) s += UTF8SKIP(s); if (s > send) { @@ -5360,7 +5396,7 @@ S_sv_pos_u2b_forwards(pTHX_ const U8 *const start, const U8 *const send, whether to walk forwards or backwards to find the byte corresponding to the passed in UTF-8 offset. */ static STRLEN -S_sv_pos_u2b_midway(pTHX_ const U8 *const start, const U8 *send, +S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, STRLEN uoffset, STRLEN uend) { STRLEN backw = uend - uoffset; @@ -5368,7 +5404,7 @@ S_sv_pos_u2b_midway(pTHX_ const U8 *const start, const U8 *send, /* The assumption is that going forwards is twice the speed of going forward (that's where the 2 * backw comes from). (The real figure of course depends on the UTF-8 data.) */ - return S_sv_pos_u2b_forwards(aTHX_ start, send, uoffset); + return sv_pos_u2b_forwards(start, send, uoffset); } while (backw--) { @@ -5419,12 +5455,12 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, if ((*mgp)->mg_len != -1) { /* And we know the end too. */ boffset = boffset0 - + S_sv_pos_u2b_midway(aTHX_ start + boffset0, send, + + sv_pos_u2b_midway(start + boffset0, send, uoffset - uoffset0, (*mgp)->mg_len - uoffset0); } else { boffset = boffset0 - + S_sv_pos_u2b_forwards(aTHX_ start + boffset0, + + sv_pos_u2b_forwards(start + boffset0, send, uoffset - uoffset0); } } @@ -5437,13 +5473,13 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, } boffset = boffset0 - + S_sv_pos_u2b_midway(aTHX_ start + boffset0, + + sv_pos_u2b_midway(start + boffset0, start + cache[1], uoffset - uoffset0, cache[0] - uoffset0); } else { boffset = boffset0 - + S_sv_pos_u2b_midway(aTHX_ start + boffset0, + + sv_pos_u2b_midway(start + boffset0, start + cache[3], uoffset - uoffset0, cache[2] - uoffset0); @@ -5455,7 +5491,7 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, /* In fact, offset0 is either 0, or less than offset, so don't need to worry about the other possibility. */ boffset = boffset0 - + S_sv_pos_u2b_midway(aTHX_ start + boffset0, send, + + sv_pos_u2b_midway(start + boffset0, send, uoffset - uoffset0, (*mgp)->mg_len - uoffset0); found = TRUE; @@ -5464,7 +5500,7 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, if (!found || PL_utf8cache < 0) { const STRLEN real_boffset - = boffset0 + S_sv_pos_u2b_forwards(aTHX_ start + boffset0, + = boffset0 + sv_pos_u2b_forwards(start + boffset0, send, uoffset - uoffset0); if (found && PL_utf8cache < 0) { @@ -5475,7 +5511,7 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, PL_utf8cache = 0; Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVf " real %"UVf" for %"SVf, - (UV) boffset, (UV) real_boffset, sv); + (UV) boffset, (UV) real_boffset, (void*)sv); } } boffset = real_boffset; @@ -5519,16 +5555,16 @@ Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) STRLEN uoffset = (STRLEN) *offsetp; const U8 * const send = start + len; MAGIC *mg = NULL; - STRLEN boffset = S_sv_pos_u2b_cached(aTHX_ sv, &mg, start, send, + const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0); *offsetp = (I32) boffset; if (lenp) { /* Convert the relative offset to absolute. */ - STRLEN uoffset2 = uoffset + (STRLEN) *lenp; - STRLEN boffset2 - = S_sv_pos_u2b_cached(aTHX_ sv, &mg, start, send, uoffset2, + const STRLEN uoffset2 = uoffset + (STRLEN) *lenp; + const STRLEN boffset2 + = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2, uoffset, boffset) - boffset; *lenp = boffset2; @@ -5608,7 +5644,7 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8, SAVEI8(PL_utf8cache); PL_utf8cache = 0; Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVf - " real %"UVf" for %"SVf, (UV) utf8, (UV) realutf8, sv); + " real %"UVf" for %"SVf, (UV) utf8, (UV) realutf8, (void*)sv); } } @@ -5855,7 +5891,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) PL_utf8cache = 0; Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVf " real %"UVf" for %"SVf, - (UV) len, (UV) real_len, sv); + (UV) len, (UV) real_len, (void*)sv); } } len = real_len; @@ -6501,7 +6537,7 @@ screamer2: * * - jik 9/25/96 */ - if (!(cnt < sizeof(buf) && PerlIO_eof(fp))) + if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp))) goto screamer2; } @@ -6951,12 +6987,15 @@ Perl_newSVhek(pTHX_ const HEK *hek) SvUTF8_on (sv); Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */ return sv; - } else if (flags & HVhek_REHASH) { + } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) { /* We don't have a pointer to the hv, so we have to replicate the flag into every HEK. This hv is using custom a hasing algorithm. Hence we can't return a shared string scalar, as that would contain the (wrong) hash value, and might get passed - into an hv routine with a regular hash */ + into an hv routine with a regular hash. + Similarly, a hash that isn't using shared hash keys has to have + the flag in every key so that we know not to try to call + share_hek_kek on it. */ SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); if (HEK_UTF8(hek)) @@ -7338,7 +7377,7 @@ Perl_sv_2io(pTHX_ SV *sv) else io = 0; if (!io) - Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv); + Perl_croak(aTHX_ "Bad filehandle: %"SVf, (void*)sv); break; } return io; @@ -7430,7 +7469,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"\"", - sv); + (void*)sv); } return GvCVu(gv); } @@ -8984,18 +9023,19 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV integer: { char *ptr = ebuf + sizeof ebuf; + bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */ + zeros = 0; + switch (base) { unsigned dig; case 16: - if (!uv) - alt = FALSE; p = (char*)((c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef"); do { dig = uv & 15; *--ptr = p[dig]; } while (uv >>= 4); - if (alt) { + if (tempalt) { esignbuf[esignlen++] = '0'; esignbuf[esignlen++] = c; /* 'x' or 'X' */ } @@ -9009,13 +9049,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV *--ptr = '0'; break; case 2: - if (!uv) - alt = FALSE; do { dig = uv & 1; *--ptr = '0' + dig; } while (uv >>= 1); - if (alt) { + if (tempalt) { esignbuf[esignlen++] = '0'; esignbuf[esignlen++] = 'b'; } @@ -9235,8 +9273,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV * --jhi */ #if defined(HAS_LONG_DOUBLE) elen = ((intsize == 'q') - ? my_sprintf(PL_efloatbuf, ptr, nv) - : my_sprintf(PL_efloatbuf, ptr, (double)nv)); + ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv) + : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv)); #else elen = my_sprintf(PL_efloatbuf, ptr, nv); #endif @@ -9287,7 +9325,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV (UV)c & 0xFF); } else sv_catpvs(msg, "end of string"); - Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */ + Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, (void*)msg); /* yes, this is reentrant */ } /* output mangled stuff ... */ @@ -9307,27 +9345,29 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV continue; /* not "break" */ } - /* calculate width before utf8_upgrade changes it */ + if (is_utf8 != has_utf8) { + if (is_utf8) { + if (SvCUR(sv)) + sv_utf8_upgrade(sv); + } + else { + const STRLEN old_elen = elen; + SV * const nsv = sv_2mortal(newSVpvn(eptr, elen)); + sv_utf8_upgrade(nsv); + eptr = SvPVX_const(nsv); + elen = SvCUR(nsv); + + if (width) { /* fudge width (can't fudge elen) */ + width += elen - old_elen; + } + is_utf8 = TRUE; + } + } + have = esignlen + zeros + elen; if (have < zeros) Perl_croak_nocontext(PL_memory_wrap); - if (is_utf8 != has_utf8) { - if (is_utf8) { - if (SvCUR(sv)) - sv_utf8_upgrade(sv); - } - else { - SV * const nsv = sv_2mortal(newSVpvn(eptr, elen)); - sv_utf8_upgrade(nsv); - eptr = SvPVX_const(nsv); - elen = SvCUR(nsv); - } - SvGROW(sv, SvCUR(sv) + elen + 1); - p = SvEND(sv); - *p = '\0'; - } - need = (have > width ? have : width); gap = need - have; @@ -9508,6 +9548,17 @@ Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param) ((reg_trie_data*)d->data[i])->refcount++; OP_REFCNT_UNLOCK; break; + case 'T': + d->data[i] = r->data->data[i]; + OP_REFCNT_LOCK; + ((reg_ac_data*)d->data[i])->refcount++; + OP_REFCNT_UNLOCK; + /* Trie stclasses are readonly and can thus be shared + * without duplication. We free the stclass in pregfree + * when the corresponding reg_ac_data struct is freed. + */ + ret->regstclass= r->regstclass; + break; default: Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]); } @@ -9608,7 +9659,7 @@ Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param) ret->gp_cv = cv_dup_inc(gp->gp_cv, param); ret->gp_cvgen = gp->gp_cvgen; ret->gp_line = gp->gp_line; - ret->gp_file = gp->gp_file; /* points to COP.cop_file */ + ret->gp_file_hek = hek_dup(gp->gp_file_hek, param); return ret; } @@ -9959,7 +10010,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) case SVt_PVGV: if (GvUNIQUE((GV*)sstr)) { - /*EMPTY*/; /* Do sharing here, and fall through */ + NOOP; /* Do sharing here, and fall through */ } case SVt_PVIO: case SVt_PVFM: @@ -10004,9 +10055,8 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) missing by always going for the destination. FIXME - instrument and check that assumption */ if (sv_type >= SVt_PVMG) { - HV *ourstash; - if ((sv_type == SVt_PVMG) && (ourstash = OURSTASH(dstr))) { - OURSTASH_set(dstr, hv_dup_inc(ourstash, param)); + if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) { + OURSTASH_set(dstr, hv_dup_inc(OURSTASH(dstr), param)); } else if (SvMAGIC(dstr)) SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param)); if (SvSTASH(dstr)) @@ -10070,7 +10120,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) if (IoDIRP(dstr)) { IoDIRP(dstr) = dirp_dup(IoDIRP(dstr)); } else { - /*EMPTY*/; + NOOP; /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */ } } @@ -10107,55 +10157,49 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) } break; case SVt_PVHV: - { - HEK *hvname = NULL; - - if (HvARRAY((HV*)sstr)) { - STRLEN i = 0; - const bool sharekeys = !!HvSHAREKEYS(sstr); - XPVHV * const dxhv = (XPVHV*)SvANY(dstr); - XPVHV * const sxhv = (XPVHV*)SvANY(sstr); - char *darray; - Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) - + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), - char); - HvARRAY(dstr) = (HE**)darray; - while (i <= sxhv->xhv_max) { - const HE *source = HvARRAY(sstr)[i]; - HvARRAY(dstr)[i] = source - ? he_dup(source, sharekeys, param) : 0; - ++i; - } - if (SvOOK(sstr)) { - struct xpvhv_aux * const saux = HvAUX(sstr); - struct xpvhv_aux * const daux = HvAUX(dstr); - /* This flag isn't copied. */ - /* SvOOK_on(hv) attacks the IV flags. */ - SvFLAGS(dstr) |= SVf_OOK; - - hvname = saux->xhv_name; - daux->xhv_name - = hvname ? hek_dup(hvname, param) : hvname; - - daux->xhv_riter = saux->xhv_riter; - daux->xhv_eiter = saux->xhv_eiter - ? he_dup(saux->xhv_eiter, - (bool)!!HvSHAREKEYS(sstr), param) : 0; - daux->xhv_backreferences = saux->xhv_backreferences + if (HvARRAY((HV*)sstr)) { + STRLEN i = 0; + const bool sharekeys = !!HvSHAREKEYS(sstr); + XPVHV * const dxhv = (XPVHV*)SvANY(dstr); + XPVHV * const sxhv = (XPVHV*)SvANY(sstr); + char *darray; + Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) + + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), + char); + HvARRAY(dstr) = (HE**)darray; + while (i <= sxhv->xhv_max) { + const HE * const source = HvARRAY(sstr)[i]; + HvARRAY(dstr)[i] = source + ? he_dup(source, sharekeys, param) : 0; + ++i; + } + if (SvOOK(sstr)) { + HEK *hvname; + const struct xpvhv_aux * const saux = HvAUX(sstr); + struct xpvhv_aux * const daux = HvAUX(dstr); + /* This flag isn't copied. */ + /* SvOOK_on(hv) attacks the IV flags. */ + SvFLAGS(dstr) |= SVf_OOK; + + hvname = saux->xhv_name; + daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname; + + daux->xhv_riter = saux->xhv_riter; + daux->xhv_eiter = saux->xhv_eiter + ? he_dup(saux->xhv_eiter, + (bool)!!HvSHAREKEYS(sstr), param) : 0; + daux->xhv_backreferences = + saux->xhv_backreferences ? (AV*) SvREFCNT_inc( - sv_dup((SV*)saux-> - xhv_backreferences, - param)) + sv_dup((SV*)saux->xhv_backreferences, param)) : 0; - } + /* Record stashes for possible cloning in Perl_clone(). */ + if (hvname) + av_push(param->stashes, dstr); } - else { - SvPV_set(dstr, NULL); - } - /* Record stashes for possible cloning in Perl_clone(). */ - if(hvname) - av_push(param->stashes, dstr); } + else + SvPV_set(dstr, NULL); break; case SVt_PVCV: if (!(param->flags & CLONEf_COPY_STACKS)) { @@ -10241,6 +10285,8 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) ncx->blk_sub.hasargs = cx->blk_sub.hasargs; ncx->blk_sub.lval = cx->blk_sub.lval; ncx->blk_sub.retop = cx->blk_sub.retop; + ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, + cx->blk_sub.oldcomppad); break; case CXt_EVAL: ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval; @@ -10578,9 +10624,11 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) i = POPINT(ss,ix); TOPINT(nss,ix) = i; ptr = POPPTR(ss,ix); - HINTS_REFCNT_LOCK; - ((COP *)ptr)->cop_hints->refcounted_he_refcnt++; - HINTS_REFCNT_UNLOCK; + if (ptr) { + HINTS_REFCNT_LOCK; + ((struct refcounted_he *)ptr)->refcounted_he_refcnt++; + HINTS_REFCNT_UNLOCK; + } TOPPTR(nss,ix) = ptr; if (i & HINT_LOCALIZE_HH) { hv = (HV*)POPPTR(ss,ix); @@ -10629,8 +10677,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) = pv_dup(old_state->re_state_bostr); new_state->re_state_reginput = pv_dup(old_state->re_state_reginput); - new_state->re_state_regbol - = pv_dup(old_state->re_state_regbol); new_state->re_state_regeol = pv_dup(old_state->re_state_regeol); new_state->re_state_regstartp @@ -10642,8 +10688,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) new_state->re_state_reglastcloseparen = any_dup(old_state->re_state_reglastcloseparen, proto_perl); - new_state->re_state_regtill - = pv_dup(old_state->re_state_regtill); /* XXX This just has to be broken. The old save_re_context code did SAVEGENERICPV(PL_reg_start_tmp); PL_reg_start_tmp is char **. @@ -10657,14 +10701,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) /* I assume that it only ever "worked" because no-one called (pseudo)fork while the regexp engine had re-entered itself. */ - new_state->re_state_reg_call_cc - = any_dup(old_state->re_state_reg_call_cc, proto_perl); - new_state->re_state_reg_re - = any_dup(old_state->re_state_reg_re, proto_perl); - new_state->re_state_reg_ganch - = pv_dup(old_state->re_state_reg_ganch); - new_state->re_state_reg_sv - = sv_dup(old_state->re_state_reg_sv, param); #ifdef PERL_OLD_COPY_ON_WRITE new_state->re_state_nrs = sv_dup(old_state->re_state_nrs, param); @@ -10679,12 +10715,14 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) = pv_dup(old_state->re_state_reg_oldsaved); new_state->re_state_reg_poscache = pv_dup(old_state->re_state_reg_poscache); -#ifdef DEBUGGING new_state->re_state_reg_starttry = pv_dup(old_state->re_state_reg_starttry); -#endif break; } + case SAVEt_COMPILE_WARNINGS: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr); + break; default: Perl_croak(aTHX_ "panic: ss_dup inconsistency (%"IVdf")", (IV) i); } @@ -10904,7 +10942,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvREFCNT(&PL_sv_no) = (~(U32)0)/2; SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; - SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0)); + SvPV_set(&PL_sv_no, savepvn(PL_No, 0)); SvCUR_set(&PL_sv_no, 0); SvLEN_set(&PL_sv_no, 1); SvIV_set(&PL_sv_no, 0); @@ -10915,7 +10953,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; - SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1)); + SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1)); SvCUR_set(&PL_sv_yes, 1); SvLEN_set(&PL_sv_yes, 2); SvIV_set(&PL_sv_yes, 1); @@ -10938,13 +10976,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file); ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); - if (!specialWARN(PL_compiling.cop_warnings)) - PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param); - if (!specialCopIO(PL_compiling.cop_io)) - PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param); - if (PL_compiling.cop_hints) { + PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); + if (PL_compiling.cop_hints_hash) { HINTS_REFCNT_LOCK; - PL_compiling.cop_hints->refcounted_he_refcnt++; + PL_compiling.cop_hints_hash->refcounted_he_refcnt++; HINTS_REFCNT_UNLOCK; } PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl); @@ -11725,16 +11760,17 @@ STATIC I32 S_find_array_subscript(pTHX_ AV *av, SV* val) { dVAR; - SV** svp; - I32 i; if (!av || SvMAGICAL(av) || !AvARRAY(av) || (AvFILLp(av) > FUV_MAX_SEARCH_SIZE)) return -1; - svp = AvARRAY(av); - for (i=AvFILLp(av); i>=0; i--) { - if (svp[i] == val && svp[i] != &PL_sv_undef) - return i; + if (val != &PL_sv_undef) { + SV ** const svp = AvARRAY(av); + I32 i; + + for (i=AvFILLp(av); i>=0; i--) + if (svp[i] == val) + return i; } return -1; } @@ -11876,7 +11912,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) subscript_type = FUV_SUBSCRIPT_HASH; } else { - index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv); + index = find_array_subscript((AV*)sv, uninit_sv); if (index >= 0) subscript_type = FUV_SUBSCRIPT_ARRAY; } @@ -12090,13 +12126,14 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) * or are optimized away, then it's unambiguous */ o2 = NULL; for (kid=o; kid; kid = kid->op_sibling) { - if (kid && - ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) - || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) - || (kid->op_type == OP_PUSHMARK) + if (kid) { + const OPCODE type = kid->op_type; + if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid))) + || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) + || (type == OP_PUSHMARK) ) - ) continue; + } if (o2) { /* more than one found */ o2 = NULL; break;