X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/ee022d6189798e4ee330607bb256ea600f01a25d..32128a7f27904b0ac4cc16cc0c5b0f5238cf60fd:/sv.c diff --git a/sv.c b/sv.c index 11db1bb..231215e 100644 --- a/sv.c +++ b/sv.c @@ -1462,9 +1462,7 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); IoPAGE_LEN(sv) = 60; } - if (UNLIKELY(new_type == SVt_REGEXP)) - sv->sv_u.svu_rx = (regexp *)new_body; - else if (old_type < SVt_PV) { + if (old_type < SVt_PV) { /* referent will be NULL unless the old type was SVt_IV emulating SVt_RV */ sv->sv_u.svu_rv = referent; @@ -1647,6 +1645,7 @@ Perl_sv_setiv(pTHX_ SV *const sv, const IV i) case SVt_PVGV: if (!isGV_with_GP(sv)) break; + /* FALLTHROUGH */ case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: @@ -1760,6 +1759,7 @@ Perl_sv_setnv(pTHX_ SV *const sv, const NV num) case SVt_PVGV: if (!isGV_with_GP(sv)) break; + /* FALLTHROUGH */ case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: @@ -2463,7 +2463,7 @@ Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) Regexps have no SvIVX and SvNVX fields. */ - assert(isREGEXP(sv) || SvPOKp(sv)); + assert(SvPOKp(sv)); { UV value; const char * const ptr = @@ -2551,7 +2551,7 @@ Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) /* FBMs use the space for SvIVX and SvNVX for other purposes, and use the same flag bit as SVf_IVisUV, so must not let them cache IVs. Regexps have no SvIVX and SvNVX fields. */ - assert(isREGEXP(sv) || SvPOKp(sv)); + assert(SvPOKp(sv)); { UV value; const char * const ptr = @@ -2627,7 +2627,6 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) return SvNVX(sv); if (SvPOKp(sv) && !SvIOKp(sv)) { ptr = SvPVX_const(sv); - grokpv: if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) && !grok_number(ptr, SvCUR(sv), NULL)) not_a_number(sv); @@ -2642,10 +2641,6 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) if (SvROK(sv)) { goto return_rok; } - if (isREGEXP(sv)) { - ptr = RX_WRAPPED((REGEXP *)sv); - goto grokpv; - } assert(SvTYPE(sv) >= SVt_PVMG); /* This falls through to the report_uninit near the end of the function. */ @@ -2672,13 +2667,17 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) if (SvTYPE(sv) < SVt_NV) { /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */ sv_upgrade(sv, SVt_NV); + CLANG_DIAG_IGNORE_STMT(-Wthread-safety); DEBUG_c({ - STORE_NUMERIC_LOCAL_SET_STANDARD(); + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; + STORE_LC_NUMERIC_SET_STANDARD(); PerlIO_printf(Perl_debug_log, "0x%" UVxf " num(%" NVgf ")\n", PTR2UV(sv), SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); + RESTORE_LC_NUMERIC(); }); + CLANG_DIAG_RESTORE_STMT; + } else if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); @@ -2813,12 +2812,15 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) and ideally should be fixed. */ return 0.0; } + CLANG_DIAG_IGNORE_STMT(-Wthread-safety); DEBUG_c({ - STORE_NUMERIC_LOCAL_SET_STANDARD(); + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; + STORE_LC_NUMERIC_SET_STANDARD(); PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2nv(%" NVgf ")\n", PTR2UV(sv), SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); + RESTORE_LC_NUMERIC(); }); + CLANG_DIAG_RESTORE_STMT; return SvNVX(sv); } @@ -3146,7 +3148,7 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) DECLARATION_FOR_LC_NUMERIC_MANIPULATION; STORE_LC_NUMERIC_SET_TO_NEEDED(); - local_radix = PL_numeric_local && PL_numeric_radix_sv; + local_radix = _NOT_IN_NUMERIC_STANDARD; if (local_radix && SvCUR(PL_numeric_radix_sv) > 1) { size += SvCUR(PL_numeric_radix_sv) - 1; s = SvGROW_mutable(sv, size); @@ -3191,10 +3193,6 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) *lp = SvCUR(buffer); return SvPVX(buffer); } - else if (isREGEXP(sv)) { - if (lp) *lp = RX_WRAPLEN((REGEXP *)sv); - return RX_WRAPPED((REGEXP *)sv); - } else { if (lp) *lp = 0; @@ -3371,11 +3369,16 @@ Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags) return cBOOL(svb); } } - return SvRV(sv) != 0; + assert(SvRV(sv)); + return TRUE; } if (isREGEXP(sv)) return RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0'); + + if (SvNOK(sv) && !SvPOK(sv)) + return SvNVX(sv) != 0.0; + return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0); } @@ -3405,11 +3408,7 @@ if all the bytes are invariant in UTF-8. If C has C bit set, will C on C if appropriate, else not. -If C has C set, this function assumes that the PV -will expand when converted to UTF-8, and skips the extra work of checking for -that. Typically this flag is used by a routine that has already parsed the -string and found such characters, and passes this information on so that the -work doesn't have to be repeated. +The C flag is now ignored. Returns the number of bytes in the converted string. @@ -3430,22 +3429,10 @@ Returns the number of bytes in the converted string (not including the spares). =cut -(One might think that the calling routine could pass in the position of the -first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't -have to be found again. But that is not the case, because typically when the -caller is likely to use this flag, it won't be calling this routine unless it -finds something that won't fit into a byte. Otherwise it tries to not upgrade -and just use bytes. But some things that do fit into a byte are variants in -utf8, and the caller may not have been keeping track of these.) - If the routine itself changes the string, it adds a trailing C. Such a C isn't guaranteed due to having other routines do the work in some input cases, or if the input is already flagged as being in utf8. -The speed of this could perhaps be improved for many cases if someone wanted to -write a fast function that counts the number of variant characters in a string, -especially if it could return the position of the first one. - */ STRLEN @@ -3468,7 +3455,12 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr } } - if (SvUTF8(sv)) { + /* SVt_REGEXP's shouldn't be upgraded to UTF8 - they're already + * compiled and individual nodes will remain non-utf8 even if the + * stringified version of the pattern gets upgraded. Whether the + * PVX of a REGEXP should be grown or we should just croak, I don't + * know - DAPM */ + if (SvUTF8(sv) || isREGEXP(sv)) { if (extra) SvGROW(sv, SvCUR(sv) + extra); return SvCUR(sv); } @@ -3483,185 +3475,96 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr /* This function could be much more efficient if we * had a FLAG in SVs to signal if there are any variant * chars in the PV. Given that there isn't such a flag - * make the loop as fast as possible (although there are certainly ways - * to speed this up, eg. through vectorization) */ + * make the loop as fast as possible. */ U8 * s = (U8 *) SvPVX_const(sv); - U8 * e = (U8 *) SvEND(sv); U8 *t = s; - STRLEN two_byte_count = 0; - if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8; + if (is_utf8_invariant_string_loc(s, SvCUR(sv), (const U8 **) &t)) { - /* See if really will need to convert to utf8. 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. */ - - while (t < e) { - const U8 ch = *t++; - if (NATIVE_BYTE_IS_INVARIANT(ch)) continue; - - t--; /* t already incremented; re-point to first variant */ - two_byte_count = 1; - goto must_be_utf8; - } - - /* utf8 conversion not needed because all are invariants. Mark as - * UTF-8 even if no variant - saves scanning loop */ - SvUTF8_on(sv); - if (extra) SvGROW(sv, SvCUR(sv) + extra); - return SvCUR(sv); - - must_be_utf8: + /* utf8 conversion not needed because all are invariants. Mark + * as UTF-8 even if no variant - saves scanning loop */ + SvUTF8_on(sv); + if (extra) SvGROW(sv, SvCUR(sv) + extra); + return SvCUR(sv); + } - /* Here, the string should be converted to utf8, either because of an - * input flag (two_byte_count = 0), or because a character that - * requires 2 bytes was found (two_byte_count = 1). t points either to - * the beginning of the string (if we didn't examine anything), or to - * the first variant. In either case, everything from s to t - 1 will - * occupy only 1 byte each on output. + /* Here, there is at least one variant (t points to the first one), so + * the string should be converted to utf8. Everything from 's' to + * 't - 1' will occupy only 1 byte each on output. + * + * Note that the incoming SV may not have a trailing '\0', as certain + * code in pp_formline can send us partially built SVs. * * There are two main ways to convert. One is to create a new string * and go through the input starting from the beginning, appending each - * converted value onto the new string as we go along. It's probably - * best to allocate enough space in the string for the worst possible - * case rather than possibly running out of space and having to - * reallocate and then copy what we've done so far. Since everything - * from s to t - 1 is invariant, the destination can be initialized - * with these using a fast memory copy - * - * The other way is to figure out exactly how big the string should be - * by parsing the entire input. Then you don't have to make it big - * enough to handle the worst possible case, and more importantly, if - * the string you already have is large enough, you don't have to - * allocate a new string, you can copy the last character in the input - * string to the final position(s) that will be occupied by the - * converted string and go backwards, stopping at t, since everything - * before that is invariant. - * - * There are advantages and disadvantages to each method. + * converted value onto the new string as we go along. Going this + * route, it's probably best to initially allocate enough space in the + * string rather than possibly running out of space and having to + * reallocate and then copy what we've done so far. Since everything + * from 's' to 't - 1' is invariant, the destination can be initialized + * with these using a fast memory copy. To be sure to allocate enough + * space, one could use the worst case scenario, where every remaining + * byte expands to two under UTF-8, or one could parse it and count + * exactly how many do expand. * - * In the first method, we can allocate a new string, do the memory - * copy from the s to t - 1, and then proceed through the rest of the - * string byte-by-byte. + * The other way is to unconditionally parse the remainder of the + * string to figure out exactly how big the expanded string will be, + * growing if needed. Then start at the end of the string and place + * the character there at the end of the unfilled space in the expanded + * one, working backwards until reaching 't'. * - * In the second method, we proceed through the rest of the input - * string just calculating how big the converted string will be. Then - * there are two cases: - * 1) if the string has enough extra space to handle the converted - * value. We go backwards through the string, converting until we - * get to the position we are at now, and then stop. If this - * position is far enough along in the string, this method is - * faster than the other method. If the memory copy were the same - * speed as the byte-by-byte loop, that position would be about - * half-way, as at the half-way mark, parsing to the end and back - * is one complete string's parse, the same amount as starting - * over and going all the way through. Actually, it would be - * somewhat less than half-way, as it's faster to just count bytes - * than to also copy, and we don't have the overhead of allocating - * a new string, changing the scalar to use it, and freeing the - * existing one. But if the memory copy is fast, the break-even - * point is somewhere after half way. The counting loop could be - * sped up by vectorization, etc, to move the break-even point - * further towards the beginning. - * 2) if the string doesn't have enough space to handle the converted - * value. A new string will have to be allocated, and one might - * as well, given that, start from the beginning doing the first - * method. We've spent extra time parsing the string and in - * exchange all we've gotten is that we know precisely how big to - * make the new one. Perl is more optimized for time than space, - * so this case is a loser. - * So what I've decided to do is not use the 2nd method unless it is - * guaranteed that a new string won't have to be allocated, assuming - * the worst case. I also decided not to put any more conditions on it - * than this, for now. It seems likely that, since the worst case is - * twice as big as the unknown portion of the string (plus 1), we won't - * be guaranteed enough space, causing us to go to the first method, - * unless the string is short, or the first variant character is near - * the end of it. In either of these cases, it seems best to use the - * 2nd method. The only circumstance I can think of where this would - * be really slower is if the string had once had much more data in it - * than it does now, but there is still a substantial amount in it */ + * The problem with assuming the worst case scenario is that for very + * long strings, we could allocate much more memory than actually + * needed, which can create performance problems. If we have to parse + * anyway, the second method is the winner as it may avoid an extra + * copy. The code used to use the first method under some + * circumstances, but now that there is faster variant counting on + * ASCII platforms, the second method is used exclusively, eliminating + * some code that no longer has to be maintained. */ { - STRLEN invariant_head = t - s; - STRLEN size = invariant_head + (e - t) * 2 + 1 + extra; - if (SvLEN(sv) < size) { - - /* Here, have decided to allocate a new string */ - - U8 *dst; - U8 *d; - - Newx(dst, size, U8); - - /* If no known invariants at the beginning of the input string, - * set so starts from there. Otherwise, can use memory copy to - * get up to where we are now, and then start from here */ - - if (invariant_head == 0) { - d = dst; - } else { - Copy(s, dst, invariant_head, char); - d = dst + invariant_head; - } - - while (t < e) { - append_utf8_from_native_byte(*t, &d); - t++; - } - *d = '\0'; - SvPV_free(sv); /* No longer using pre-existing string */ - SvPV_set(sv, (char*)dst); - SvCUR_set(sv, d - dst); - SvLEN_set(sv, size); - } else { - - /* Here, have decided to get the exact size of the string. - * Currently this happens only when we know that there is - * guaranteed enough space to fit the converted string, so - * don't have to worry about growing. If two_byte_count is 0, - * then t points to the first byte of the string which hasn't - * been examined yet. Otherwise two_byte_count is 1, and t - * points to the first byte in the string that will expand to - * two. Depending on this, start examining at t or 1 after t. - * */ - - U8 *d = t + two_byte_count; - - - /* Count up the remaining bytes that expand to two */ - - while (d < e) { - const U8 chr = *d++; - if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++; - } - - /* The string will expand by just the number of bytes that - * occupy two positions. But we are one afterwards because of - * the increment just above. This is the place to put the - * trailing NUL, and to set the length before we decrement */ - - d += two_byte_count; - SvCUR_set(sv, d - s); - *d-- = '\0'; + /* Count the total number of variants there are. We can start + * just beyond the first one, which is known to be at 't' */ + const Size_t invariant_length = t - s; + U8 * e = (U8 *) SvEND(sv); + + /* The length of the left overs, plus 1. */ + const Size_t remaining_length_p1 = e - t; + + /* We expand by 1 for the variant at 't' and one for each remaining + * variant (we start looking at 't+1') */ + Size_t expansion = 1 + variant_under_utf8_count(t + 1, e); + + /* +1 = trailing NUL */ + Size_t need = SvCUR(sv) + expansion + extra + 1; + U8 * d; + + /* Grow if needed */ + if (SvLEN(sv) < need) { + t = invariant_length + (U8*) SvGROW(sv, need); + e = t + remaining_length_p1; + } + SvCUR_set(sv, invariant_length + remaining_length_p1 + expansion); + /* Set the NUL at the end */ + d = (U8 *) SvEND(sv); + *d-- = '\0'; - /* Having decremented d, it points to the position to put the - * very last byte of the expanded string. Go backwards through - * the string, copying and expanding as we go, stopping when we - * get to the part that is invariant the rest of the way down */ + /* Having decremented d, it points to the position to put the + * very last byte of the expanded string. Go backwards through + * the string, copying and expanding as we go, stopping when we + * get to the part that is invariant the rest of the way down */ - e--; - while (e >= t) { - if (NATIVE_BYTE_IS_INVARIANT(*e)) { - *d-- = *e; - } else { - *d-- = UTF8_EIGHT_BIT_LO(*e); - *d-- = UTF8_EIGHT_BIT_HI(*e); - } - e--; - } - } + e--; + while (e >= t) { + if (NATIVE_BYTE_IS_INVARIANT(*e)) { + *d-- = *e; + } else { + *d-- = UTF8_EIGHT_BIT_LO(*e); + *d-- = UTF8_EIGHT_BIT_HI(*e); + } + e--; + } if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { /* Update pos. We do it at the end rather than during @@ -3680,7 +3583,6 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr } } - /* Mark as UTF-8 even if no variant - saves scanning loop */ SvUTF8_on(sv); return SvCUR(sv); } @@ -3785,7 +3687,7 @@ Perl_sv_utf8_decode(pTHX_ SV *const sv) PERL_ARGS_ASSERT_SV_UTF8_DECODE; if (SvPOKp(sv)) { - const U8 *start, *c; + const U8 *start, *c, *first_variant; /* The octets may have got themselves encoded - get them back as * bytes @@ -3797,9 +3699,9 @@ Perl_sv_utf8_decode(pTHX_ SV *const sv) * we want to make sure everything inside is valid utf8 first. */ c = start = (const U8 *) SvPVX_const(sv); - if (!is_utf8_string(c, SvCUR(sv))) - return FALSE; - if (! is_utf8_invariant_string(c, SvCUR(sv))) { + if (! is_utf8_invariant_string_loc(c, SvCUR(sv), &first_variant)) { + if (!is_utf8_string(first_variant, SvCUR(sv) - (first_variant -c))) + return FALSE; SvUTF8_on(sv); } if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { @@ -3920,15 +3822,14 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) glob to begin with. */ if(dtype == SVt_PVGV) { const char * const name = GvNAME((const GV *)dstr); - if( - strEQ(name,"ISA") + const STRLEN len = GvNAMELEN(dstr); + if(memEQs(name, len, "ISA") /* The stash may have been detached from the symbol table, so check its name. */ && GvSTASH(dstr) && HvENAME(GvSTASH(dstr)) ) mro_changes = 2; else { - const STRLEN len = GvNAMELEN(dstr); if ((len > 1 && name[len-2] == ':' && name[len-1] == ':') || (len == 1 && name[0] == ':')) { mro_changes = 3; @@ -4141,7 +4042,7 @@ Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr) } else if ( stype == SVt_PVAV && sref != dref - && strEQ(GvNAME((GV*)dstr), "ISA") + && memEQs(GvNAME((GV*)dstr), GvNAMELEN((GV*)dstr), "ISA") /* The stash may have been detached from the symbol table, so check its name before doing anything. */ && GvSTASH(dstr) && HvENAME(GvSTASH(dstr)) @@ -4448,15 +4349,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) case SVt_REGEXP: upgregexp: if (dtype < SVt_REGEXP) - { - if (dtype >= SVt_PV) { - SvPV_free(dstr); - SvPV_set(dstr, 0); - SvLEN_set(dstr, 0); - SvCUR_set(dstr, 0); - } sv_upgrade(dstr, SVt_REGEXP); - } break; case SVt_INVLIST: @@ -4705,11 +4598,13 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) ) { /* Either it's a shared hash key, or it's suitable for copy-on-write. */ +#ifdef DEBUGGING if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n"); sv_dump(sstr); sv_dump(dstr); } +#endif #ifdef PERL_ANY_COW if (!(sflags & SVf_IsCOW)) { SvIsCOW_on(sstr); @@ -4883,7 +4778,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) #endif PERL_ARGS_ASSERT_SV_SETSV_COW; - +#ifdef DEBUGGING if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n", (void*)sstr, (void*)dstr); @@ -4891,7 +4786,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) if (dstr) sv_dump(dstr); } - +#endif if (dstr) { if (SvTHINKFIRST(dstr)) sv_force_normal_flags(dstr, SV_COW_DROP_PV); @@ -4938,9 +4833,10 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) SvUTF8_on(dstr); SvLEN_set(dstr, len); SvCUR_set(dstr, cur); - if (DEBUG_C_TEST) { - sv_dump(dstr); - } +#ifdef DEBUGGING + if (DEBUG_C_TEST) + sv_dump(dstr); +#endif return dstr; } #endif @@ -5146,7 +5042,7 @@ giving it to C, and neither should any pointers from "behind" that pointer (e.g. ptr + 1) be used. If S> is true, will call C. If -S & SV_HAS_TRAILING_NUL>> is true, then C must be C, +S> is true, then C must be C, 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). @@ -5226,12 +5122,14 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags) const STRLEN len = SvLEN(sv); const STRLEN cur = SvCUR(sv); +#ifdef DEBUGGING if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Copy on write: Force normal %ld\n", (long) flags); sv_dump(sv); } +#endif SvIsCOW_off(sv); # ifdef PERL_COPY_ON_WRITE if (len) { @@ -5271,9 +5169,10 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags) } else { unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); } - if (DEBUG_C_TEST) { +#ifdef DEBUGGING + if (DEBUG_C_TEST) sv_dump(sv); - } +#endif } #else const char * const pvx = SvPVX_const(sv); @@ -5338,7 +5237,7 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) const svtype new_type = islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV; SV *const temp = newSV_type(new_type); - regexp *const temp_p = ReANY((REGEXP *)sv); + regexp *old_rx_body; if (new_type == SVt_PVMG) { SvMAGIC_set(temp, SvMAGIC(sv)); @@ -5346,15 +5245,26 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) SvSTASH_set(temp, SvSTASH(sv)); SvSTASH_set(sv, NULL); } - if (!islv) SvCUR_set(temp, SvCUR(sv)); - /* Remember that SvPVX is in the head, not the body. But - RX_WRAPPED is in the body. */ + if (!islv) + SvCUR_set(temp, SvCUR(sv)); + /* Remember that SvPVX is in the head, not the body. */ assert(ReANY((REGEXP *)sv)->mother_re); + + if (islv) { + /* LV-as-regex has sv->sv_any pointing to an XPVLV body, + * whose xpvlenu_rx field points to the regex body */ + XPV *xpv = (XPV*)(SvANY(sv)); + old_rx_body = xpv->xpv_len_u.xpvlenu_rx; + xpv->xpv_len_u.xpvlenu_rx = NULL; + } + else + old_rx_body = ReANY((REGEXP *)sv); + /* Their buffer is already owned by someone else. */ if (flags & SV_COW_DROP_PV) { /* SvLEN is already 0. For SVt_REGEXP, we have a brand new - zeroed body. For SVt_PVLV, it should have been set to 0 - before turning into a regexp. */ + zeroed body. For SVt_PVLV, we zeroed it above (len field + a union with xpvlenu_rx) */ assert(!SvLEN(islv ? sv : temp)); sv->sv_u.svu_pv = 0; } @@ -5375,8 +5285,7 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) SvFLAGS(temp) &= ~(SVTYPEMASK); SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE; - SvANY(temp) = temp_p; - temp->sv_u.svu_rx = (regexp *)temp_p; + SvANY(temp) = old_rx_body; SvREFCNT_dec_NN(temp); } @@ -5962,7 +5871,8 @@ 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. If the RV is magical, set magic will be -called after the RV is cleared. +called after the RV is cleared. Silently ignores C and warns +on already-weak references. =cut */ @@ -5991,6 +5901,42 @@ Perl_sv_rvweaken(pTHX_ SV *const sv) } /* +=for apidoc sv_rvunweaken + +Unweaken a reference: Clear the C flag on this RV; remove +the backreference to this RV from the array of backreferences +associated with the target SV, increment the refcount of the target. +Silently ignores C and warns on non-weak references. + +=cut +*/ + +SV * +Perl_sv_rvunweaken(pTHX_ SV *const sv) +{ + SV *tsv; + + PERL_ARGS_ASSERT_SV_RVUNWEAKEN; + + if (!SvOK(sv)) /* let undefs pass */ + return sv; + if (!SvROK(sv)) + Perl_croak(aTHX_ "Can't unweaken a nonreference"); + else if (!SvWEAKREF(sv)) { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is not weak"); + return sv; + } + else if (SvREADONLY(sv)) croak_no_modify(); + + tsv = SvRV(sv); + SvWEAKREF_off(sv); + SvROK_on(sv); + SvREFCNT_inc_NN(tsv); + Perl_sv_del_backref(aTHX_ tsv, sv); + return sv; +} + +/* =for apidoc sv_get_backrefs If C is the target of a weak reference then it returns the back @@ -6625,7 +6571,6 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) goto freescalar; case SVt_REGEXP: /* FIXME for plugins */ - freeregexp: pregfree2((REGEXP*) sv); goto freescalar; case SVt_PVCV: @@ -6704,7 +6649,16 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) } else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ SvREFCNT_dec(LvTARG(sv)); - if (isREGEXP(sv)) goto freeregexp; + if (isREGEXP(sv)) { + /* SvLEN points to a regex body. Free the body, then + * set SvLEN to whatever value was in the now-freed + * regex body. The PVX buffer is shared by multiple re's + * and only freed once, by the re whose len in non-null */ + STRLEN len = ReANY(sv)->xpv_len; + pregfree2((REGEXP*) sv); + SvLEN_set((sv), len); + goto freescalar; + } /* FALLTHROUGH */ case SVt_PVGV: if (isGV_with_GP(sv)) { @@ -6761,10 +6715,12 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) { if (SvIsCOW(sv)) { +#ifdef DEBUGGING if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); sv_dump(sv); } +#endif if (SvLEN(sv)) { if (CowREFCNT(sv)) { sv_buf_to_rw(sv); @@ -7851,8 +7807,6 @@ Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) STRLEN cur1; const char *pv2; STRLEN cur2; - I32 eq = 0; - SV* svrecode = NULL; if (!sv1) { pv1 = ""; @@ -7892,11 +7846,9 @@ Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) } if (cur1 == cur2) - eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1); - - SvREFCNT_dec(svrecode); - - return eq; + return (pv1 == pv2) || memEQ(pv1, pv2, cur1); + else + return 0; } /* @@ -8958,7 +8910,7 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) if (flags & SVp_NOK) { const NV was = SvNVX(sv); if (LIKELY(!Perl_isinfnan(was)) && - NV_OVERFLOWS_INTEGERS_AT && + NV_OVERFLOWS_INTEGERS_AT != 0.0 && was >= NV_OVERFLOWS_INTEGERS_AT) { /* diag_listed_as: Lost precision when %s %f by 1 */ Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), @@ -9141,7 +9093,7 @@ Perl_sv_dec_nomg(pTHX_ SV *const sv) { const NV was = SvNVX(sv); if (LIKELY(!Perl_isinfnan(was)) && - NV_OVERFLOWS_INTEGERS_AT && + NV_OVERFLOWS_INTEGERS_AT != 0.0 && was <= -NV_OVERFLOWS_INTEGERS_AT) { /* diag_listed_as: Lost precision when %s %f by 1 */ Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), @@ -9374,7 +9326,7 @@ Creates a new SV and copies a string into it, which may contain C character (C<\0>) and other binary data. The reference count for the SV is set to 1. Note that if C is zero, Perl will create a zero length (Perl) string. You are responsible for ensuring that the source buffer is at least -C bytes long. If the C argument is NULL the new SV will be +C bytes long. If the C argument is NULL the new SV will be undefined. =cut @@ -10955,12 +10907,35 @@ Usually used via one of its frontends C and C. void 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) + va_list *const args, SV **const svargs, const Size_t sv_count, bool *const maybe_tainted) { PERL_ARGS_ASSERT_SV_VSETPVFN; SvPVCLEAR(sv); - sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, 0); + sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, sv_count, maybe_tainted, 0); +} + + +/* simplified inline Perl_sv_catpvn_nomg() when you know the SV's SvPOK */ + +PERL_STATIC_INLINE void +S_sv_catpvn_simple(pTHX_ SV *const sv, const char* const buf, const STRLEN len) +{ + STRLEN const need = len + SvCUR(sv) + 1; + char *end; + + /* can't wrap as both len and SvCUR() are allocated in + * memory and together can't consume all the address space + */ + assert(need > len); + + assert(SvPOK(sv)); + SvGROW(sv, need); + end = SvEND(sv); + Copy(buf, end, len, char); + end += len; + *end = '\0'; + SvCUR_set(sv, need - 1); } @@ -10978,19 +10953,81 @@ S_warn_vcatpvfn_missing_argument(pTHX) { } +static void +S_croak_overflow() +{ + dTHX; + Perl_croak(aTHX_ "Integer overflow in format string for %s", + (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn")); +} + + +/* Given an int i from the next arg (if args is true) or an sv from an arg + * (if args is false), try to extract a STRLEN-ranged value from the arg, + * with overflow checking. + * Sets *neg to true if the value was negative (untouched otherwise. + * Returns the absolute value. + * As an extra margin of safety, it croaks if the returned value would + * exceed the maximum value of a STRLEN / 4. + */ + +static STRLEN +S_sprintf_arg_num_val(pTHX_ va_list *const args, int i, SV *sv, bool *neg) +{ + IV iv; + + if (args) { + iv = i; + goto do_iv; + } + + if (!sv) + return 0; + + SvGETMAGIC(sv); + + if (UNLIKELY(SvIsUV(sv))) { + UV uv = SvUV_nomg(sv); + if (uv > IV_MAX) + S_croak_overflow(); + iv = uv; + } + else { + iv = SvIV_nomg(sv); + do_iv: + if (iv < 0) { + if (iv < -IV_MAX) + S_croak_overflow(); + iv = -iv; + *neg = TRUE; + } + } + + if (iv > (IV)(((STRLEN)~0) / 4)) + S_croak_overflow(); + + return (STRLEN)iv; +} + + /* Returns true if c is in the range '1'..'9' * Written with the cast so it only needs one conditional test */ #define IS_1_TO_9(c) ((U8)(c - '1') <= 8) -/* read in and return a number. Updates *pattern to point to the char +/* Read in and return a number. Updates *pattern to point to the char * following the number. Expects the first char to 1..9. + * Croaks if the number exceeds 1/4 of the maximum value of STRLEN. + * This is a belt-and-braces safety measure to complement any + * overflow/wrap checks done in the main body of sv_vcatpvfn_flags. + * It means that e.g. on a 32-bit system the width/precision can't be more + * than 1G, which seems reasonable. */ -STATIC I32 -S_expect_number(pTHX_ char **const pattern) +STATIC STRLEN +S_expect_number(pTHX_ const char **const pattern) { - I32 var; + STRLEN var; PERL_ARGS_ASSERT_EXPECT_NUMBER; @@ -10998,11 +11035,10 @@ S_expect_number(pTHX_ char **const pattern) var = *(*pattern)++ - '0'; while (isDIGIT(**pattern)) { - const I32 tmp = var * 10 + (*(*pattern)++ - '0'); - if (tmp < var) - Perl_croak(aTHX_ "Integer overflow in format string for %s", - (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn")); - var = tmp; + /* if var * 10 + 9 would exceed 1/4 max strlen, croak */ + if (var > ((((STRLEN)~0) / 4 - 9) / 10)) + S_croak_overflow(); + var = var * 10 + (*(*pattern)++ - '0'); } return var; } @@ -11024,12 +11060,15 @@ S_F0convert(NV nv, char *const endbuf, STRLEN *const len) assert(!Perl_isinfnan(nv)); if (neg) nv = -nv; - if (nv < UV_MAX) { + if (nv != 0.0 && nv < UV_MAX) { char *p = endbuf; - nv += 0.5; uv = (UV)nv; - if (uv & 1 && uv == nv) - uv--; /* Round to even */ + if (uv != nv) { + nv += 0.5; + uv = (UV)nv; + if (uv & 1 && uv == nv) + uv--; /* Round to even */ + } do { const unsigned dig = uv % 10; *--p = '0' + dig; @@ -11047,11 +11086,11 @@ S_F0convert(NV nv, char *const endbuf, STRLEN *const len) void 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) + va_list *const args, SV **const svargs, const Size_t sv_count, bool *const maybe_tainted) { PERL_ARGS_ASSERT_SV_VCATPVFN; - sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC); + sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, sv_count, maybe_tainted, SV_GMAGIC|SV_SMAGIC); } @@ -11213,6 +11252,9 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, #endif const U8* vmaxend = vhex + HEXTRACTSIZE; + + assert(HEXTRACTSIZE <= VHEX_SIZE); + PERL_UNUSED_VAR(ix); /* might happen */ (void)Perl_frexp(PERL_ABS(nv), exponent); *subnormal = FALSE; @@ -11231,7 +11273,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, const U8* nvp = (const U8*)(&nv); HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_IMPLICIT_BIT(nv); -# undef HEXTRACT_HAS_TOP_NYBBLE +# undef HEXTRACT_HAS_TOP_NYBBLE HEXTRACT_BYTES_LE(13, 0); # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN /* Used in e.g. Solaris Sparc and HP-UX PA-RISC, e.g. -0.1L: @@ -11241,7 +11283,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, const U8* nvp = (const U8*)(&nv); HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_IMPLICIT_BIT(nv); -# undef HEXTRACT_HAS_TOP_NYBBLE +# undef HEXTRACT_HAS_TOP_NYBBLE HEXTRACT_BYTES_BE(2, 15); # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN /* x86 80-bit "extended precision", 64 bits of mantissa / fraction / @@ -11341,9 +11383,10 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, # define HEXTRACT_FALLBACK # endif #endif /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) #else */ -# ifdef HEXTRACT_FALLBACK + +#ifdef HEXTRACT_FALLBACK HEXTRACT_GET_SUBNORMAL(nv); -# undef HEXTRACT_HAS_TOP_NYBBLE /* Meaningless, but consistent. */ +# undef HEXTRACT_HAS_TOP_NYBBLE /* Meaningless, but consistent. */ /* The fallback is used for the double-double format, and * for unknown long double formats, and for unknown double * formats, or in general unknown NV formats. */ @@ -11424,7 +11467,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, v++; } } -# endif +#endif } /* Croak for various reasons: if the output pointer escaped the * output buffer, if the extraction index escaped the extraction @@ -11454,6 +11497,8 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, * same name within Perl_sv_vcatpvfn_flags(). * * It assumes the caller has already done STORE_LC_NUMERIC_SET_TO_NEEDED(); + * + * It requires the caller to make buf large enough. */ static STRLEN @@ -11475,7 +11520,7 @@ S_format_hexfp(pTHX_ char * const buf, const STRLEN bufsize, const char c, * be mapped through the xdig to get the actual * human-readable xdigits. */ const char* xdig = PL_hexdigit; - int zerotail = 0; /* how many extra zeros to append */ + STRLEN zerotail = 0; /* how many extra zeros to append */ int exponent = 0; /* exponent of the floating point input */ bool hexradix = FALSE; /* should we output the radix */ bool subnormal = FALSE; /* IEEE 754 subnormal/denormal */ @@ -11498,8 +11543,7 @@ S_format_hexfp(pTHX_ char * const buf, const STRLEN bufsize, const char c, /* In this case there is an implicit bit, * and therefore the exponent is shifted by one. */ exponent--; -# else -# ifdef NV_X86_80_BIT +# elif defined(NV_X86_80_BIT) if (subnormal) { /* The subnormals of the x86-80 have a base exponent of -16382, * (while the physical exponent bits are zero) but the frexp() @@ -11513,7 +11557,6 @@ S_format_hexfp(pTHX_ char * const buf, const STRLEN bufsize, const char c, } else { exponent -= 4; } -# endif /* TBD: other non-implicit-bit platforms than the x86-80. */ # endif #endif @@ -11570,6 +11613,7 @@ S_format_hexfp(pTHX_ char * const buf, const STRLEN bufsize, const char c, * the top non-zero nybble. */ for (i = vfnz[0], n = 0; i > 1; i >>= 1, n++) { } assert(n < 4); + assert(vlnz); vlnz[1] = 0; for (vshr = vlnz; vshr >= vfnz; vshr--) { vshr[1] |= (vshr[0] & (0xF >> (4 - n))) << (4 - n); @@ -11670,10 +11714,9 @@ S_format_hexfp(pTHX_ char * const buf, const STRLEN bufsize, const char c, #ifndef USE_LOCALE_NUMERIC *p++ = '.'; #else - if (PL_numeric_radix_sv) { + if (IN_LC(LC_NUMERIC)) { STRLEN n; const char* r = SvPV(PL_numeric_radix_sv, n); - assert(IN_LC(LC_NUMERIC)); Copy(r, p, n, char); p += n; } @@ -11695,6 +11738,12 @@ S_format_hexfp(pTHX_ char * const buf, const STRLEN bufsize, const char c, } elen = p - buf; + + /* sanity checks */ + if (elen >= bufsize || width >= bufsize) + /* diag_listed_as: Hexadecimal float: internal error (%s) */ + Perl_croak(aTHX_ "Hexadecimal float: internal error (overflow)"); + elen += my_snprintf(p, bufsize - elen, "%c%+d", lower ? 'p' : 'P', exponent); @@ -11733,20 +11782,6 @@ S_format_hexfp(pTHX_ char * const buf, const STRLEN bufsize, const char c, } -/* Helper for sv_vcatpvfn_flags(). */ -#define FETCH_VCATPVFN_ARGUMENT(var, in_range, expr) \ - STMT_START { \ - if (in_range) \ - (var) = (expr); \ - else { \ - (var) = &PL_sv_no; /* [perl #71000] */ \ - arg_missing = TRUE; \ - } \ - } STMT_END - -void - - /* =for apidoc sv_vcatpvfn @@ -11774,22 +11809,21 @@ Usually used via one of its frontends C and C. */ +void Perl_sv_vcatpvfn_flags(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, + va_list *const args, SV **const svargs, const Size_t sv_count, bool *const maybe_tainted, const U32 flags) { - char *p; - char *q; + const char *fmtstart; /* character following the current '%' */ + const char *q; /* current position within format */ const char *patend; STRLEN origlen; - I32 svix = 0; + Size_t svix = 0; static const char nullstr[] = "(null)"; - SV *argsv = NULL; bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */ const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */ - SV *nsv = NULL; /* Times 4: a decimal digit takes more than 3 binary digits. - * NV_DIG: mantissa takes than many decimal digits. + * NV_DIG: mantissa takes that many decimal digits. * Plus 32: Playing safe. */ char ebuf[IV_DIG * 4 + NV_DIG + 32]; bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */ @@ -11812,64 +11846,63 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * should be fixed */ assert(pat[patlen] == '\0'); - /* special-case "", "%s", and "%-p" (SVf - see below) */ - if (patlen == 0) { - if (svmax && ckWARN(WARN_REDUNDANT)) - Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s", - PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); - return; - } - if (patlen == 2 && pat[0] == '%' && pat[1] == 's') { - if (svmax > 1 && ckWARN(WARN_REDUNDANT)) - Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s", - PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); - if (args) { - const char * const s = va_arg(*args, char*); - sv_catpv_nomg(sv, s ? s : nullstr); - } - else if (svix < svmax) { - /* we want get magic on the source but not the target. sv_catsv can't do that, though */ - SvGETMAGIC(*svargs); - sv_catsv_nomg(sv, *svargs); - } - else - S_warn_vcatpvfn_missing_argument(aTHX); - return; - } - if (args && patlen == 3 && pat[0] == '%' && - pat[1] == '-' && pat[2] == 'p') { - if (svmax > 1 && ckWARN(WARN_REDUNDANT)) - Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s", - PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); - argsv = MUTABLE_SV(va_arg(*args, void*)); - sv_catsv_nomg(sv, argsv); + /* Special-case "", "%s", "%-p" (SVf - see below) and "%.0f". + * In each case, if there isn't the correct number of args, instead + * fall through to the main code to handle the issuing of any + * warnings etc. + */ + + if (patlen == 0 && (args || sv_count == 0)) return; - } -#if !defined(USE_LONG_DOUBLE) && !defined(USE_QUADMATH) - /* special-case "%.0f" */ - if ( !args - && patlen == 4 - && pat[0] == '%' && pat[1] == '.' && pat[2] == '0' && pat[3] == 'f' - && svmax > 0) - { - const NV nv = SvNV(*svargs); - if (LIKELY(!Perl_isinfnan(nv))) { - STRLEN l; - char *p; + if (patlen <= 4 && pat[0] == '%' && (args || sv_count == 1)) { + + /* "%s" */ + if (patlen == 2 && pat[1] == 's') { + if (args) { + const char * const s = va_arg(*args, char*); + sv_catpv_nomg(sv, s ? s : nullstr); + } + else { + /* we want get magic on the source but not the target. + * sv_catsv can't do that, though */ + SvGETMAGIC(*svargs); + sv_catsv_nomg(sv, *svargs); + } + return; + } - if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) { - sv_catpvn_nomg(sv, p, l); + /* "%-p" */ + if (args) { + if (patlen == 3 && pat[1] == '-' && pat[2] == 'p') { + SV *asv = MUTABLE_SV(va_arg(*args, void*)); + sv_catsv_nomg(sv, asv); return; } - } - } + } +#if !defined(USE_LONG_DOUBLE) && !defined(USE_QUADMATH) + /* special-case "%.0f" */ + else if ( patlen == 4 + && pat[1] == '.' && pat[2] == '0' && pat[3] == 'f') + { + const NV nv = SvNV(*svargs); + if (LIKELY(!Perl_isinfnan(nv))) { + STRLEN l; + char *p; + + if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) { + sv_catpvn_nomg(sv, p, l); + return; + } + } + } #endif /* !USE_LONG_DOUBLE */ + } - patend = (char*)pat + patlen; - for (p = (char*)pat; p < patend; p = q) { + patend = (char*)pat + patlen; + for (fmtstart = pat; fmtstart < patend; fmtstart = q) { char intsize = 0; /* size qualifier in "%hi..." etc */ bool alt = FALSE; /* has "%#..." */ bool left = FALSE; /* has "%-..." */ @@ -11878,21 +11911,20 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p STRLEN width = 0; /* value of "%NNN..." */ bool has_precis = FALSE; /* has "%.NNN..." */ STRLEN precis = 0; /* value of "%.NNN..." */ - bool used_explicit_ix = FALSE;/* has "%$n..." */ int base = 0; /* base to print in, e.g. 8 for %o */ UV uv = 0; /* the value to print of int-ish args */ bool vectorize = FALSE; /* has "%v..." */ - SV *vecsv = NULL; /* the cur arg for %v */ - bool vec_utf8 = FALSE; /* SvUTF8(vecsv) */ - const U8 *vecstr = NULL; /* SvPVX(vecsv) */ - STRLEN veclen = 0; /* SvCUR(vecsv) */ + bool vec_utf8 = FALSE; /* SvUTF8(vec arg) */ + const U8 *vecstr = NULL; /* SvPVX(vec arg) */ + STRLEN veclen = 0; /* SvCUR(vec arg) */ const char *dotstr = NULL; /* separator string for %v */ STRLEN dotstrlen; /* length of separator string for %v */ - I32 efix = 0; /* explicit format parameter index */ - const I32 osvix = svix; /* original index in case of bad fmt */ + Size_t efix = 0; /* explicit format parameter index */ + const Size_t osvix = svix; /* original index in case of bad fmt */ + SV *argsv = NULL; bool is_utf8 = FALSE; /* is this item utf8? */ bool arg_missing = FALSE; /* give "Missing argument" warning */ char esignbuf[4]; /* holds sign prefix, e.g. "-0x" */ @@ -11902,23 +11934,39 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p const char *eptr = NULL; /* the address of the element string */ STRLEN elen = 0; /* the length of the element string */ - const char *fmtstart; /* start of current format (the '%') */ - char c = 0; /* current character read from format */ + char c; /* the actual format ('d', s' etc) */ /* echo everything up to the next format specification */ - for (q = p; q < patend && *q != '%'; ++q) ; - if (q > p) { - if (has_utf8 && !pat_utf8) - sv_catpvn_nomg_utf8_upgrade(sv, p, q - p, nsv); + for (q = fmtstart; q < patend && *q != '%'; ++q) + {}; + + if (q > fmtstart) { + if (has_utf8 && !pat_utf8) { + /* upgrade and copy the bytes of fmtstart..q-1 to utf8 on + * the fly */ + const char *p; + char *dst; + STRLEN need = SvCUR(sv) + (q - fmtstart) + 1; + + for (p = fmtstart; p < q; p++) + if (!NATIVE_BYTE_IS_INVARIANT(*p)) + need++; + SvGROW(sv, need); + + dst = SvEND(sv); + for (p = fmtstart; p < q; p++) + append_utf8_from_native_byte((U8)*p, (U8**)&dst); + *dst = '\0'; + SvCUR_set(sv, need - 1); + } else - sv_catpvn_nomg(sv, p, q - p); - p = q; + S_sv_catpvn_simple(aTHX_ sv, fmtstart, q - fmtstart); } if (q++ >= patend) break; - fmtstart = q; + fmtstart = q; /* fmtstart is char following the '%' */ /* We allow format specification elements in this order: @@ -11939,9 +11987,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p Perl_croak_nocontext( "Cannot yet reorder sv_catpvfn() arguments from va_list"); ++q; - efix = width; + efix = (Size_t)width; width = 0; - used_explicit_ix = TRUE; + no_redundant_warning = TRUE; } else { goto gotwidth; } @@ -11998,8 +12046,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p tryasterisk: if (*q == '*') { - int i; - I32 ix; /* explicit width/vector separator index */ + STRLEN ix; /* explicit width/vector separator index */ q++; if (IS_1_TO_9(*q)) { ix = expect_number(&q); @@ -12007,7 +12054,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (args) Perl_croak_nocontext( "Cannot yet reorder sv_catpvfn() arguments from va_list"); - used_explicit_ix = TRUE; + no_redundant_warning = TRUE; } else goto unknown; } @@ -12015,6 +12062,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p ix = 0; if (*q == 'v') { + SV *vecsv; /* The asterisk was for *v, *NNN$v: vectorizing, but not * with the default "." */ q++; @@ -12022,12 +12070,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p goto unknown; if (args) vecsv = va_arg(*args, SV*); - else if (ix) { - FETCH_VCATPVFN_ARGUMENT( - vecsv, ix > 0 && ix <= svmax, svargs[ix-1]); - } else { - FETCH_VCATPVFN_ARGUMENT( - vecsv, svix < svmax, svargs[svix++]); + else { + ix = ix ? ix - 1 : svix++; + vecsv = ix < sv_count ? svargs[ix] + : (arg_missing = TRUE, &PL_sv_no); } dotstr = SvPV_const(vecsv, dotstrlen); /* Keep the DO_UTF8 test *after* the SvPV call, else things go @@ -12045,13 +12091,18 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } /* the asterisk specified a width */ - if (args) - i = va_arg(*args, int); - else - i = (ix ? ix <= svmax : svix < svmax) ? - SvIVx(svargs[ix ? ix-1 : svix++]) : 0; - left |= (i < 0); - width = (i < 0) ? -i : i; + { + int i = 0; + SV *sv = NULL; + if (args) + i = va_arg(*args, int); + else { + ix = ix ? ix - 1 : svix++; + sv = (ix < sv_count) ? svargs[ix] + : (arg_missing = TRUE, (SV*)NULL); + } + width = S_sprintf_arg_num_val(aTHX_ args, i, sv, &left); + } } else if (*q == 'v') { q++; @@ -12080,8 +12131,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (*q == '.') { q++; if (*q == '*') { - int i; - I32 ix; /* explicit precision index */ + STRLEN ix; /* explicit precision index */ q++; if (IS_1_TO_9(*q)) { ix = expect_number(&q); @@ -12089,32 +12139,40 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (args) Perl_croak_nocontext( "Cannot yet reorder sv_catpvfn() arguments from va_list"); - used_explicit_ix = TRUE; + no_redundant_warning = TRUE; } else goto unknown; } else ix = 0; - if (args) - i = va_arg(*args, int); - else { - SV *precsv; - if (ix) - FETCH_VCATPVFN_ARGUMENT( - precsv, ix > 0 && ix <= svmax, svargs[ix-1]); - else - FETCH_VCATPVFN_ARGUMENT( - precsv, svix < svmax, svargs[svix++]); - i = precsv == &PL_sv_no ? 0 : SvIVx(precsv); + { + int i = 0; + SV *sv = NULL; + bool neg = FALSE; + + if (args) + i = va_arg(*args, int); + else { + ix = ix ? ix - 1 : svix++; + sv = (ix < sv_count) ? svargs[ix] + : (arg_missing = TRUE, (SV*)NULL); + } + precis = S_sprintf_arg_num_val(aTHX_ args, i, sv, &neg); + has_precis = !neg; } - precis = i; - has_precis = !(i < 0); } else { - precis = 0; - while (isDIGIT(*q)) - precis = precis * 10 + (*q++ - '0'); + /* although it doesn't seem documented, this code has long + * behaved so that: + * no digits following the '.' is treated like '.0' + * the number may be preceded by any number of zeroes, + * e.g. "%.0001f", which is the same as "%.1f" + * so I've kept that behaviour. DAPM May 2017 + */ + while (*q == '0') + q++; + precis = IS_1_TO_9(*q) ? expect_number(&q) : 0; has_precis = TRUE; } } @@ -12179,9 +12237,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p case 'V': case 'z': case 't': -#ifdef I_STDINT case 'j': -#endif intsize = *q++; break; } @@ -12199,55 +12255,19 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p goto string; } - /* get next arg */ + if (vectorize && !strchr("BbDdiOouUXx", c)) + goto unknown; - if (vectorize) { - if (!strchr("BbDdiOouUXx", c)) - goto unknown; + /* get next arg (individual branches do their own va_arg() + * handling for the args case) */ - if (args) { - vecsv = va_arg(*args, SV*); - vecstr = (U8*)SvPV_const(vecsv,veclen); - vec_utf8 = DO_UTF8(vecsv); - } - 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 convert - * back into v-string notation and then let the - * vectorize happen normally - */ - if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) { - if ( hv_existss(MUTABLE_HV(SvRV(vecsv)), "alpha") ) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF), - "vector argument not supported with alpha versions"); - goto vdblank; - } - vecsv = sv_newmortal(); - scan_vstring((char *)vecstr, (char *)vecstr + veclen, - vecsv); - vecstr = (U8*)SvPV_const(vecsv, veclen); - vec_utf8 = DO_UTF8(vecsv); - } - } - else { - vdblank: - vecstr = (U8*)""; - veclen = 0; - } - } - else if (!args) { - if (efix) { - const I32 i = efix-1; - FETCH_VCATPVFN_ARGUMENT(argsv, i >= 0 && i < svmax, svargs[i]); - } else { - FETCH_VCATPVFN_ARGUMENT(argsv, svix >= 0 && svix < svmax, - svargs[svix++]); - } + if (!args) { + efix = efix ? efix - 1 : svix++; + argsv = efix < sv_count ? svargs[efix] + : (arg_missing = TRUE, &PL_sv_no); } + switch (c) { /* STRINGS */ @@ -12256,7 +12276,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (args) { eptr = va_arg(*args, char*); if (eptr) - elen = strlen(eptr); + if (has_precis) + elen = my_strnlen(eptr, precis); + else + elen = strlen(eptr); else { eptr = (char *)nullstr; elen = sizeof nullstr - 1; @@ -12331,7 +12354,6 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* not %*p or %*1$p - any width was explicit */ && q[-2] != '*' && q[-2] != '$' - && !used_explicit_ix ) { if (left) { /* %-p (SVf), %-NNNp */ if (width) { @@ -12464,6 +12486,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (vectorize) { STRLEN ulen; + SV *vecsv; if (base < 0) { base = -base; @@ -12471,11 +12494,35 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p esignbuf[esignlen++] = plus; } + /* initialise the vector string to iterate over */ + + vecsv = args ? va_arg(*args, SV*) : argsv; + + /* if this is a version object, we need to convert + * back into v-string notation and then let the + * vectorize happen normally + */ + if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) { + if ( hv_existss(MUTABLE_HV(SvRV(vecsv)), "alpha") ) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF), + "vector argument not supported with alpha versions"); + vecsv = &PL_sv_no; + } + else { + vecstr = (U8*)SvPV_const(vecsv,veclen); + vecsv = sv_newmortal(); + scan_vstring((char *)vecstr, (char *)vecstr + veclen, + vecsv); + } + } + vecstr = (U8*)SvPV_const(vecsv, veclen); + vec_utf8 = DO_UTF8(vecsv); + /* This is the re-entry point for when we're iterating * over the individual characters of a vector arg */ vector: if (!veclen) - goto donevalidconversion; + goto done_valid_conversion; if (vec_utf8) uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV); @@ -12513,9 +12560,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p case 't': iv = va_arg(*args, ptrdiff_t); break; #endif default: iv = va_arg(*args, int); break; -#ifdef I_STDINT - case 'j': iv = va_arg(*args, intmax_t); break; -#endif + case 'j': iv = va_arg(*args, PERL_INTMAX_T); break; case 'q': #if IVSIZE >= 8 iv = va_arg(*args, Quad_t); break; @@ -12525,7 +12570,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } } else { - IV tiv = SvIV_nomg(argsv); /* work around GCC bug #13488 */ + /* assign to tiv then cast to iv to work around + * 2003 GCC cast bug (gnu.org bugzilla #13488) */ + IV tiv = SvIV_nomg(argsv); switch (intsize) { case 'c': iv = (char)tiv; break; case 'h': iv = (short)tiv; break; @@ -12568,9 +12615,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * uptrdiff_t, so oh well */ case 't': uv = va_arg(*args, ptrdiff_t); break; #endif -#ifdef I_STDINT - case 'j': uv = va_arg(*args, uintmax_t); break; -#endif + case 'j': uv = va_arg(*args, PERL_UINTMAX_T); break; default: uv = va_arg(*args, unsigned); break; case 'q': #if IVSIZE >= 8 @@ -12581,7 +12626,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } } else { - UV tuv = SvUV_nomg(argsv); /* work around GCC bug #13488 */ + /* assign to tiv then cast to iv to work around + * 2003 GCC cast bug (gnu.org bugzilla #13488) */ + UV tuv = SvUV_nomg(argsv); switch (intsize) { case 'c': uv = (unsigned char)tuv; break; case 'h': uv = (unsigned short)tuv; break; @@ -12602,22 +12649,25 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p do_integer: { char *ptr = ebuf + sizeof ebuf; - bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */ unsigned dig; zeros = 0; switch (base) { case 16: - p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit); - do { - dig = uv & 15; - *--ptr = p[dig]; - } while (uv >>= 4); - if (tempalt) { - esignbuf[esignlen++] = '0'; - esignbuf[esignlen++] = c; /* 'x' or 'X' */ - } - break; + { + const char * const p = + (c == 'X') ? PL_hexdigit + 16 : PL_hexdigit; + + do { + dig = uv & 15; + *--ptr = p[dig]; + } while (uv >>= 4); + if (alt && *ptr != '0') { + esignbuf[esignlen++] = '0'; + esignbuf[esignlen++] = c; /* 'x' or 'X' */ + } + break; + } case 8: do { dig = uv & 7; @@ -12631,9 +12681,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p dig = uv & 1; *--ptr = '0' + dig; } while (uv >>= 1); - if (tempalt) { + if (alt && *ptr != '0') { esignbuf[esignlen++] = '0'; - esignbuf[esignlen++] = c; + esignbuf[esignlen++] = c; /* 'b' or 'B' */ } break; @@ -12652,8 +12702,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p is_utf8 = TRUE; } else { - c = (char)uv; - eptr = &c; + eptr = ebuf; + ebuf[0] = (char)uv; elen = 1; } goto string; @@ -12691,7 +12741,6 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p case 'a': case 'A': { - STRLEN radix_len; /* SvCUR(PL_numeric_radix_sv) */ STRLEN float_need; /* what PL_efloatsize needs to become */ bool hexfp; /* hexadecimal floating point? */ @@ -12794,7 +12843,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p && intsize != 'q' && ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen))) ) - goto float_concat_no_utf8; + goto float_concat; /* Determine the buffer size needed for the various * floating-point formats. @@ -12825,17 +12874,24 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * First, here are the constant bits. For ease of calculation * we over-estimate the needed buffer size, for example by * assuming all formats have an exponent and a leading 0x1. + * + * Also for production use, add a little extra overhead for + * safety's sake. Under debugging don't, as it means we're + * more likely to quickly spot issues during development. */ float_need = 1 /* possible unary minus */ + 4 /* "0x1" plus very unlikely carry */ + + 1 /* default radix point '.' */ + 2 /* "e-", "p+" etc */ + 6 /* exponent: up to 16383 (quad fp) */ +#ifndef DEBUGGING + + 20 /* safety net */ +#endif + 1; /* \0 */ /* determine the radix point len, e.g. length(".") in "1.2" */ - radix_len = 1; /* assume '.' */ #ifdef USE_LOCALE_NUMERIC /* note that we may either explicitly use PL_numeric_radix_sv * below, or implicitly, via an snprintf() variant. @@ -12850,18 +12906,26 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p lc_numeric_set = TRUE; } - if (PL_numeric_radix_sv) { - assert(IN_LC(LC_NUMERIC)); - radix_len = SvCUR(PL_numeric_radix_sv); - /* note that this will convert the output to utf8 even if - * if the radix point didn't get output */ - is_utf8 = SvUTF8(PL_numeric_radix_sv); + if (IN_LC(LC_NUMERIC)) { + /* this can't wrap unless PL_numeric_radix_sv is a string + * consuming virtually all the 32-bit or 64-bit address + * space + */ + float_need += (SvCUR(PL_numeric_radix_sv) - 1); + + /* floating-point formats only get utf8 if the radix point + * is utf8. All other characters in the string are < 128 + * and so can be safely appended to both a non-utf8 and utf8 + * string as-is. + * Note that this will convert the output to utf8 even if + * the radix point didn't get output. + */ + if (SvUTF8(PL_numeric_radix_sv) && !has_utf8) { + sv_utf8_upgrade(sv); + has_utf8 = TRUE; + } } #endif - /* this can't wrap unless PL_numeric_radix_sv is a string - * consuming virtually all the 32-bit or 64-bit address space - */ - float_need += radix_len; hexfp = FALSE; @@ -12878,8 +12942,13 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (i > 0) { digits = BIT_DIGITS(i); - if (float_need >= ((STRLEN)~0) - digits) - croak_memory_wrap(); + /* this can't overflow. 'digits' will only be a few + * thousand even for the largest floating-point types. + * And up until now float_need is just some small + * constants plus radix len, which can't be in + * overflow territory unless the radix SV is consuming + * over 1/2 the address space */ + assert(float_need < ((STRLEN)~0) - digits); float_need += digits; } } @@ -12911,8 +12980,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #else NVSIZE * 2; /* 2 hexdigits for each byte */ #endif - if (float_need >= ((STRLEN)~0) - digits) - croak_memory_wrap(); + /* see "this can't overflow" comment above */ + assert(float_need < ((STRLEN)~0) - digits); float_need += digits; } } @@ -12938,6 +13007,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p { STRLEN pr = has_precis ? precis : 6; /* known default */ + /* this probably can't wrap, since precis is limited + * to 1/4 address space size, but better safe than sorry + */ if (float_need >= ((STRLEN)~0) - pr) croak_memory_wrap(); float_need += pr; @@ -12946,19 +13018,15 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (float_need < width) float_need = width; -/* We should have correctly calculated (or indeed over-estimated) the - * buffer size, but you never know what strange floating-point systems - * there are out there. So for production use, add a little extra overhead. - * Under debugging don't, as it means we more more likely to quickly spot - * issues during development. - */ -#ifndef DEBUGGING - if (float_need >= ((STRLEN)~0) - 20) - croak_memory_wrap(); - float_need += 20; /* safety fudge factor */ -#endif - - if (PL_efloatsize < float_need) { + if (PL_efloatsize <= float_need) { + /* PL_efloatbuf should be at least 1 greater than + * float_need to allow a trailing \0 to be returned by + * snprintf(). If we need to grow, overgrow for the + * benefit of future generations */ + const STRLEN extra = 0x20; + if (float_need >= ((STRLEN)~0) - extra) + croak_memory_wrap(); + float_need += extra; Safefree(PL_efloatbuf); PL_efloatsize = float_need; Newx(PL_efloatbuf, PL_efloatsize, char); @@ -13018,7 +13086,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* hopefully the above makes ptr a very constrained format * that is safe to use, even though it's not literal */ - GCC_DIAG_IGNORE(-Wformat-nonliteral); + GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); #ifdef USE_QUADMATH { const char* qfmt = quadmath_format_single(ptr); @@ -13039,9 +13107,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv) : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)fv)); #else - elen = my_sprintf(PL_efloatbuf, ptr, fv); + elen = my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv); #endif - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; } eptr = PL_efloatbuf; @@ -13053,55 +13121,30 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * loop which handles appending eptr to sv, and do our own * stripped-down version */ - /* floating-point formats only get is_utf8 if the radix point - * is utf8. All other characters in the string are < 128 - * and so can be safely appended to both a non-utf8 and utf8 - * string as-is. - */ - if (is_utf8 && !has_utf8) { - sv_utf8_upgrade(sv); - has_utf8 = TRUE; - } - - float_concat_no_utf8: - assert(!zeros); assert(!esignlen); assert(elen); assert(elen >= width); + S_sv_catpvn_simple(aTHX_ sv, eptr, elen); - { - /* unrolled Perl_sv_catpvn */ - STRLEN need = elen + SvCUR(sv) + 1; - char *end; - /* can't wrap as both elen and SvCUR() are allocated in - * memory and together can't consume all the address space - */ - assert(need > elen); - SvGROW(sv, need); - end = SvEND(sv); - Copy(eptr, end, elen, char); - end += elen; - *end = '\0'; - SvCUR_set(sv, need - 1); - } - - goto donevalidconversion; + goto done_valid_conversion; } /* SPECIAL */ case 'n': { - int i; + STRLEN len; /* XXX ideally we should warn if any flags etc have been * set, e.g. "%-4.5n" */ /* XXX if sv was originally non-utf8 with a char in the * range 0x80-0xff, then if it got upgraded, we should * calculate char len rather than byte len here */ - i = SvCUR(sv) - origlen; + len = SvCUR(sv) - origlen; if (args) { + int i = (len > PERL_INT_MAX) ? PERL_INT_MAX : (int)len; + switch (intsize) { case 'c': *(va_arg(*args, char*)) = i; break; case 'h': *(va_arg(*args, short*)) = i; break; @@ -13112,9 +13155,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #ifdef HAS_PTRDIFF_T case 't': *(va_arg(*args, ptrdiff_t*)) = i; break; #endif -#ifdef I_STDINT - case 'j': *(va_arg(*args, intmax_t*)) = i; break; -#endif + case 'j': *(va_arg(*args, PERL_INTMAX_T*)) = i; break; case 'q': #if IVSIZE >= 8 *(va_arg(*args, Quad_t*)) = i; break; @@ -13128,9 +13169,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p Perl_croak_nocontext( "Missing argument for %%n in %s", PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); - sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i); + sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)len); } - goto donevalidconversion; + goto done_valid_conversion; } /* UNKNOWN */ @@ -13165,9 +13206,12 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* mangled format: output the '%', then continue from the * character following that */ - sv_catpvn_nomg(sv, p, 1); - q = p + 1; + sv_catpvn_nomg(sv, fmtstart-1, 1); + q = fmtstart; svix = osvix; + /* Any "redundant arg" warning from now onwards will probably + * just be misleading, so don't bother. */ + no_redundant_warning = TRUE; continue; /* not "break" */ } @@ -13195,22 +13239,17 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p { STRLEN need, have, gap; + STRLEN i; + char *s; /* signed value that's wrapped? */ assert(elen <= ((~(STRLEN)0) >> 1)); - /* Most of these length vars can range to any value if - * supplied with a hostile format and/or args. So check every - * addition for possible overflow. In reality some of these - * values are interdependent so these checks are slightly - * redundant. But its easier to be certain this way. - */ - - have = elen; - - if (have >= (((STRLEN)~0) - zeros)) - croak_memory_wrap(); - have += zeros; + /* if zeros is non-zero, then it represents filler between + * elen and precis. So adding elen and zeros together will + * always be <= precis, and the addition can never wrap */ + assert(!zeros || (precis > elen && precis - elen == zeros)); + have = elen + zeros; if (have >= (((STRLEN)~0) - esignlen)) croak_memory_wrap(); @@ -13225,40 +13264,45 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p SvGROW(sv, need); - p = SvEND(sv); - if (esignlen && fill) { - int i; - for (i = 0; i < (int)esignlen; i++) - *p++ = esignbuf[i]; - } - if (gap && !left) { - memset(p, (fill ? '0' : ' '), gap); - p += gap; - } - if (esignlen && !fill) { - int i; - for (i = 0; i < (int)esignlen; i++) - *p++ = esignbuf[i]; - } - if (zeros) { - int i; + s = SvEND(sv); + + if (left) { + for (i = 0; i < esignlen; i++) + *s++ = esignbuf[i]; for (i = zeros; i; i--) - *p++ = '0'; + *s++ = '0'; + Copy(eptr, s, elen, char); + s += elen; + for (i = gap; i; i--) + *s++ = ' '; } - if (elen) { - Copy(eptr, p, elen, char); - p += elen; - } - if (gap && left) { - memset(p, ' ', gap); - p += gap; + else { + if (fill) { + for (i = 0; i < esignlen; i++) + *s++ = esignbuf[i]; + assert(!zeros); + zeros = gap; + } + else { + for (i = gap; i; i--) + *s++ = ' '; + for (i = 0; i < esignlen; i++) + *s++ = esignbuf[i]; + } + + for (i = zeros; i; i--) + *s++ = '0'; + Copy(eptr, s, elen, char); + s += elen; } + + *s = '\0'; + SvCUR_set(sv, s - SvPVX_const(sv)); + if (is_utf8) has_utf8 = TRUE; if (has_utf8) SvUTF8_on(sv); - *p = '\0'; - SvCUR_set(sv, p - SvPVX_const(sv)); } if (vectorize && veclen) { @@ -13270,9 +13314,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p goto vector; /* do next iteration */ } - donevalidconversion: - if (used_explicit_ix) - no_redundant_warning = TRUE; + done_valid_conversion: + if (arg_missing) S_warn_vcatpvfn_missing_argument(aTHX); } @@ -13280,15 +13323,17 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* Now that we've consumed all our printf format arguments (svix) * do we have things left on the stack that we didn't use? */ - if (!no_redundant_warning && svmax >= svix + 1 && ckWARN(WARN_REDUNDANT)) { + if (!no_redundant_warning && sv_count >= svix + 1 && ckWARN(WARN_REDUNDANT)) { Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s", PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); } SvTAINT(sv); - RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to save/restore - each iteration. */ + if (lc_numeric_set) { + RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to + save/restore each iteration. */ + } } /* ========================================================================= @@ -13355,13 +13400,6 @@ Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) Newxz(parser, 1, yy_parser); ptr_table_store(PL_ptr_table, proto, parser); - /* XXX these not yet duped */ - parser->old_parser = NULL; - parser->stack = NULL; - parser->ps = NULL; - parser->stack_max1 = 0; - /* XXX parser->stack->state = 0; */ - /* XXX eventually, just Copy() most of the parser struct ? */ parser->lex_brackets = proto->lex_brackets; @@ -13403,7 +13441,6 @@ Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) parser->sig_optelems= proto->sig_optelems; parser->sig_slurpy = proto->sig_slurpy; parser->recheck_utf8_validity = proto->recheck_utf8_validity; - parser->linestr = sv_dup_inc(proto->linestr, param); { char * const ols = SvPVX(proto->linestr); @@ -14134,7 +14171,6 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) case SVt_REGEXP: duprex: /* FIXME for plugins */ - dstr->sv_u.svu_rx = ((REGEXP *)dstr)->sv_any; re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param); break; case SVt_PVLV: @@ -14146,6 +14182,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) else LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param); if (isREGEXP(sstr)) goto duprex; + /* FALLTHROUGH */ case SVt_PVGV: /* non-GP case already handled above */ if(isGV_with_GP(sstr)) { @@ -14199,7 +14236,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) SSize_t items = AvFILLp((const AV *)sstr) + 1; src_ary = AvARRAY((const AV *)sstr); - Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*); + Newx(dst_ary, AvMAX((const AV *)sstr)+1, SV*); ptr_table_store(PL_ptr_table, src_ary, dst_ary); AvARRAY(MUTABLE_AV(dstr)) = dst_ary; AvALLOC((const AV *)dstr) = dst_ary; @@ -14531,7 +14568,7 @@ Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) return nsi; /* create anew and remember what it is */ - Newxz(nsi, 1, PERL_SI); + Newx(nsi, 1, PERL_SI); ptr_table_store(PL_ptr_table, si, nsi); nsi->si_stack = av_dup_inc(si->si_stack, param); @@ -14542,6 +14579,9 @@ Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) nsi->si_prev = si_dup(si->si_prev, param); nsi->si_next = si_dup(si->si_next, param); nsi->si_markoff = si->si_markoff; +#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY + nsi->si_stack_hwm = 0; +#endif return nsi; } @@ -14623,7 +14663,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) PERL_ARGS_ASSERT_SS_DUP; - Newxz(nss, max, ANY); + Newx(nss, max, ANY); while (ix > 0) { const UV uv = POPUV(ss,ix); @@ -14826,8 +14866,8 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) case SAVEt_AELEM: /* array element */ sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param)); - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; av = (const AV *)POPPTR(ss,ix); TOPPTR(nss,ix) = av_dup_inc(av, param); break; @@ -15142,8 +15182,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_filemode = proto_perl->Ifilemode; PL_lastfd = proto_perl->Ilastfd; PL_oldname = proto_perl->Ioldname; /* XXX not quite right */ - PL_Argv = NULL; - PL_Cmd = NULL; PL_gensym = proto_perl->Igensym; PL_laststatval = proto_perl->Ilaststatval; @@ -15189,13 +15227,16 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #ifdef USE_LOCALE_NUMERIC PL_numeric_standard = proto_perl->Inumeric_standard; - PL_numeric_local = proto_perl->Inumeric_local; + PL_numeric_underlying = proto_perl->Inumeric_underlying; + PL_numeric_underlying_is_standard = proto_perl->Inumeric_underlying_is_standard; #endif /* !USE_LOCALE_NUMERIC */ /* Did the locale setup indicate UTF-8? */ PL_utf8locale = proto_perl->Iutf8locale; PL_in_utf8_CTYPE_locale = proto_perl->Iin_utf8_CTYPE_locale; PL_in_utf8_COLLATE_locale = proto_perl->Iin_utf8_COLLATE_locale; + my_strlcpy(PL_locale_utf8ness, proto_perl->Ilocale_utf8ness, sizeof(PL_locale_utf8ness)); + PL_lc_numeric_mutex_depth = 0; /* Unicode features (see perlrun/-C) */ PL_unicode = proto_perl->Iunicode; @@ -15313,6 +15354,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, init_constants(); ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); + ptr_table_store(PL_ptr_table, &proto_perl->Isv_zero, &PL_sv_zero); ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); ptr_table_store(PL_ptr_table, &proto_perl->Ipadname_const, &PL_padname_const); @@ -15508,6 +15550,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_subname = sv_dup_inc(proto_perl->Isubname, param); +#if defined(USE_POSIX_2008_LOCALE) \ + && defined(USE_THREAD_SAFE_LOCALE) \ + && ! defined(HAS_QUERYLOCALE) + for (i = 0; i < (int) C_ARRAY_LENGTH(PL_curlocales); i++) { + PL_curlocales[i] = savepv("."); /* An illegal value */ + } +#endif #ifdef USE_LOCALE_CTYPE /* Should we warn if uses locale? */ PL_warn_locale = sv_dup_inc(proto_perl->Iwarn_locale, param); @@ -15520,8 +15569,18 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #ifdef USE_LOCALE_NUMERIC PL_numeric_name = SAVEPV(proto_perl->Inumeric_name); PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param); + +# if defined(HAS_POSIX_2008_LOCALE) + PL_underlying_numeric_obj = NULL; +# endif #endif /* !USE_LOCALE_NUMERIC */ + PL_langinfo_buf = NULL; + PL_langinfo_bufsize = 0; + + PL_setlocale_buf = NULL; + PL_setlocale_bufsize = 0; + /* Unicode inversion lists */ PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param); PL_UpperLatin1 = sv_dup_inc(proto_perl->IUpperLatin1, param); @@ -15540,6 +15599,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } PL_GCB_invlist = sv_dup_inc(proto_perl->IGCB_invlist, param); PL_SB_invlist = sv_dup_inc(proto_perl->ISB_invlist, param); + PL_SCX_invlist = sv_dup_inc(proto_perl->ISCX_invlist, param); PL_WB_invlist = sv_dup_inc(proto_perl->IWB_invlist, param); PL_seen_deprecated_macro = hv_dup_inc(proto_perl->Iseen_deprecated_macro, param); PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param); @@ -15582,7 +15642,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ i = proto_perl->Imarkstack_max - proto_perl->Imarkstack; - Newxz(PL_markstack, i, I32); + Newx(PL_markstack, i, I32); PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max - proto_perl->Imarkstack); PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr @@ -15592,11 +15652,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] * NOTE: unlike the others! */ - Newxz(PL_scopestack, PL_scopestack_max, I32); + Newx(PL_scopestack, PL_scopestack_max, I32); Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32); #ifdef DEBUGGING - Newxz(PL_scopestack_name, PL_scopestack_max, const char *); + Newx(PL_scopestack_name, PL_scopestack_max, const char *); Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *); #endif /* reset stack AV to correct length before its duped via @@ -15820,6 +15880,13 @@ Perl_init_constants(pTHX) |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK |SVp_POK|SVf_POK; + SvANY(&PL_sv_zero) = new_XPVNV(); + SvREFCNT(&PL_sv_zero) = SvREFCNT_IMMORTAL; + SvFLAGS(&PL_sv_zero) = SVt_PVNV|SVf_READONLY|SVf_PROTECT + |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK + |SVp_POK|SVf_POK + |SVs_PADTMP; + SvPV_set(&PL_sv_no, (char*)PL_No); SvCUR_set(&PL_sv_no, 0); SvLEN_set(&PL_sv_no, 0); @@ -15832,7 +15899,33 @@ Perl_init_constants(pTHX) SvIV_set(&PL_sv_yes, 1); SvNV_set(&PL_sv_yes, 1); + SvPV_set(&PL_sv_zero, (char*)PL_Zero); + SvCUR_set(&PL_sv_zero, 1); + SvLEN_set(&PL_sv_zero, 0); + SvIV_set(&PL_sv_zero, 0); + SvNV_set(&PL_sv_zero, 0); + PadnamePV(&PL_padname_const) = (char *)PL_No; + + assert(SvIMMORTAL_INTERP(&PL_sv_yes)); + assert(SvIMMORTAL_INTERP(&PL_sv_undef)); + assert(SvIMMORTAL_INTERP(&PL_sv_no)); + assert(SvIMMORTAL_INTERP(&PL_sv_zero)); + + assert(SvIMMORTAL(&PL_sv_yes)); + assert(SvIMMORTAL(&PL_sv_undef)); + assert(SvIMMORTAL(&PL_sv_no)); + assert(SvIMMORTAL(&PL_sv_zero)); + + assert( SvIMMORTAL_TRUE(&PL_sv_yes)); + assert(!SvIMMORTAL_TRUE(&PL_sv_undef)); + assert(!SvIMMORTAL_TRUE(&PL_sv_no)); + assert(!SvIMMORTAL_TRUE(&PL_sv_zero)); + + assert( SvTRUE_nomg_NN(&PL_sv_yes)); + assert(!SvTRUE_nomg_NN(&PL_sv_undef)); + assert(!SvTRUE_nomg_NN(&PL_sv_no)); + assert(!SvTRUE_nomg_NN(&PL_sv_zero)); } /* @@ -16734,6 +16827,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, /* def-ness of rval pos() is independent of the def-ness of its arg */ if ( !(obase->op_flags & OPf_MOD)) break; + /* FALLTHROUGH */ case OP_SCHOMP: case OP_CHOMP: @@ -16809,6 +16903,9 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv) if (PL_op) { desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded ? "join or string" + : PL_op->op_type == OP_MULTICONCAT + && (PL_op->op_private & OPpMULTICONCAT_FAKE) + ? "sprintf" : OP_DESC(PL_op); if (uninit_sv && PL_curpad) { varname = find_uninit_var(PL_op, uninit_sv, 0, &desc); @@ -16822,7 +16919,7 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv) desc = "sort"; /* PL_warn_uninit_sv is constant */ - GCC_DIAG_IGNORE(-Wformat-nonliteral); + GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); if (desc) /* diag_listed_as: Use of uninitialized value%s */ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv, @@ -16831,7 +16928,7 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv) else Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, "", "", ""); - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; } /*