X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=f918d5ab2722a1cf8a039135d858df3dde86a79b;hb=170c5524f26ec8d57d5b2a5413842df92809a613;hp=f3676541aaf8470a027c7e08b307a9ae8cd35a39;hpb=e4cd187473b5443b84bf0c23f377f8bd4a0a1424;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index f367654..f918d5a 100644 --- a/sv.c +++ b/sv.c @@ -520,7 +520,7 @@ do_clean_all(pTHX_ SV *sv) DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); SvFLAGS(sv) |= SVf_BREAK; if (PL_comppad == (AV*)sv) { - PL_comppad = Nullav; + PL_comppad = NULL; PL_curpad = Null(SV**); } SvREFCNT_dec(sv); @@ -640,8 +640,8 @@ Perl_sv_free_arenas(pTHX) STATIC void * S_more_bodies (pTHX_ size_t size, svtype sv_type) { - void **arena_root = &PL_body_arenaroots[sv_type]; - void **root = &PL_body_roots[sv_type]; + void ** const arena_root = &PL_body_arenaroots[sv_type]; + void ** const root = &PL_body_roots[sv_type]; char *start; const char *end; const size_t count = PERL_ARENA_SIZE / size; @@ -675,7 +675,7 @@ S_more_bodies (pTHX_ size_t size, svtype sv_type) #define new_body_inline(xpv, size, sv_type) \ STMT_START { \ - void **r3wt = &PL_body_roots[sv_type]; \ + void ** const r3wt = &PL_body_roots[sv_type]; \ LOCK_SV_MUTEX; \ xpv = *((void **)(r3wt)) \ ? *((void **)(r3wt)) : S_more_bodies(aTHX_ size, sv_type); \ @@ -704,7 +704,7 @@ S_new_body(pTHX_ size_t size, svtype sv_type) #define del_body(thing, root) \ STMT_START { \ - void **thing_copy = (void **)thing; \ + void ** const thing_copy = (void **)thing;\ LOCK_SV_MUTEX; \ *thing_copy = *root; \ *root = (void*)thing_copy; \ @@ -1413,9 +1413,9 @@ S_not_a_number(pTHX_ SV *sv) /* each *s can expand to 4 chars + "...\0", i.e. need room for 8 chars */ - const char *s, *end; - for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit; - s++) { + const char *s = SvPVX_const(sv); + const char * const end = s + SvCUR(sv); + for ( ; s < end && d < limit; s++ ) { int ch = *s & 0xFF; if (ch & 128 && !isPRINT_LC(ch)) { *d++ = 'M'; @@ -1888,18 +1888,37 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) if (SvNOKp(sv)) { return I_V(SvNVX(sv)); } - if (SvPOKp(sv) && SvLEN(sv)) - return asIV(sv); - if (!SvROK(sv)) { - if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); + if (SvPOKp(sv) && SvLEN(sv)) { + UV value; + const int numtype + = grok_number(SvPVX_const(sv), SvCUR(sv), &value); + + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + == IS_NUMBER_IN_UV) { + /* It's definitely an integer */ + if (numtype & IS_NUMBER_NEG) { + if (value < (UV)IV_MIN) + return -(IV)value; + } else { + if (value < (UV)IV_MAX) + return (IV)value; + } } - return 0; + if (!numtype) { + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } + return I_V(Atof(SvPVX_const(sv))); + } + if (SvROK(sv)) { + goto return_rok; } + assert(SvTYPE(sv) >= SVt_PVMG); + /* This falls through to the report_uninit inside S_sv_2iuv_common. */ } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { + return_rok: if (SvAMAGIC(sv)) { SV * const tmpstr=AMG_CALLun(sv,numer); if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { @@ -1948,23 +1967,39 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) return SvUVX(sv); if (SvNOKp(sv)) return U_V(SvNVX(sv)); - if (SvPOKp(sv) && SvLEN(sv)) - return asUV(sv); - if (!SvROK(sv)) { - if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); + if (SvPOKp(sv) && SvLEN(sv)) { + UV value; + const int numtype + = grok_number(SvPVX_const(sv), SvCUR(sv), &value); + + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + == IS_NUMBER_IN_UV) { + /* It's definitely an integer */ + if (!(numtype & IS_NUMBER_NEG)) + return value; } - return 0; + if (!numtype) { + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } + return U_V(Atof(SvPVX_const(sv))); + } + if (SvROK(sv)) { + goto return_rok; } + assert(SvTYPE(sv) >= SVt_PVMG); + /* This falls through to the report_uninit inside S_sv_2iuv_common. */ } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { - SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) - return SvUV(tmpstr); - return PTR2UV(SvRV(sv)); + return_rok: + if (SvAMAGIC(sv)) { + SV *const tmpstr = AMG_CALLun(sv,numer); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + return SvUV(tmpstr); + } + } + return PTR2UV(SvRV(sv)); } if (SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); @@ -2015,22 +2050,23 @@ Perl_sv_2nv(pTHX_ register SV *sv) return (NV)SvUVX(sv); else return (NV)SvIVX(sv); - } - if (!SvROK(sv)) { - if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - } - return (NV)0; - } - } - if (SvTHINKFIRST(sv)) { + } + if (SvROK(sv)) { + goto return_rok; + } + assert(SvTYPE(sv) >= SVt_PVMG); + /* This falls through to the report_uninit near the end of the + function. */ + } else if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { - SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) - return SvNV(tmpstr); - return PTR2NV(SvRV(sv)); + return_rok: + if (SvAMAGIC(sv)) { + SV *const tmpstr = AMG_CALLun(sv,numer); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + return SvNV(tmpstr); + } + } + return PTR2NV(SvRV(sv)); } if (SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); @@ -2042,10 +2078,8 @@ Perl_sv_2nv(pTHX_ register SV *sv) } } if (SvTYPE(sv) < SVt_NV) { - if (SvTYPE(sv) == SVt_IV) - sv_upgrade(sv, SVt_PVNV); - else - sv_upgrade(sv, SVt_NV); + /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */ + sv_upgrade(sv, SVt_NV); #ifdef USE_LONG_DOUBLE DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); @@ -2139,11 +2173,10 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvNVX(sv) < (NV)IV_MAX + 0.5) { if (SvIVX(sv) == I_V(nv)) { SvNOK_on(sv); - SvIOK_on(sv); } else { - SvIOK_on(sv); /* It had no "." so it must be integer. */ } + SvIOK_on(sv); } else { /* between IV_MAX and NV(UV_MAX). Could be slightly > UV_MAX */ @@ -2155,10 +2188,8 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (value == nv_as_uv && SvUVX(sv) != UV_MAX) { SvNOK_on(sv); - SvIOK_on(sv); - } else { - SvIOK_on(sv); } + SvIOK_on(sv); } } } @@ -2169,11 +2200,10 @@ Perl_sv_2nv(pTHX_ register SV *sv) else { if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); - if (SvTYPE(sv) < SVt_NV) - /* Typically the caller expects that sv_any is not NULL now. */ - /* XXX Ilya implies that this is a bug in callers that assume this - and ideally should be fixed. */ - sv_upgrade(sv, SVt_NV); + assert (SvTYPE(sv) >= SVt_NV); + /* Typically the caller expects that sv_any is not NULL now. */ + /* XXX Ilya implies that this is a bug in callers that assume this + and ideally should be fixed. */ return 0.0; } #if defined(USE_LONG_DOUBLE) @@ -2194,55 +2224,6 @@ Perl_sv_2nv(pTHX_ register SV *sv) return SvNVX(sv); } -/* asIV(): extract an integer from the string value of an SV. - * Caller must validate PVX */ - -STATIC IV -S_asIV(pTHX_ SV *sv) -{ - UV value; - const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); - - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == IS_NUMBER_IN_UV) { - /* It's definitely an integer */ - if (numtype & IS_NUMBER_NEG) { - if (value < (UV)IV_MIN) - return -(IV)value; - } else { - if (value < (UV)IV_MAX) - return (IV)value; - } - } - if (!numtype) { - if (ckWARN(WARN_NUMERIC)) - not_a_number(sv); - } - return I_V(Atof(SvPVX_const(sv))); -} - -/* asUV(): extract an unsigned integer from the string value of an SV - * Caller must validate PVX */ - -STATIC UV -S_asUV(pTHX_ SV *sv) -{ - UV value; - const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); - - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == IS_NUMBER_IN_UV) { - /* It's definitely an integer */ - if (!(numtype & IS_NUMBER_NEG)) - return value; - } - if (!numtype) { - if (ckWARN(WARN_NUMERIC)) - not_a_number(sv); - } - return U_V(Atof(SvPVX_const(sv))); -} - /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or * UV as a string towards the end of buf, and return pointers to start and * end of it. @@ -2281,7 +2262,7 @@ S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) static char * S_stringify_regexp(pTHX_ SV *sv, MAGIC *mg, STRLEN *lp) { - const regexp *re = (regexp *)mg->mg_obj; + const regexp * const re = (regexp *)mg->mg_obj; if (!mg->mg_ptr) { const char *fptr = "msix"; @@ -2289,7 +2270,7 @@ S_stringify_regexp(pTHX_ SV *sv, MAGIC *mg, STRLEN *lp) { char ch; int left = 0; int right = 4; - char need_newline = 0; + bool need_newline = 0; U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12); while((ch = *fptr++)) { @@ -2403,7 +2384,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */ /* Sneaky stuff here */ - SV *tsv = newSVpvn(tbuf, len); + SV * const tsv = newSVpvn(tbuf, len); sv_2mortal(tsv); if (lp) @@ -2429,44 +2410,43 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) return memcpy(s, tbuf, len + 1); } } - if (!SvROK(sv)) { - if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - } - if (lp) - *lp = 0; - return (char *)""; - } - } - if (SvTHINKFIRST(sv)) { + if (SvROK(sv)) { + goto return_rok; + } + assert(SvTYPE(sv) >= SVt_PVMG); + /* This falls through to the report_uninit near the end of the + function. */ + } else if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { - SV* tmpstr; - - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) && - (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - /* Unwrap this: */ - /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */ - - char *pv; - if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { - if (flags & SV_CONST_RETURN) { - pv = (char *) SvPVX_const(tmpstr); + return_rok: + if (SvAMAGIC(sv)) { + SV *const tmpstr = AMG_CALLun(sv,string); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + /* Unwrap this: */ + /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); + */ + + char *pv; + if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { + if (flags & SV_CONST_RETURN) { + pv = (char *) SvPVX_const(tmpstr); + } else { + pv = (flags & SV_MUTABLE_RETURN) + ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); + } + if (lp) + *lp = SvCUR(tmpstr); } else { - pv = (flags & SV_MUTABLE_RETURN) - ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); + pv = sv_2pv_flags(tmpstr, lp, flags); } - if (lp) - *lp = SvCUR(tmpstr); - } else { - pv = sv_2pv_flags(tmpstr, lp, flags); + if (SvUTF8(tmpstr)) + SvUTF8_on(sv); + else + SvUTF8_off(sv); + return pv; } - if (SvUTF8(tmpstr)) - SvUTF8_on(sv); - else - SvUTF8_off(sv); - return pv; - } else { + } + { SV *tsv; MAGIC *mg; const SV *const referent = (SV*)SvRV(sv); @@ -2562,7 +2542,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); if (lp) - *lp = 0; + *lp = 0; if (SvTYPE(sv) < SVt_PV) /* Typically the caller expects that sv_any is not NULL now. */ sv_upgrade(sv, SVt_PV); @@ -2750,25 +2730,23 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) * had a FLAG in SVs to signal if there are any hibit * chars in the PV. Given that there isn't such a flag * make the loop as fast as possible. */ - const U8 *s = (U8 *) SvPVX_const(sv); + const U8 * const s = (U8 *) SvPVX_const(sv); const U8 * const e = (U8 *) SvEND(sv); const U8 *t = s; - int hibit = 0; while (t < e) { const U8 ch = *t++; - if ((hibit = !NATIVE_IS_INVARIANT(ch))) + /* Check for hi bit */ + if (!NATIVE_IS_INVARIANT(ch)) { + STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */ + 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. */ break; - } - if (hibit) { - STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */ - 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. */ + } } /* Mark as UTF-8 even if no hibit - saves scanning loop */ SvUTF8_on(sv); @@ -3400,7 +3378,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvIV_set(dstr, SvIVX(sstr)); } if (SvVOK(sstr)) { - MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring); + const MAGIC * const smg = mg_find(sstr,PERL_MAGIC_vstring); sv_magic(dstr, NULL, PERL_MAGIC_vstring, smg->mg_ptr, smg->mg_len); SvRMAGICAL_on(dstr); @@ -3906,10 +3884,10 @@ and C are implemented in terms of this function. void Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) { - const char *spv; - STRLEN slen; if (ssv) { - if ((spv = SvPV_const(ssv, slen))) { + STRLEN slen; + const char *spv = SvPV_const(ssv, slen); + if (spv) { /* sutf8 and dutf8 were type bool, but under USE_ITHREADS, gcc version 2.95.2 20000220 (Debian GNU/Linux) for Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously @@ -3927,7 +3905,7 @@ Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) if (dutf8 != sutf8) { if (dutf8) { /* Not modifying source SV, so taking a temporary copy. */ - SV* csv = sv_2mortal(newSVpvn(spv, slen)); + SV* const csv = sv_2mortal(newSVpvn(spv, slen)); sv_utf8_upgrade(csv); spv = SvPV_const(csv, slen); @@ -5892,7 +5870,7 @@ thats_really_all_folks: screamer2: if (rslen) { - register const STDCHAR *bpe = buf + sizeof(buf); + register const STDCHAR * const bpe = buf + sizeof(buf); bp = buf; while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe) ; /* keep reading */ @@ -7283,7 +7261,7 @@ S_sv_unglob(pTHX_ SV *sv) gp_free((GV*)sv); if (GvSTASH(sv)) { sv_del_backref((SV*)GvSTASH(sv), sv); - GvSTASH(sv) = Nullhv; + GvSTASH(sv) = NULL; } sv_unmagic(sv, PERL_MAGIC_glob); Safefree(GvNAME(sv)); @@ -7639,8 +7617,13 @@ S_expect_number(pTHX_ char** pattern) case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': - while (isDIGIT(**pattern)) - var = var * 10 + (*(*pattern)++ - '0'); + var = *(*pattern)++ - '0'; + while (isDIGIT(**pattern)) { + I32 tmp = var * 10 + (*(*pattern)++ - '0'); + if (tmp < var) + Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn")); + var = tmp; + } } return var; } @@ -7982,31 +7965,48 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (vectorarg) { if (args) vecsv = va_arg(*args, SV*); - else - vecsv = (evix ? evix <= svmax : svix < svmax) ? - svargs[evix ? evix-1 : svix++] : &PL_sv_undef; + else if (evix) { + vecsv = (evix > 0 && evix <= svmax) + ? svargs[evix-1] : &PL_sv_undef; + } else { + vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef; + } dotstr = SvPV_const(vecsv, dotstrlen); + /* Keep the DO_UTF8 test *after* the SvPV call, else things go + bad with tied or overloaded values that return UTF8. */ if (DO_UTF8(vecsv)) is_utf8 = TRUE; + else if (has_utf8) { + vecsv = sv_mortalcopy(vecsv); + sv_utf8_upgrade(vecsv); + dotstr = SvPV_const(vecsv, dotstrlen); + is_utf8 = TRUE; + } } if (args) { VECTORIZE_ARGS } - else if (efix ? efix <= svmax : svix < svmax) { + else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) { vecsv = svargs[efix ? efix-1 : svix++]; vecstr = (U8*)SvPV_const(vecsv,veclen); vec_utf8 = DO_UTF8(vecsv); - /* if this is a version object, we need to return the - * stringified representation (which the SvPVX_const has - * already done for us), but not vectorize the args + + /* if this is a version object, we need to convert + * back into v-string notation and then let the + * vectorize happen normally */ - if ( *q == 'd' && sv_derived_from(vecsv,"version") ) - { - q++; /* skip past the rest of the %vd format */ - eptr = (const char *) vecstr; - elen = veclen; - vectorize=FALSE; - goto string; + if (sv_derived_from(vecsv, "version")) { + char *version = savesvpv(vecsv); + vecsv = sv_newmortal(); + /* scan_vstring is expected to be called during + * tokenization, so we need to fake up the end + * of the buffer for it + */ + PL_bufend = version + veclen; + scan_vstring(version, vecsv); + vecstr = (U8*)SvPV_const(vecsv, veclen); + vec_utf8 = DO_UTF8(vecsv); + Safefree(version); } } else { @@ -8105,12 +8105,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (*q == '%') { eptr = q++; elen = 1; + if (vectorize) { + c = '%'; + goto unknown; + } goto string; } - if (vectorize) - argsv = vecsv; - else if (!args) { + if (!vectorize && !args) { if (efix) { const I32 i = efix-1; argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef; @@ -8125,7 +8127,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* STRINGS */ case 'c': - uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv); + if (vectorize) + goto unknown; + uv = (args) ? va_arg(*args, int) : SvIVx(argsv); if ((uv > 255 || (!UNI_IS_INVARIANT(uv) && SvUTF8(sv))) && !IN_BYTES) { @@ -8141,7 +8145,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV goto string; case 's': - if (args && !vectorize) { + if (vectorize) + goto unknown; + if (args) { eptr = va_arg(*args, char*); if (eptr) #ifdef MACOS_TRADITIONAL @@ -8172,7 +8178,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } string: - vectorize = FALSE; if (has_precis && elen > precis) elen = precis; break; @@ -8387,6 +8392,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'e': case 'E': case 'f': case 'g': case 'G': + if (vectorize) + goto unknown; /* This is evil, but floating point is even more evil */ @@ -8419,7 +8426,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } /* now we need (long double) if intsize == 'q', else (double) */ - nv = (args && !vectorize) ? + nv = (args) ? #if LONG_DOUBLESIZE > DOUBLESIZE intsize == 'q' ? va_arg(*args, long double) : @@ -8430,7 +8437,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV : SvNVx(argsv); need = 0; - vectorize = FALSE; if (c != 'e' && c != 'E') { i = PERL_INT_MIN; /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this @@ -8588,8 +8594,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* SPECIAL */ case 'n': + if (vectorize) + goto unknown; i = SvCUR(sv) - origlen; - if (args && !vectorize) { + if (args) { switch (intsize) { case 'h': *(va_arg(*args, short*)) = i; break; default: *(va_arg(*args, int*)) = i; break; @@ -8602,7 +8610,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } else sv_setuv_mg(argsv, (UV)i); - vectorize = FALSE; continue; /* not "break" */ /* UNKNOWN */ @@ -9031,11 +9038,8 @@ Perl_ptr_table_new(pTHX) return tbl; } -#if (PTRSIZE == 8) -# define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3) -#else -# define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2) -#endif +#define PTR_TABLE_HASH(ptr) \ + ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) /* we use the PTE_SVSLOT 'reservation' made above, both here (in the @@ -9127,34 +9131,22 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) void Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl) { - register PTR_TBL_ENT_t **array; - register PTR_TBL_ENT_t *entry; - UV riter = 0; - UV max; + if (tbl && tbl->tbl_items) { + register PTR_TBL_ENT_t **array = tbl->tbl_ary; + UV riter = tbl->tbl_max; - if (!tbl || !tbl->tbl_items) { - return; - } + do { + PTR_TBL_ENT_t *entry = array[riter]; - array = tbl->tbl_ary; - entry = array[0]; - max = tbl->tbl_max; + while (entry) { + PTR_TBL_ENT_t * const oentry = entry; + entry = entry->next; + del_pte(oentry); + } + } while (riter--); - for (;;) { - if (entry) { - PTR_TBL_ENT_t *oentry = entry; - entry = entry->next; - del_pte(oentry); - } - if (!entry) { - if (++riter > max) { - break; - } - entry = array[riter]; - } + tbl->tbl_items = 0; } - - tbl->tbl_items = 0; } /* clear and free a ptr table */ @@ -9322,9 +9314,9 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) case SVt_PVNV: case SVt_PVIV: case SVt_PV: - assert(sv_type_details->copy); + assert(sv_type_details->size); if (sv_type_details->arena) { - new_body_inline(new_body, sv_type_details->copy, sv_type); + new_body_inline(new_body, sv_type_details->size, sv_type); new_body = (void*)((char*)new_body - sv_type_details->offset); } else { @@ -9462,8 +9454,8 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) ++i; } if (SvOOK(sstr)) { - struct xpvhv_aux *saux = HvAUX(sstr); - struct xpvhv_aux *daux = HvAUX(dstr); + 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; @@ -9563,7 +9555,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) : cv_dup(cx->blk_sub.cv,param)); ncx->blk_sub.argarray = (cx->blk_sub.hasargs ? av_dup_inc(cx->blk_sub.argarray, param) - : Nullav); + : NULL); ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param); ncx->blk_sub.olddepth = cx->blk_sub.olddepth; ncx->blk_sub.hasargs = cx->blk_sub.hasargs; @@ -10588,7 +10580,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif /* swatch cache */ - PL_last_swash_hv = Nullhv; /* reinits on demand */ + PL_last_swash_hv = NULL; /* reinits on demand */ PL_last_swash_klen = 0; PL_last_swash_key[0]= '\0'; PL_last_swash_tmps = (U8*)NULL; @@ -11240,7 +11232,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) break; } else { - SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE); + SV * const * const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE); if (!svp || *svp != uninit_sv) break; } @@ -11251,7 +11243,6 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) else return varname(gv, '@', o->op_targ, Nullsv, SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY); - ; } else { /* index is an expression;