In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/8c5fc2b7832433c282c07796345b54bd79e334f3?hp=fe7ba591228c20c0840941f6994ce3055969d50f>
- Log ----------------------------------------------------------------- commit 8c5fc2b7832433c282c07796345b54bd79e334f3 Merge: fe7ba59122 e85981ca50 Author: David Mitchell <[email protected]> Date: Wed Jun 7 11:09:38 2017 +0100 [MERGE] rework Perl_sv_vcatpvfn_flags Bug fixes: Size modifiers with integer Inf/Nan, e.g. sprintf("%hi", Inf) used to print spurious warnings. The very-special-cased "%.NNNg" code has been removed, and is now handled by the special-cased "...%.NNNg..." code instead, which makes it about 4% slower, but handles unicode radix points better. "%n" with a missing arg now croaks with a specific error message (previously it croaked about modifying a read-only variable). sprintf("%p", 0+Inf) now prints the address of an SV, not the literal string "Inf" (or "NaN"). It now warns on a missing explicit width or vector arg, e.g. "%*2$d" or "%3$vd". Widths and precisions specified via an argument used to wrap; for example, this used to output " abc"; it now croaks with "Integer overflow in format string": $w = 0x100000005; printf "%*s", $w, "abc"; Illegal formats didn't work well with utf8. It now resets to the character following the '%' and continues from there. The locale-specific radix point code now uses SvCUR(PL_numeric_radix_sv) rather than SvLEN(PL_numeric_radix_sv) for buffer size allocation. Also, several places weren't taking into account the length of the radix point string when calculating buffer sizes; they were only being saved by the general 'add 40' fudge factor. Buffer sizing and length calculation overflow/wraps: The code has been thoroughly audited to look for any issues where the format and/or args are malicious, and some possible (although not exploitable) wraps have been fixed. int's and I32's etc have been replaced with STRLEN where appropriate. Tests for overflow/wrap have been added to the test suite. The code has been cleaned up a lot and better commented, so it will be easier to avoid wrapping in future. Optimisations: The special-cased "...%.0f..." is now detected and handled earlier in the loop, so is about 35% faster. It now sets and restores locale only once per function call, not multiple times per format element. Generally the code has been heavily tweaked. On average, the newly-added benchmarks are about 10-15% faster; the mixed-utf8 benchmark is about about 80% faster. Other changes: The HAS_LDBL_SPRINTF_BUG code that worked around a 2002 Irix 6 bug has been removed. The 300-line block of code which handles %a hex floating-point formats has been moved into a separate static function. The 'svmax' arg to the sv_vcatpvfn() family has been changed from I32 to STRLEN and renamed to 'sv_count'. A "Redundant argument in printf" warning is no longer emitted after an invalid % format element has been encountered. This makes the code simpler, and since you get an "Invalid conversion in printf" warning anyway, does no harm (and in fact may be less confusing). Several locals vars have been eliminated and the scope of many others has been reduced. commit e85981ca501498494be121fe69ea8a3ea6c8c836 Author: David Mitchell <[email protected]> Date: Fri Jun 2 15:57:29 2017 +0100 add some sprintf benchmarks M t/perf/benchmarks commit 21657b83b1392e51d56024de03c64fc808defeac Author: David Mitchell <[email protected]> Date: Fri Jun 2 15:12:46 2017 +0100 Perl_sv_vcatpvfn_flags: rename a label s/donevalidconversion/done_valid_conversion/ so its a bit easier to read. M sv.c commit ea4817b1dac72a22336f4afe6ee3ab9d7e40d4d0 Author: David Mitchell <[email protected]> Date: Fri Jun 2 15:07:10 2017 +0100 sv_vcatpvfn_flags and wrappers: s/svmax/sv_count/ Rename the 'svmax' parameter of Perl_sv_vcatpvfn_flags(), Perl_sv_vcatpvfn(), Perl_sv_vsetpvfn(), to 'sv_count'. 'max' often implies N-1 (e.g. svarsg[0]..svargs[svmax]), whereas it's actually the number of SV args passed to the functions. M embed.fnc M proto.h M sv.c commit d0bb7cfbdb7926a11888ea9507c51285e51aa49f Author: David Mitchell <[email protected]> Date: Fri Jun 2 14:47:11 2017 +0100 Perl_sv_vcatpvfn_flags: handle mixed utf8 better Once the output string gets upgraded to utf8 (e.g. due to a utf8 %s argument), any remaining appending of plain (non-%) parts of the format string becomes very inefficient. It basically creates an SV out of the next format chunk, upgrades that SV to utf8, then appends the upgraded buffer. This commits makes it just append the format chunk byte by byte, upgrading in the fly if that byte is !NATIVE_BYTE_IS_INVARIANT M sv.c commit 069f220916a5df0756a761e8e064076229b3e312 Author: David Mitchell <[email protected]> Date: Fri Jun 2 13:51:45 2017 +0100 add S_sv_catpvn_simple() for use by sprintf Currently Perl_sv_vcatpvfn_flags() uses an unrolled sv_catpvn_nomg() to append floating point formats, a call to sv_catpvn_nomg() to append non-% parts of the format, and a few other non-performance-critical calls to sv_catpvn_nomg(). Move the unrolled code block into an inline static function, and make the non-% appending use it too. M sv.c commit fb66e1c9b3acce81ab01cdc67d5f8610900fcf67 Author: David Mitchell <[email protected]> Date: Fri Jun 2 13:08:12 2017 +0100 Perl_sv_vcatpvfn_flags: re-indent a code block whitespace only M sv.c commit 6e1be2e06a54faa92ab53c621a6776f58eeebffe Author: David Mitchell <[email protected]> Date: Fri Jun 2 13:00:52 2017 +0100 Perl_sv_vcatpvfn_flags: eliminate p var It has 1500-line scope, and is equal to fmtstart-1 for most of the time. This also allows us to 'const'ify some variables better. M embed.fnc M proto.h M sv.c commit 6f3cc0ab249d90a03504c6915cff26c58d008b2b Author: David Mitchell <[email protected]> Date: Fri Jun 2 12:23:32 2017 +0100 Perl_sv_vcatpvfn_flags: clarify GCC bug comments In particular it wasn't clear what bug was being worked around, nor that '#13488' referred to a GNU ticket rather than a perl ticket. This bug was fixed back in 2004, but the workaround is fairly harmless, so I've left it as-is. M sv.c commit d5055133a694ab3e49efbf06a09dc9ca9422a7c1 Author: David Mitchell <[email protected]> Date: Fri Jun 2 11:57:11 2017 +0100 Perl_sv_vcatpvfn_flags: simplify alt handling only do calculations for alt (#) formatting in the branches which use it M sv.c commit ad95ba277ef335ace826cb4a527a2c35c82cc615 Author: David Mitchell <[email protected]> Date: Fri Jun 2 11:41:41 2017 +0100 Perl_sv_vcatpvfn_flags: rename 'p' var 's' In the 'append # block of code at the end of the loop, don't re-use the widely-scoped 'p' pointer; instead use a tightly scope var instead (named 's' do it doesn't clash with p which is still valid in an outer scope.) M sv.c commit 994396346877ce0327692b1645230ed3aab79891 Author: David Mitchell <[email protected]> Date: Fri Jun 2 09:51:40 2017 +0100 Perl_sv_vcatpvfn_flags: simplify format appending The bit at the end of the main loop has a whole bunch of conditionals along the lines of if (gap && !left) apppend gap if (esignlen && !fill) append esignbuf if (zeros) append zeroes if (elen) append ebuf if (gap && left) append gap This involves many tests along the main code path to cope with all the possibilities (e.g. if left, gap is output before ebuf, otherwise after) Instead split it into a couple of major branches with duplication between the branches, but requiring few tests along any one code path. For example, sprintf("%5d", -1) formerly required 9 branches, 1 for loop, and 1 memset(). It now requires 2 branches and 3 for loops, I've removed memset()s and replaced them with for loops. For the short padding typically used (e.g. "%9d" rather than "%8192d") a loop is faster. M sv.c commit e5c237c4457bb568c86126cf3816b5c115cba1b2 Author: David Mitchell <[email protected]> Date: Thu Jun 1 16:05:59 2017 +0100 Perl_sv_vcatpvfn_flags: eliminate a wrap check This is one case where it can never wrap, so don't check. M sv.c commit cf939a2ec7d3e073ec2ba5651369050b230f5156 Author: David Mitchell <[email protected]> Date: Thu Jun 1 12:46:23 2017 +0100 Perl_sv_vcatpvfn_flags: simpler special formats At the top of Perl_sv_vcatpvfn_flags(), certain fixed formats are special-cased: "", "%s", "%-p", "%.0f". Simplify the code which handles these. In particular, don't try to issue "missing" or "redundant" arg warnings there. Instead, check for the correct number of args as part of the test for whether this can be special-cased, and if not, fall through to the general code in the main body of the function to handle that format and issue any warnings. This makes the code a lot simpler. It also now detects the redundant arg in printf("%.0f",1,2). The code is now also more efficient - it tries to check for things like pat[0] == '%' only once, rather than re-checking for every special-case variant its trying. M sv.c M t/op/sprintf.t commit 0ea396d546f6a934fa5f1ab7da5002f4efa0ae53 Author: David Mitchell <[email protected]> Date: Thu Jun 1 11:55:47 2017 +0100 Perl_sv_vcatpvfn_flags: simpler redundant arg test 5.24.0 added a new warning: Redundant argument in printf at .... That warning is issued if there are more args than format elements. However, it may also warn for invalid format - e.g. for something like printf("%Z%d", 1,2) you get both Invalid conversion in printf: "%Z" at ... Redundant argument in printf at ... Personally I think once once part of the format has been determined to be invalid, its hard for perl to second-guess in what way the format was invalid, and thus to be able to conclude that there is in fact a redundant arg. So this commit commit suppresses any "redundant" warning once an "invalid" warning has been issued. Doing this makes it possible to simplify the code and remove the used_explicit_ix variable. Apart from warnings, used_explicit_ix was only used in %p to check for 'simple' special forms - but that code checks for a trailing '$' character anyway, so that test was redundant. M sv.c M t/op/sprintf.t M t/op/sprintf2.t commit 812b6f860c7670da1dccb63f390945b7ba3a038d Author: David Mitchell <[email protected]> Date: Thu Jun 1 11:29:35 2017 +0100 Perl_sv_vcatpvfn_flags: fix comment typo M sv.c commit dbfbcaeff2e345e2302dca554ad966c60c4c3d11 Author: David Mitchell <[email protected]> Date: Thu Jun 1 11:27:20 2017 +0100 Perl_sv_vcatpvfn_flags: add comment about wrap M sv.c commit 2bfa133079ec76d63c52a467feba457718b4edad Author: David Mitchell <[email protected]> Date: Thu Jun 1 11:08:27 2017 +0100 Perl_sv_vcatpvfn_flags: only do utf8 in radix code For floating point formats, the output can only be utf8 if the radix point is utf8. Currently the radix point code sets the is_utf8 variable, then later, in the main floating-point code path, it tests is_utf8 and upgrades the output string to utf8. Instead, just do the upgrade directly in the radix code block. M sv.c commit 7637234e4ce791346982ea6e5a81e9e98f2757c2 Author: David Mitchell <[email protected]> Date: Thu Jun 1 11:00:26 2017 +0100 Perl_sv_vcatpvfn_flags: simplify radix len adding Assume the length of the radix point is a constant 1 (i.e. length('.')) and only increment float_need further if we're in a locale. M sv.c commit f6c1f65de9fb9ee760030c5be0201289ba0b73fd Author: David Mitchell <[email protected]> Date: Thu Jun 1 10:52:12 2017 +0100 sprintf %a/%A more sanity checks For the code which generates hexadecimal floating-point formats, add extra sanity checks against buffer overruns. M sv.c commit 812ec8536884c7ab0aba76e997f85c156762747e Author: David Mitchell <[email protected]> Date: Thu Jun 1 10:32:36 2017 +0100 S_hextract(): fix #if indentation a complex set of nested #if/#else/#endif's had incorrect and confusing indentation. whitespace-only change M sv.c commit 4101164a79db9b57d79223dd740fc75b8aca49bc Author: David Mitchell <[email protected]> Date: Wed May 31 12:35:34 2017 +0100 Perl_sv_vcatpvfn_flags: simplify some wrap checks Skip doing some overflow checks when we know it can't overflow. M sv.c commit 34f8e9c7761ba9f7b2f0a54c636d9e84210e3507 Author: David Mitchell <[email protected]> Date: Wed May 31 11:59:48 2017 +0100 Perl_sv_vcatpvfn_flags: simplify float_need calc Include another constant addition in the initial assignment, to eliminate a later wrap check. M sv.c commit eb295c425be965576c4211afebf92687013bd50b Author: David Mitchell <[email protected]> Date: Wed May 31 11:15:15 2017 +0100 S_format_hexfp(): s/int/STRLEN/ In the helper function that sprintf's %a/%A hex floating point values, the calculation of the number of zeros to pad with should be in terms of STRLEN rather than int. A bit academic unless someone ever tries to print a hex f/p value with a precision > 2Gb digits. M sv.c commit 1fe4f5e92876d3250f87e0f494570d43fcbc6457 Author: David Mitchell <[email protected]> Date: Wed May 31 09:47:27 2017 +0100 op/infnam.t: skip unportable tests sprintf size modifiers L and q aren't available on all platform sizes, so skip them. M t/op/infnan.t commit 80c2fe61375644d5ae2a5c3b236eae7c6ac1199a Author: David Mitchell <[email protected]> Date: Tue May 30 16:11:37 2017 +0100 Perl_sv_vcatpvfn_flags: add inits to silence gcc Add a couple of unnecessary variable initialisers, to keep gcc's "this variable might be used uninitialised - then again it might not - in fact I don't really know what I'm talking about, but I've decided to annoy you with it anyway" warning at bay. M sv.c commit 1cf776efbdf4c0ec9c63db594557fb05e588123e Author: David Mitchell <[email protected]> Date: Tue May 30 15:55:29 2017 +0100 Perl_sv_vcatpvfn_flags: avoid wrap on precision Where the precision is specified literally in the format string, the integer precision value could wrap. Instead, make it croak with Integer overflow in format string As in other recent commits, the upper limit is set at 1/4 of STRLEN. M sv.c M t/op/sprintf.t M t/op/sprintf2.t commit 8a015f6ec969acd841529dbca037e9fc0e3046a4 Author: David Mitchell <[email protected]> Date: Tue May 30 15:27:00 2017 +0100 Perl_sv_vcatpvfn_flags: s/int/STRLEN/g There wee a few residual places that used int loop counters, e.g. to prepend N '0's to a number. Since the N's are of type STRLEN, make the loop counters STRLEN too. Its a bit academic since you're unlikely to have a number needing >2Gb worth of zero padding, but it makes things consistent and easier to audit. At this point I believe that any remaining usage of int / I32 / U32 in Perl_sv_vcatpvfn_flags() is legitimate. M sv.c commit 7f595ee351b96363e401ea506c10b3590018e1e7 Author: David Mitchell <[email protected]> Date: Tue May 30 15:11:24 2017 +0100 Perl_sv_vcatpvfn_flags: %n: avoid wrap Its a bit academic, but in principle if a string was longer than 2Gb chars, the length as set by %n could wrap. So use the correct type(s). M sv.c commit 50a72221c3ad37c9d2925668f5e671494e3ec09c Author: David Mitchell <[email protected]> Date: Tue May 30 13:45:35 2017 +0100 Perl_sv_vcatpvfn_flags: width/precis arg wrap When the width or precision is specified via an argument rather than literally, check whether the value wraps. Formerly, something like $w = 0x100000005; printf "%*s", $w, "abc"; might print " abc" or similar, depending on platform. Now it croaks with "Integer overflow in format string". I did wonder whether it should just warn instead, but: 1) over-large literal widths/precisions already croak. 2) Code that has wild field specifiers like that is already likely to crash with an out-of-memory error. 3) At least this croak is trappable via eval - OOM isn't. I also set the maximum allowed value to be 1/4 of the size of a pointer, to give a safety margin for possible wrapping later M sv.c M t/op/sprintf2.t commit e58e1a5bd6a9fde55dcdf3b060e2c3c92a319403 Author: David Mitchell <[email protected]> Date: Mon May 29 17:06:06 2017 +0100 Perl_sv_vcatpvfn_flags: move vector initialisation Move the generation of vecstr/veclen/vec_utf8 into the vector-initialisation block, rather than being part of the general 'get next arg' block. Also, stop vecsv being in scope for the whole of the loop block, and make it two separate tightly-scope vars (with different purposes). M sv.c commit f98db8c625222221c93a2f8ea961c1014ff99b38 Author: David Mitchell <[email protected]> Date: Mon May 29 16:53:06 2017 +0100 Perl_sv_vcatpvfn_flags: warn on missing %v arg The explicit arg variant, e.g. %3$vd, didn't give 'missing arg' warning. M sv.c M t/op/sprintf.t M t/op/sprintf2.t commit 52ffdfb42975c0a6a6ef7d48fb7a96ce2cb735c4 Author: David Mitchell <[email protected]> Date: Mon May 29 16:20:17 2017 +0100 Perl_sv_vcatpvfn_flags: warn on missing width arg It didn't used to warn when the width value was obtained from the next or specified arg, and there wasn't such an arg. M sv.c M t/op/sprintf.t commit da0861421acf77ec0140c984134db5df0da4d2f8 Author: David Mitchell <[email protected]> Date: Mon May 29 16:11:01 2017 +0100 Eliminate FETCH_VCATPVFN_ARGUMENT macro This can be simplified so much now that it might as well just be expanded in situ for its 3 uses. M sv.c commit 733b0a0f82fb27aac14ef6f96b7d7ef46fabaf3d Author: David Mitchell <[email protected]> Date: Mon May 29 16:01:26 2017 +0100 Perl_sv_vcatpvfn_flags: re-indent block whitespace-only M sv.c commit c8a3b7ce704c93afbed9951513a942c46a2bf97f Author: David Mitchell <[email protected]> Date: Mon May 29 15:27:18 2017 +0100 Perl_sv_vcatpvfn_flags: unify %v vers obj handling Cureently sv_vcatpvfn_flags() has special handling of the arg under %v when the arg is a version object, but only via the perlish interface (argsv and svmax). This commit extends that handling to the C-sih interface (args). There seems no good reason not to, and it simplifies the code. M sv.c commit 0e51eac129a5ca786bbfe7b890e94ffd89bec39d Author: David Mitchell <[email protected]> Date: Mon May 29 13:49:42 2017 +0100 Perl_sv_vcatpvfn_flags: unify args handling Several places do something along the lines of: if (explicit arg index) FETCH_VCATPVFN_ARGUMENT(...., svargs[ix-1]) else FETCH_VCATPVFN_ARGUMENT(...., svargs[svix++]) For each of these, reduce the duplicate code by changing the above to (approximately) ix = ix ? ix - 1 : svix++; FETCH_VCATPVFN_ARGUMENT(...., svargs[ix]) M sv.c commit 03a22d83037406c116b676033c0bd575b6e8ff8a Author: David Mitchell <[email protected]> Date: Mon May 29 11:16:49 2017 +0100 sv_vcatpvfn() family: make svmax arg Size_t It was formerly I32. It should be unsigned since you can't have a negative number of args. And although you're unlikely to call sprintf with more than 0x7fffffff args, it makes it more consistent with other APIs which we've been gradually expanding to 64-bit/ptrsize. It also makes the code internal to Perl_sv_vcatpvfn_flags more consistent, when dealing with explict arg index formats like "%10$s". This function still has a mix of STRLEN (for string lengths) and Size_t (for arg indexes) but they are aliases for each other. I made Perl_do_sprintf()'s len arg SSize_t rather than Size_t, since it typically gets called with ptr diff arithmetic. Not sure if this is being overly cautious. M doop.c M embed.fnc M pod/perlguts.pod M proto.h M sv.c commit 5860c1eebae0e97105f7ef5ebcb86d1c72654c51 Author: David Mitchell <[email protected]> Date: Mon May 29 09:59:16 2017 +0100 S_expect_number(): return STRLEN not I32 This static function is used by Perl_sv_vcatpvfn_flags() to read in a width or explicit argument number. It currently returns an I32 result (and croaks if the number exceeds the maximum possible I32 value). Change it to return STRLEN, and to croak on the value being greater than max(STRLEN) / 4. This doesn't make a lot of difference in practice, since no code is ever going to be able to successfully create a formatted string that large without running out of memory anyway. But by making it unsigned and of the same type used elsewhere in sv_vcatpvfn_flags(), it simplifies auditing the code for possible wrapping/truncating etc. The change in the limit where it croaks with "Integer overflow in format string" has changed as follows: previously now 32-bit system 0x7fffffff 0x3fffffff 32/64bit system 0x7fffffff 0x3fffffff 64bit system 0x7fffffff 0x3fffffffffffffff Setting the limit as 1/4 max rather than 1/2 max is just a safety net to help avoid wraps/overflows elsewhere. M embed.fnc M proto.h M sv.c M t/op/sprintf.t M t/op/sprintf2.t commit c84aff19851aed97094a819ac8136f1d0e619c7f Author: David Mitchell <[email protected]> Date: Sun May 28 18:07:14 2017 +0100 Perl_sv_vcatpvfn_flags: simplify 'c' var Make it so that its now *always* the format type ('s', 'd' etc). Don';t bother initialising it, and *don't* use as as a temporary buffer (eptr = &c), so it can be stored in a register. M sv.c commit ee022d6189798e4ee330607bb256ea600f01a25d Author: David Mitchell <[email protected]> Date: Sun May 28 17:59:47 2017 +0100 Perl_sv_vcatpvfn_flags: reduce scope of 'iv' var M sv.c commit 25aa149e50056d08d7209086af46d907c7ee5589 Author: David Mitchell <[email protected]> Date: Sun May 28 17:52:25 2017 +0100 Perl_sv_vcatpvfn_flags: eliminate 'epix' var Or rather, reduce its scope to a small block and rename to 'ix'. M sv.c commit c1ed55fcb210bc18af763f93231a871f11c44b05 Author: David Mitchell <[email protected]> Date: Sun May 28 17:49:10 2017 +0100 S_expect_number() re-indent code .. following previous commit. Whitespace only. M sv.c commit a153a24b69011905c07591405dbdb4d0724fff02 Author: David Mitchell <[email protected]> Date: Sun May 28 17:43:36 2017 +0100 sprintf: move 1..9 test out of S_expect_number() Currently Perl_sv_vcatpvfn_flags() does several checks for "is the next part of the format a number starting with a '1'..'9'?" It does this by calling S_expect_number(), which returns 0 if not, or the value of the number otherwise. For a simple format specifier, this results in multiple fruitless calls to S_expect_number. This commits makes it that the caller of S_expect_number is responsible for checking for the presence of 1..9. M sv.c commit 1a8feec26bf6b7ca18a94298fc4d6bdeb828279e Author: David Mitchell <[email protected]> Date: Sat May 27 00:57:47 2017 +0100 Perl_sv_vcatpvfn_flags: more %v optimisation Only do the code for appending the vector separator in the vector branch. In particular, don't size the SvGROW for dotstrlen outside of %v. This makes the %v code a bit slower but everything else a bit faster. M sv.c commit 6d8359099e891d5d17c54443848ae47c65431f7c Author: David Mitchell <[email protected]> Date: Sat May 27 00:17:35 2017 +0100 Perl_sv_vcatpvfn_flags: test for valid %vX once Rather than testing for !vectorize in every conversion case which doesn't support %v, test once for supported types in the if (vectorize) branch. That way code which doesn't use %v never has to test for it. M sv.c commit 035c82bafaebfbb81dc7ae9d2eb5972f5404b6d8 Author: David Mitchell <[email protected]> Date: Sat May 27 00:07:48 2017 +0100 Perl_sv_vcatpvfn_flags: join two if blocks convert if (x); if (!x); into an single if/else M sv.c commit 3137da4e11e85d1349c2188eaf05115f4954db85 Author: David Mitchell <[email protected]> Date: Sat May 27 00:00:10 2017 +0100 Perl_sv_vcatpvfn_flags: delay vector arg get Move the block of code which retrieves the SV which the %v will iterate over, from just before the /* SIZE */ block to just after. Since that block doesn't do anything with args or svargs, this should make no functional difference - but it will allow the next commit to coalesce if (x); if (!x); into an single if/else. Apart from cutting and pasting the code block, no other changes have been made to it. M sv.c commit a575c5729405e25b9c4d20ed778c4438296bfc32 Author: David Mitchell <[email protected]> Date: Fri May 26 23:49:58 2017 +0100 Perl_sv_vcatpvfn_flags: eliminate VECTORIZE_ARGS This macro is only used once. Just expand it. M sv.c commit def77a2b44181e257a45432dd21f77c593b22e7b Author: David Mitchell <[email protected]> Date: Fri May 26 23:42:07 2017 +0100 Perl_sv_vcatpvfn_flags: eliminate ewix local var It's now only used within one code block. M sv.c commit d1ce136f24009faf349e2a3b3cfc91e37082d29f Author: David Mitchell <[email protected]> Date: Fri May 26 23:34:25 2017 +0100 Perl_sv_vcatpvfn_flags: remove 'asterisk' var There was only one remaining use of this local var: in %p, to distinguish between explicit and implicit width specifier, e.g. %*p or %1$p, vs %2p. This can be done by just checking whether the char before the p was a '*' or '$'. M sv.c commit 2c60127b5800140e9e0b3888c75f4f4291fac653 Author: David Mitchell <[email protected]> Date: Fri May 26 23:20:22 2017 +0100 Perl_sv_vcatpvfn_flags: further simplify %v logic For the common case with no * or v, there now are only 2 test-and-branch (! '*', ! 'v') rather than 3 (! '*', ! 'v', !asterisk) This works by putting the *v handling code in the * branch M sv.c commit d25698308ada2b60cd782559471065666db524d5 Author: David Mitchell <[email protected]> Date: Fri May 26 22:45:02 2017 +0100 Perl_sv_vcatpvfn_flags: eliminate evix local var M sv.c commit f0498cbc4c53e95d3dc615590171765dd34cbf6e Author: David Mitchell <[email protected]> Date: Fri May 26 22:26:58 2017 +0100 Perl_sv_vcatpvfn_flags: simplify v/asterisk code The previous commit's rearrangement of the v and * code now allows us to: 1) eliminate the 'vectorarg' bool variable, which is set but no longer used; 2) join two adjacent "if (asterisk)" and "if (!asterisk)" blocks into a single if/else. M sv.c commit acb5c40ed6c543c736a67a4511651d441cf7fe3d Author: David Mitchell <[email protected]> Date: Fri May 26 22:19:44 2017 +0100 Perl_sv_vcatpvfn_flags: move %*v handling earlier Where the v flag appears, and it has non-default separator, i.e. *v or *NNN$v, retrieve the next or NNNth arg (which defines the separator) earlier - as soon as we encounter the v flag. This should in theory make no functional difference since no args are processed between those two points (so no chance of us stealing something else's arg). Doing it ealrier makes the conditions simpler (we don't have to check for (vectorize && vectorarg) later). The whole code block has been moved as-is with no changes apart from whitespace. M sv.c commit f35bb12b68e7dc46f60a20569722d6d04b72b6c2 Author: David Mitchell <[email protected]> Date: Fri May 26 18:19:11 2017 +0100 Perl_sv_vcatpvfn_flags: move Inf handling for ints integer-like format types handle Inf/Nan specially. Currently the code to handle this in the main execution path, guarded by if (strchr("BbcDdiOouUXx", c)) ... After the previous few commits reorganised the int-arg getting code, this block can now be moved into an int-only section, so not slowing down other format types. There should be no functional changes. I've added some comments to the %c branch explaining why its a special case. M sv.c commit b154ff054ce4e76402d5ffae3bfd5f169869d153 Author: David Mitchell <[email protected]> Date: Fri May 26 17:23:09 2017 +0100 Perl_sv_vcatpvfn_flags: unify int arg fetching There are two big blocks of code that do signed and unsigned 'get next int arg' processing. Combine them (sort of). Previously it was a bit like case 'd': case 'i': base = 10; if (vectorize) uv = ... else if (arg) iv = ... else iv = SvIV_nomg(argsv); if (!vectorize) uv = f(iv) for some f. goto integer; case 'x' base = 16; goto uns_integer; case 'u' base = 10; goto uns_integer; ... uns_integer: if (vectorize) uv = ... else if (arg) uv = ... else uv = SvUV_nomg(argsv); integer: ... do stuff with base and uv ... Now it's more like case 'd': base = -10; goto get_int_arg_val; case 'i': base = -10; goto get_int_arg_val; case 'x': base = 16; goto get_int_arg_val; case 'u': base = 10; goto get_int_arg_val; get_int_arg_val: if (vectorize) uv = ... else if (base < 0) { /* signed int type */ base = -base; if (arg) iv = ... else iv = SvIV_nomg(argsv); uv = f(iv) for some f. } else { /* unsigned int type */ if (arg) uv = ... else uv = SvUV_nomg(argsv); } integer: ... do stuff with base and uv ... Note that in particular the vectorize block of code is no longer duplicated. This will also allow the next commit to handle Inf/overload just after the 'get_int_arg_val' label rather than doing it before the main switch and slowing down the non-integer format types. Should be no functional changes M sv.c commit 14d1b0a5c7c0be5753b05ab19841954438ea1cb7 Author: David Mitchell <[email protected]> Date: Fri May 26 16:39:30 2017 +0100 Perl_sv_vcatpvfn_flags: move %c handling to ints %c is in some ways like integer formats - we treat the arg as an integer (with '0+' overloading and Inf/Nan handling), but then at the end convert it into a 1 char string rather than sequence of 0..9's. Move the %c code partially into the main integer handling block of code; this will shortly allow us to unify the SV-as-integer handling code. M sv.c commit 84a826ef51fc3a38e04ab298d0f2942feeb4754e Author: David Mitchell <[email protected]> Date: Fri May 26 16:05:18 2017 +0100 Perl_sv_vcatpvfn_flags: %p and Inf/Nan sprintf("%p", 0+Inf) should print the address of an SV, not the literal string "Inf". Ditto NaN. Similarly, sprintf("%p", $x) should print the address of the $x SV, not triggering a tie fetch or overload method call, nor using the address of any SV returned by such calls. M sv.c M t/op/infnan.t M t/op/sprintf2.t M t/op/tie_fetch_count.t commit 5f7104e27bf393e7a375da488b5653e69e55d8da Author: David Mitchell <[email protected]> Date: Thu May 25 12:09:52 2017 +0100 Perl_sv_vcatpvfn_flags: make 'fill' var a boolean Currently the 'fill' local variable is a char, but it only ever holds the values ' ' or '0'. Make it into a boolean flag instead. M sv.c commit 1ea5772b2b77bacf4da0d91a7ae6c88d8f7b834d Author: David Mitchell <[email protected]> Date: Thu May 25 11:56:44 2017 +0100 Perl_sv_vcatpvfn_flags: do %p specials in %p case There are currently a few special-cased %p variants (but only when called from C, not from perl) such as %-p, %2p etc. Currently these are handled specially at the top of main format-element loop, which penalises every format type. Instead move the handling into the "case 'p'" branch of the main switch. Which seems more logical, as well as more efficient. I've also heavily rewritten the big comment block about all the special %p formats. M sv.c commit 078395f0d601e3495305273a86e4384104043f1f Author: David Mitchell <[email protected]> Date: Thu May 25 10:29:04 2017 +0100 Perl_sv_vcatpvfn_flags: move UTF8f handling code The special UTF8f format (which is usually defined as something like "%d%lu%4p") is currently handled as a special case at the top of the main format-element loop. Instead move it into the "case "'d'" branch so that it doesn't slow down everything. M sv.c commit ce205b2f51e0f71cbebe24537dfdadc110bd143a Author: David Mitchell <[email protected]> Date: Wed May 24 16:29:16 2017 +0100 Perl_sv_vcatpvfn_flags: add %n code comment point out thngs like "%-4.5n" don't currently warn M sv.c commit 0ea23158a16953a6bdda198e6f77df120fe866ef Author: David Mitchell <[email protected]> Date: Wed May 24 16:09:25 2017 +0100 Perl_sv_vcatpvfn_flags: make %n missing arg fatal Normally sprintf et al just warn if there aren't enough args; but since %n wants to write the current string length to the next arg, make it fatal. Formerly it would croak anyway, but with a spurious "Modification of a read-only value" error as it as it tried to set &PL_sv_no M pod/perldiag.pod M sv.c M t/op/sprintf2.t commit a60fe28cdc60d5637900d7f01c3f37a844261e65 Author: David Mitchell <[email protected]> Date: Wed May 24 15:58:06 2017 +0100 Perl_sv_vcatpvfn_flags: comment %n deficiency This should be fixed sometime: /* 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 */ M sv.c commit c10a72e1914795f6399890aafae13734552645cd Author: David Mitchell <[email protected]> Date: Sat May 20 16:01:26 2017 +0100 Perl_sv_vcatpvfn_flags: skip IN_LC(LC_NUMERIC) In a couple of places it does if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) { ... } But PL_numeric_radix_sv is set to NULL unless we have a non-standard radix point (i.e. not "."), and this can only happen when we're in the scope of 'use locale'. So the IN_LC() should be a redundant (and expensive) test. Replace it with an assert. M sv.c commit bc37e90eb33540fa29c5be8911e2d2e25dc669df Author: David Mitchell <[email protected]> Date: Sat May 20 15:51:31 2017 +0100 Perl_sv_vcatpvfn_flags: set locale at most once Calls to external snprintf-ish functions or that directly access PL_numeric_radix_sv are supposed to sandwich this access within STORE_LC_NUMERIC_SET_TO_NEEDED(); .... RESTORE_LC_NUMERIC(); The code in Perl_sv_vcatpvfn_flags() seems to have gotten a bit confused as to whether its trying to only set STORE_LC_NUMERIC_SET_TO_NEEDED() once, then handle one of more %[aefh] format elements, then only restore on exit. There is code at the end of the function which says: RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to save/restore each iteration. */ but in practice various places within this function (and its helper function S_format_hexfp() inconsistently repeatedly do STORE_LC_NUMERIC_SET_TO_NEEDED(); and sometime do RESTORE_LC_NUMERIC(). This commit changes it so that STORE_LC_NUMERIC_SET_TO_NEEDED() is called at most once, the first time a % format involving a radix point is encountered, and does RESTORE_LC_NUMERIC(); exactly once at the end of the function. Note that while calling STORE_LC_NUMERIC_SET_TO_NEEDED() multiple times is harmless, its quite expensive, as each time it has to check whether it's in the scope of 'use locale'. RESTORE_LC_NUMERIC() is cheap if STORE_LC_NUMERIC_SET_TO_NEEDED() earlier determined that there was nothing to do. M sv.c commit 9cc0d8397eaa8e121e0d8f44e86a19132c12a899 Author: David Mitchell <[email protected]> Date: Sat May 20 13:01:02 2017 +0100 Perl_sv_vcatpvfn_flags: remove redundant code At the start of the function, it marks the output as being utf8 if the first arg is utf8. But this should be taken care of when the individual args (including the first one are processed). So its redundant code. In fact it would sometimes cause the resultant string to be unnecessarily upgraded to utf8, e.g.: my $precis = "9"; utf8::upgrade($precis); my $s = sprintf "%.*f\n", $precis, 1.1; # whoops, $s is now utf8 M sv.c M t/op/sprintf2.t commit 27b6e3b1f92b0d1cef7c9597770147628d7240bf Author: David Mitchell <[email protected]> Date: Sat May 20 12:07:23 2017 +0100 Perl_sv_vcatpvfn_flags: remove "%.Ng" special-case This function has special-case handling for the formats "%.0f" and "%.NNg", to speed things up. This special-casing appears twice, once near the top of the function for where the format matches exactly "%.0f" or "%.Ng" (N is 1..99), and once again in the main loop of the function, where it handles those format elements embedded in the larger format: "....%.0f..." and "....%.Ng..." (N > 0). The problem with the "%.Ng" code is that it isn't as robust as the more general "....%.Ng..." code - in particular the latter checks for a locale-dependent radix-point when determining needed buffer size. This commit removes the "%.Ng" special-cased code but leaves the "....%.Ng..." special-cased code. It makes the former about 7% slower compared to the situation at the start of this branch. (Part of the effort in this branch has been to make the "....%.Ng..." code faster, so that there's less of an overall performance hit by removing "%.Ng"). M sv.c commit f9e6989e75204d4bb17f8bd9f218f30ec363c14d Author: David Mitchell <[email protected]> Date: Fri May 19 16:15:31 2017 +0100 Perl_sv_vcatpvfn_flags: handle %.NNNg case earlier In the main loop, we look for %.NNNg and handle it specially. Change it so that the special-case is only used when precis is small enough to that it fits in the local ebuf[] rather than the malloced PL_efloatbuf. This allows the check for this special case to be done earlier with less redundant calculations. M sv.c commit b2ad037fc156084b17ba3c2f93be3fe214322208 Author: David Mitchell <[email protected]> Date: Fri May 19 15:45:51 2017 +0100 Perl_sv_vcatpvfn_flags: use quick concat for %.0f Most floating-point formats now use the quick concat path. But the "%.0f" shortcut was accidentally bypassing that path. This commit fixes that. M sv.c commit f851755c7adcf343960bf89d33c4cd426aef3ecb Author: David Mitchell <[email protected]> Date: Thu May 18 12:47:51 2017 +0100 Perl_sv_vcatpvfn_flags: simplify concat of f/p str Since floating-point formats do their own formatting and padding, skip the block of code at the end of the main loop which handles appending eptr to sv, and do our own stripped-down version. M sv.c commit 0328f687d9bb687bcbe7fde0aee61261ec662048 Author: David Mitchell <[email protected]> Date: Thu May 18 11:44:17 2017 +0100 Perl_sv_vcatpvfn_flags: s/gconverts/Gconvert's/ fix a comment, so that a search for the word 'Gconvert' gets a match. So that a later comment 'See earlier comment about buggy Gconvert' makes sense. M sv.c commit 5d10f2fcfe8b2a11672351b95a7f374075dd4c67 Author: David Mitchell <[email protected]> Date: Thu May 18 11:32:27 2017 +0100 Perl_sv_vcatpvfn_flags: tighten hexfp var scope Only have the 'hexfp' var declared within the innermost scope it is actually needed for. M sv.c commit 2a007f8cd4266822c9a277defa3a98dd14bfbe9a Author: David Mitchell <[email protected]> Date: Thu May 18 11:17:32 2017 +0100 Perl_sv_vcatpvfn_flags: rename 'is_simple' var the definition of 'simple' required the format to have a precision. M sv.c commit 67a075256729e5dcf6f149de6eb230830014a426 Author: David Mitchell <[email protected]> Date: Thu May 18 11:03:28 2017 +0100 Perl_sv_vcatpvfn_flags: move pod closer Several static functions etc had been added between the pod and the main function. Move the pod to be just above it. Also incorporate a comment into the pod about utf8ness of pattern and SV needing to match. M sv.c commit 749723ec6fde0abfa343018449d205875ca7289d Author: David Mitchell <[email protected]> Date: Thu May 18 10:45:56 2017 +0100 Perl_sv_vcatpvfn_flags: eliminate utf8buf[] var %c for a >255 char generates its utf8 byte representation and stores it in thiis temporarly buffer: U8 utf8buf[UTF8_MAXBYTES+1] But we already have another temporary buffer, ebuf, for creating floating point strings, which is big enough. So use that instead. M sv.c commit bb3a69e5d53b13c9e93ffdc7af58faf80c2d7045 Author: David Mitchell <[email protected]> Date: Thu May 18 10:37:42 2017 +0100 Perl_sv_vcatpvfn_flags: reorganise loop vars There are a big chunk of local vars declared at the top of the main loop. Reorder the declarations to group similar vars together, and add a comment to each var explaining what its for. No functional changes. M sv.c commit 023c07c2c940aa80a9f7373ebd0e3ef983c8e7e3 Author: David Mitchell <[email protected]> Date: Thu May 18 09:49:08 2017 +0100 Perl_sv_vcatpvfn_flags: move vars to inner scope Add a new scope around the floating-point code, then move some locals var declarations into that scope. M sv.c commit de18632d9fb976e1a9d05c5dfa81ec77aa2a081b Author: David Mitchell <[email protected]> Date: Thu May 18 09:41:15 2017 +0100 Perl_sv_vcatpvfn_flags: extract hex f/p code There is a large block of code (nearly 300 lines) in Perl_sv_vcatpvfn_flags(), which handles the %a/%A hexadecimal floating-point format. Move it into new static function, S_format_hexfp(). No functional changes. M sv.c commit ccedffca3a4de735c4032d34239327420dbb52df Author: David Mitchell <[email protected]> Date: Thu May 18 09:03:20 2017 +0100 Perl_sv_vcatpvfn_flags: move some macros earlier There are some macro definitions in the body of Perl_sv_vcatpvfn_flags() which handle some possible differences between double and long double. Move these to before the function as they will shortly need to be visible to a new helper function. At the same time, prefix their names with with VCATPVFN_ to make clear what they're for. For the same reason I've also added a new typedef, vcatpvfn_long_double_t. I also eliminated the FV_ISFINITE macro definition as its no longer used. M sv.c commit 00bc75c12c7ebb8cf76cc4f3d49f39c9f8897108 Author: David Mitchell <[email protected]> Date: Wed May 17 13:36:27 2017 +0100 remove HAS_LDBL_SPRINTF_BUG code This code was added in 2002 to work round an Irix 6 rounding bug in long double sprintfs. I strongly suspect that any such OS bug has long been fixed and/or such machines have been retired or are unlikely to have new perls installed on them. Part of the motivation for removing this code is that following the previous commit, that block of code's use of the float_need variable is likely to be wrong (since it now includes exponent etc), but I have no way of testing it. I've left the probe code in hints/irix_6.sh, so if anyone ever reports sprintf.t failures on an old Irix platform, perl -V should show if their system still has the bug. At that point someone brave could resurrect this block of code. M sv.c commit ccb8ae84d412f65e7f257f6d21742aad77857514 Author: David Mitchell <[email protected]> Date: Wed May 17 12:27:18 2017 +0100 Perl_sv_vcatpvfn_flags: better calc f/p buf size How it works out the needed buffer size for the various floating point formats is a bit opaque. This commit extensively documents and rationalises the process. In particular it will no longer allocate a very large buffer for %g printing a large number (%g switches to %e style format rather than %f in cases like this). Also it no longer relies on a +40 fudge factor to accommodate exponents - this is now factored in properly. It still includes a +20 safety fudge factor for production builds, but this is disabled under DEBUGGING so that ASAN and the like are likely to more quickly spot issues during development. M sv.c M t/op/sprintf2.t commit 559a021f1d52c32a82cbdf9184aa59a58e898b08 Author: David Mitchell <[email protected]> Date: Tue May 16 16:30:13 2017 +0100 sprintf: handle sized int-ish formats with Inf/Nan The code path taken when int-ish formats saw an Inf/Nan was to jump to the floating-point handler, but then that would warn about (valid) size qualifiers. For example before: $ perl -we'printf "[%hi]\n", Inf' Invalid conversion in printf: "%hi" at -e line 1. Redundant argument in printf at -e line 1. [%hi] $ After this commit: $ perl -we'printf "[%hi]\n", Inf' [Inf] $ It also makes the code simpler. M sv.c M t/op/infnan.t commit 5a5fe90db443ad067e76362e551375647b619ab9 Author: David Mitchell <[email protected]> Date: Tue May 16 08:53:19 2017 +0100 Perl_sv_vcatpvfn_flags: handle Inf/Nan in 1 place At the start of the float section, check whether the value if Inf/Nan and handle directly. This stops later blocks of code having to test for it too. Also simplify the formatting of Inf/Nan - let the general code at the end of the block do any pre/post padding. M sv.c commit d7ce3e216e4fc097060b79ddfd1cc497e74d21ad Author: David Mitchell <[email protected]> Date: Mon May 15 18:59:54 2017 +0100 Perl_sv_vcatpvfn_flags: sort PL_numeric_radix_sv Under locales the radix point may not be just a simple '.' but a Unicode string like "\N{ARABIC DECIMAL SEPARATOR}". Currently the hex f/p code explicitly takes account of the length of this string when calculating the buffer length, but the other branches don't - they just rely on the "add 40 fudge factor" to protect them. Instead, handle its length for all branches, and simplify utf8 handling. Currently it checks post-format whether the radix point was utf8, and if so marks the resulting buffer as utf8. Instead, check for utf8-ness at the same time we check for length. This new approach doesn't check whether the resulting string actually contains the radix point string, so in principle the string could be marked utf8 but not have any >127 chars. I think this is harmless. M sv.c commit 784f8b3cbed61eec02af29dba2e2f906ab3de16a Author: David Mitchell <[email protected]> Date: Mon May 15 20:42:12 2017 +0100 Perl_sv_vcatpvfn_flags() split %.0f and %.Ng The format elements "%.0f" and "%.NNNg" are handled specially in the main loop. Split the code block which handles them and process %.0f earlier. It doesn't need to allocate a variable-length buffer or worry about the length of the radix string. M sv.c commit 2b7d1ece3360ab87502d3adcd9fd64f482cbe06e Author: David Mitchell <[email protected]> Date: Mon May 15 14:49:50 2017 +0100 S_F0convert(): remove Nan/Inf handling This function handles sprintf "%.0f". It also handles Inf/Nan, but neither of its callers will call it with such an nv. Its code for handling them is also broken - it returns the \0 following the "Inf" or "Nan! string. So just remove this unneeded and broken functionality. At the same time document what S_F0convert() does. M sv.c commit 7c671983277afae7035c2c9078d47f9be9924bf0 Author: David Mitchell <[email protected]> Date: Mon May 15 13:54:17 2017 +0100 Perl_sv_vcatpvfn_flags: fix arg to SNPRINTF_G() One of the callers of SNPRINTF_G() passes 'size' as its third arg - but there is no such variable. This code happens only to be used in the !USE_QUADMATH branch, and the SNPRINTF_G macro only uses that arg under USE_QUADMATH. So it doesn't matter. But replace 'size' with 'sizeof(ebuf)' in case that changes in future. M sv.c commit 7d47e43d076885f3fac0a4c62aecc3706f56624d Author: David Mitchell <[email protected]> Date: Mon May 15 12:51:56 2017 +0100 Perl_sv_vcatpvfn_flags: reduce scope of local var fix_ldbl_sprintf_bug is only used in one block of code so declare it in that block. Given that that block is only compiled under HAS_LDBL_SPRINTF_BUG, which seems only to be for some obscure Irix issues from 2002, I haven't actually tested this. M sv.c commit 4c039fd82ca62691f50df7ca9c2b86a84c445d16 Author: David Mitchell <[email protected]> Date: Mon May 15 11:59:49 2017 +0100 use SvCUR(PL_numeric_radix_sv) not SvLEN() When determining the length of buffer needed to output the decimal point in the current locale, use SvCUR(PL_numeric_radix_sv) rather than SvLEN(PL_numeric_radix_sv). I presume this was a thinko in the original commit. Using SvLEN currently seems harmless, since typically SvCUR < SvLEN, but one could conceive a future scenario where locale info is set using alien string buffers with SvLEN(sv) == 0. M sv.c commit 67d0ee8ee8593f11ed43f3ace64963f5645b73cc Author: David Mitchell <[email protected]> Date: Thu May 11 09:06:05 2017 +0100 Perl_sv_vcatpvfn_flags: reindent block whitespace only M sv.c commit fce26459b034b58a2317bbf41b281bc8157329d6 Author: David Mitchell <[email protected]> Date: Thu May 11 09:00:30 2017 +0100 Perl_sv_vcatpvfn_flags: reduce scope of 'int i' Declare an 'i' var wherever needed for local use, rather than being in scope for 1600 lines. M sv.c commit 2b4780456089c3aff8a223d54788c976348afb25 Author: David Mitchell <[email protected]> Date: Wed May 10 17:23:51 2017 +0100 Perl_sv_vcatpvfn_flags: get rid of an (int) cast harmless in this case, but there really shouldn't be (int) casts on string length and ptr diff calculations M sv.c commit 3e41ecc92174a108aa69c527c9e59d41d45ed39b Author: David Mitchell <[email protected]> Date: Wed May 10 16:58:58 2017 +0100 Perl_sv_vcatpvfn_flags: calc (width - elen) once There's a couple of blocks of code which repeat the expression (width - elen). Calculate this once at the top. This makes it slightly easier to audit the code for signed/unsigned wrap etc. Should be no functional change. M sv.c commit 56b8b5fa015fb4447d1b1c18605edf654bd487ea Author: David Mitchell <[email protected]> Date: Wed May 10 16:17:18 2017 +0100 Perl_sv_vcatpvfn_flags: avoid 1-byte buf overrun This only occurs on the "%a" (hex) format, and only happens when processing a denormalised value whose bit pattern is 0xf....f or similar, and when rounding up it needs to insert a '1' at the head of the number and shift the rest of the digits down one. In practice this never seems to happen - the top nybble of a denormalised float value always seems to be 0x1 (presumably because that's implicit) so there's never any carry to a higher digit. Maybe other platforms do it differently. Also VHEX_SIZE seems to be rounded up, so in practice there's no overrun. But better safe than sorry. M sv.c commit f712c9c902dc12404cc91a577c7986c8bd7db5bf Author: David Mitchell <[email protected]> Date: Wed May 10 15:27:49 2017 +0100 Perl_sv_vcatpvfn_flags: avoid a potential wrap In the floating-point hex (%a) code, it checks whether the requested precision is smaller than the hex buf size. It does this by casting (precis + 1) to signed. Since precis can be any user-supplied value, this can wrap. Instead, cast the (buffer_length - 1) to unsigned, since this is bounded to a small constant value > 1. In practise this makes no difference currently, as a large precis will have caused a malloc panic earlier anyway. But that might change in future. M sv.c commit 196344c20348c6f1effb9b3dabcee6350d47fbff Author: David Mitchell <[email protected]> Date: Wed May 10 14:03:25 2017 +0100 Perl_sv_vcatpvfn_flags: simplify an expression In the hex floating/point code, (subnormal ? vfnz : vhex) is equivalent to v0, which we just set to the same value. So keep things simple. M sv.c commit c0535913148dc15651cf402b864ceb78a5e40c6d Author: David Mitchell <[email protected]> Date: Wed May 10 11:19:38 2017 +0100 sprintf(): handle mangled formats better with utf8 Currently if sprintf() detects an error in the format while processing a %.... entry, it copies the bytes as-is from the % to the point the error was detected, then continues, If the output string and format string don't have the same utf8-ness, this can result in badly-formed utf8 output. This commit changes the code so that it just appends a '%' then restarts processing from the character following the %. Most of the time this just again results with the characters following the % being output as-is, expect this time the 'normal' character-copying code path is taken, which handles utf8 mismatches correctly. By doing this, it also removes a block of code which contained a "roll your own" string appender which used SvGROW() and Copy(). This was one further place which was potentially open to wrapping and block overrun bugs. This commit may cause occasional changes in behaviour, depending on whether there are any further '%' characters within the bad section of the format. Now these will be reprocessed, possibly triggering further 'Invalid conversion' type warnings. M sv.c M t/op/sprintf.t M t/op/sprintf2.t commit 075f29f481ebf101b77740c973de022de650189d Author: David Mitchell <[email protected]> Date: Tue May 9 15:55:07 2017 +0100 Perl_sv_vcatpvfn_flags: simplify wrap checking The main SvGROW() has a new-length arg roughly equivalent to (SvCUR(sv) + elen + zeros + esignlen + dotstrlen + 1); Rationalise the overflow/wrap checking by doing each individual addition separately with its own check. This is slightly redundant as some of the values are interdependent, but this way it's easier to see whether all possible overflows are being checked for. ` M sv.c commit 24c4c352e63b4aa738dce7435a9e12968fd1006e Author: David Mitchell <[email protected]> Date: Tue May 9 15:32:49 2017 +0100 Perl_sv_vcatpvfn_flags: reduce scope of 'gap' var shouldn't make any functional difference M sv.c commit 252710ff90abb255d41a5a06ad46d0eaf832b78b Author: David Mitchell <[email protected]> Date: Tue May 9 15:29:25 2017 +0100 Perl_sv_vcatpvfn_flags: reindent a block of code (whitespace-only change) indent a chunk of code ready for the next commit. M sv.c commit d8440ba98282cdcffc278903e87ee1a20e80aba5 Author: David Mitchell <[email protected]> Date: Tue May 9 14:48:59 2017 +0100 Perl_sv_vcatpvfn_flags: reduce scope of 'have' var Just declare this var in the small block where its needed, rather than being in scope for 500+ lines. Should be no functional changes. M sv.c commit 655816c42255edd311d85817b154bf5902b2d40f Author: David Mitchell <[email protected]> Date: Tue May 9 14:36:40 2017 +0100 Perl_sv_vcatpvfn_flags: split the 'need' local var The 'need' local var has a wide scope (over 500 lines), and is used for two separate purposes. Split it into two separate vars. One remains wide scope, but is just used to calculate the new value of PL_efloatsize. Rename that one to 'float_need'. For the second use, introduce a new scope of just 6 lines with its own 'need' variable'. This should make no functional difference but makes the code slightly easier to understand and analyse. M sv.c commit d729f63cc94318c248eab95844cfbed5298a7ecd Author: David Mitchell <[email protected]> Date: Tue May 9 14:29:11 2017 +0100 sprintf(): add memory wrap tests In various places Perl_sv_vcatpvfn_flags() does croak_memory_wrap() (including a couple added by the previous commit to fix RT #131260), but there don't appear to be any tests for them. So this commit adds some tests. M t/op/sprintf2.t ----------------------------------------------------------------------- Summary of changes: doop.c | 5 +- embed.fnc | 10 +- pod/perldiag.pod | 5 + pod/perlguts.pod | 2 +- proto.h | 10 +- sv.c | 2502 ++++++++++++++++++++++++++---------------------- t/op/infnan.t | 36 +- t/op/sprintf.t | 126 +-- t/op/sprintf2.t | 148 ++- t/op/tie_fetch_count.t | 4 +- t/perf/benchmarks | 69 ++ 11 files changed, 1706 insertions(+), 1211 deletions(-) diff --git a/doop.c b/doop.c index c97d9e3208..9b525ae53b 100644 --- a/doop.c +++ b/doop.c @@ -717,13 +717,14 @@ Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp) } void -Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg) +Perl_do_sprintf(pTHX_ SV *sv, SSize_t len, SV **sarg) { STRLEN patlen; const char * const pat = SvPV_const(*sarg, patlen); bool do_taint = FALSE; PERL_ARGS_ASSERT_DO_SPRINTF; + assert(len >= 1); if (SvTAINTED(*sarg)) TAINT_PROPER( @@ -736,7 +737,7 @@ Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg) SvUTF8_off(sv); if (DO_UTF8(*sarg)) SvUTF8_on(sv); - sv_vsetpvfn(sv, pat, patlen, NULL, sarg + 1, len - 1, &do_taint); + sv_vsetpvfn(sv, pat, patlen, NULL, sarg + 1, (Size_t)(len - 1), &do_taint); SvSETMAGIC(sv); if (do_taint) SvTAINTED_on(sv); diff --git a/embed.fnc b/embed.fnc index 1314504502..c25941437a 100644 --- a/embed.fnc +++ b/embed.fnc @@ -484,7 +484,7 @@ p |bool |do_print |NULLOK SV* sv|NN PerlIO* fp pR |OP* |do_readline : Defined in doio.c, used only in pp_sys.c p |bool |do_seek |NULLOK GV* gv|Off_t pos|int whence -Ap |void |do_sprintf |NN SV* sv|I32 len|NN SV** sarg +Ap |void |do_sprintf |NN SV* sv|SSize_t len|NN SV** sarg : Defined in doio.c, used only in pp_sys.c p |Off_t |do_sysseek |NN GV* gv|Off_t pos|int whence : Defined in doio.c, used only in pp_sys.c @@ -1618,14 +1618,14 @@ Apdmb |void |sv_usepvn |NN SV* sv|NULLOK char* ptr|STRLEN len Apd |void |sv_usepvn_flags|NN SV *const sv|NULLOK char* ptr|const STRLEN len\ |const U32 flags Apd |void |sv_vcatpvfn |NN SV *const sv|NN const char *const pat|const STRLEN patlen \ - |NULLOK va_list *const args|NULLOK SV **const svargs|const I32 svmax \ + |NULLOK va_list *const args|NULLOK SV **const svargs|const Size_t sv_count \ |NULLOK bool *const maybe_tainted Apd |void |sv_vcatpvfn_flags|NN SV *const sv|NN const char *const pat|const STRLEN patlen \ - |NULLOK va_list *const args|NULLOK SV **const svargs|const I32 svmax \ + |NULLOK va_list *const args|NULLOK SV **const svargs|const Size_t sv_count \ |NULLOK bool *const maybe_tainted|const U32 flags Apd |void |sv_vsetpvfn |NN SV *const sv|NN const char *const pat|const STRLEN patlen \ |NULLOK va_list *const args|NULLOK SV **const svargs \ - |const I32 svmax|NULLOK bool *const maybe_tainted + |const Size_t sv_count|NULLOK bool *const maybe_tainted ApR |NV |str_to_version |NN SV *sv EXpRM |SV* |swash_init |NN const char* pkg|NN const char* name|NN SV* listsv|I32 minbits|I32 none EXpM |UV |swash_fetch |NN SV *swash|NN const U8 *ptr|bool do_utf8 @@ -2596,7 +2596,7 @@ s |int |sv_2iuv_non_preserve |NN SV *const sv|I32 numtype s |int |sv_2iuv_non_preserve |NN SV *const sv # endif # endif -sR |I32 |expect_number |NN char **const pattern +sR |STRLEN |expect_number |NN const char **const pattern sn |STRLEN |sv_pos_u2b_forwards|NN const U8 *const start \ |NN const U8 *const send|NN STRLEN *const uoffset \ |NN bool *const at_end diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 60f32ecb30..cf9801e177 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -3527,6 +3527,11 @@ ended earlier on the current line. (W syntax) An underscore (underbar) in a numeric constant did not separate two digits. +=item Missing argument for %n in %s + +(F) A C<%n> was used in a format string with no corresponding argument for +perl to write the current string length to. + =item Missing argument in %s (W missing) You called a function with fewer arguments than other diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 56eee93164..e90e9035e5 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -79,7 +79,7 @@ To change the value of an I<already-existing> SV, there are eight routines: void sv_setpvn(SV*, const char*, STRLEN) void sv_setpvf(SV*, const char*, ...); void sv_vsetpvfn(SV*, const char*, STRLEN, va_list *, - SV **, I32, bool *); + SV **, Size_t, bool *); void sv_setsv(SV*, SV*); Notice that you can choose to specify the length of the string to be diff --git a/proto.h b/proto.h index 7b5b4bc3d0..c6f80360d1 100644 --- a/proto.h +++ b/proto.h @@ -789,7 +789,7 @@ PERL_CALLCONV OP* Perl_do_readline(pTHX) __attribute__warn_unused_result__; PERL_CALLCONV bool Perl_do_seek(pTHX_ GV* gv, Off_t pos, int whence); -PERL_CALLCONV void Perl_do_sprintf(pTHX_ SV* sv, I32 len, SV** sarg); +PERL_CALLCONV void Perl_do_sprintf(pTHX_ SV* sv, SSize_t len, SV** sarg); #define PERL_ARGS_ASSERT_DO_SPRINTF \ assert(sv); assert(sarg) PERL_CALLCONV void Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim); @@ -3454,10 +3454,10 @@ PERL_CALLCONV void Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va PERL_CALLCONV void Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args); #define PERL_ARGS_ASSERT_SV_VCATPVF_MG \ assert(sv); assert(pat) -PERL_CALLCONV 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); +PERL_CALLCONV void Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, va_list *const args, SV **const svargs, const Size_t sv_count, bool *const maybe_tainted); #define PERL_ARGS_ASSERT_SV_VCATPVFN \ assert(sv); assert(pat) -PERL_CALLCONV 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, const U32 ... [8 chars truncated] +PERL_CALLCONV void Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, va_list *const args, SV **const svargs, const Size_t sv_count, bool *const maybe_tainted, con ... [14 chars truncated] #define PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS \ assert(sv); assert(pat) PERL_CALLCONV void Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args); @@ -3466,7 +3466,7 @@ PERL_CALLCONV void Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va PERL_CALLCONV void Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args); #define PERL_ARGS_ASSERT_SV_VSETPVF_MG \ assert(sv); assert(pat) -PERL_CALLCONV 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); +PERL_CALLCONV void Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, va_list *const args, SV **const svargs, const Size_t sv_count, bool *const maybe_tainted); #define PERL_ARGS_ASSERT_SV_VSETPVFN \ assert(sv); assert(pat) PERL_CALLCONV UV Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8); @@ -5554,7 +5554,7 @@ STATIC void S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN fr STATIC bool S_curse(pTHX_ SV * const sv, const bool check_refcnt); #define PERL_ARGS_ASSERT_CURSE \ assert(sv) -STATIC I32 S_expect_number(pTHX_ char **const pattern) +STATIC STRLEN S_expect_number(pTHX_ const char **const pattern) __attribute__warn_unused_result__; #define PERL_ARGS_ASSERT_EXPECT_NUMBER \ assert(pattern) diff --git a/sv.c b/sv.c index 4c3936b8c5..de27251f03 100644 --- a/sv.c +++ b/sv.c @@ -3147,8 +3147,8 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) STORE_LC_NUMERIC_SET_TO_NEEDED(); local_radix = PL_numeric_local && PL_numeric_radix_sv; - if (local_radix && SvLEN(PL_numeric_radix_sv) > 1) { - size += SvLEN(PL_numeric_radix_sv) - 1; + if (local_radix && SvCUR(PL_numeric_radix_sv) > 1) { + size += SvCUR(PL_numeric_radix_sv) - 1; s = SvGROW_mutable(sv, size); } @@ -10955,12 +10955,35 @@ Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>. 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,28 +11001,102 @@ S_warn_vcatpvfn_missing_argument(pTHX) { } -STATIC I32 -S_expect_number(pTHX_ char **const pattern) +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 + * 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 STRLEN +S_expect_number(pTHX_ const char **const pattern) { - I32 var = 0; + STRLEN var; PERL_ARGS_ASSERT_EXPECT_NUMBER; - switch (**pattern) { - case '1': case '2': case '3': - case '4': case '5': case '6': - case '7': case '8': case '9': - 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; - } + assert(IS_1_TO_9(**pattern)); + + var = *(*pattern)++ - '0'; + while (isDIGIT(**pattern)) { + /* 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; } +/* Implement a fast "%.0f": given a pointer to the end of a buffer (caller + * ensures it's big enough), back fill it with the rounded integer part of + * nv. Returns ptr to start of string, and sets *len to its length. + * Returns NULL if not convertible. + */ + STATIC char * S_F0convert(NV nv, char *const endbuf, STRLEN *const len) { @@ -11008,11 +11105,7 @@ S_F0convert(NV nv, char *const endbuf, STRLEN *const len) PERL_ARGS_ASSERT_F0CONVERT; - if (UNLIKELY(Perl_isinfnan(nv))) { - STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len, 0); - *len = n; - return endbuf - n; - } + assert(!Perl_isinfnan(nv)); if (neg) nv = -nv; if (nv < UV_MAX) { @@ -11034,44 +11127,45 @@ S_F0convert(NV nv, char *const endbuf, STRLEN *const len) } -/* -=for apidoc sv_vcatpvfn - -=for apidoc sv_vcatpvfn_flags - -Processes its arguments like C<vsprintf> and appends the formatted output -to an SV. Uses an array of SVs if the C-style variable argument list is -missing (C<NULL>). Argument reordering (using format specifiers like C<%2$d> -or C<%*2$d>) is supported only when using an array of SVs; using a C-style -C<va_list> argument list with a format string that uses argument reordering -will yield an exception. - -When running with taint checks enabled, indicates via -C<maybe_tainted> if results are untrustworthy (often due to the use of -locales). - -If called as C<sv_vcatpvfn> or flags has the C<SV_GMAGIC> bit set, calls get magic. - -Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>. - -=cut -*/ - -#define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\ - vecstr = (U8*)SvPV_const(vecsv,veclen);\ - vec_utf8 = DO_UTF8(vecsv); - /* XXX maybe_tainted is never assigned to, so the doc above is lying. */ 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); } + +/* For the vcatpvfn code, we need a long double target in case + * HAS_LONG_DOUBLE, even without USE_LONG_DOUBLE, so that we can printf + * with long double formats, even without NV being long double. But we + * call the target 'fv' instead of 'nv', since most of the time it is not + * (most compilers these days recognize "long double", even if only as a + * synonym for "double"). +*/ +#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && \ + defined(PERL_PRIgldbl) && !defined(USE_QUADMATH) +# define VCATPVFN_FV_GF PERL_PRIgldbl +# if defined(__VMS) && defined(__ia64) && defined(__IEEE_FLOAT) + /* Work around breakage in OTS$CVT_FLOAT_T_X */ +# define VCATPVFN_NV_TO_FV(nv,fv) \ + STMT_START { \ + double _dv = nv; \ + fv = Perl_isnan(_dv) ? LDBL_QNAN : _dv; \ + } STMT_END +# else +# define VCATPVFN_NV_TO_FV(nv,fv) (fv)=(nv) +# endif + typedef long double vcatpvfn_long_double_t; +#else +# define VCATPVFN_FV_GF NVgf +# define VCATPVFN_NV_TO_FV(nv,fv) (fv)=(nv) + typedef NV vcatpvfn_long_double_t; +#endif + #ifdef LONGDOUBLE_DOUBLEDOUBLE /* The first double can be as large as 2**1023, or '1' x '0' x 1023. * The second double can be as small as 2**-1074, or '0' x 1073 . '1'. @@ -11121,7 +11215,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, # define HEXTRACT_MIX_ENDIAN #endif -/* S_hextract() is a helper for Perl_sv_vcatpvfn_flags, for extracting +/* S_hextract() is a helper for S_format_hexfp, for extracting * the hexadecimal values (for %a/%A). The nv is the NV where the value * are being extracted from (either directly from the long double in-memory * presentation, or from the uquad computed via frexp+ldexp). frexp also @@ -11203,6 +11297,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; @@ -11221,7 +11318,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: @@ -11231,7 +11328,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 / @@ -11331,9 +11428,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. */ @@ -11414,7 +11512,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 @@ -11432,40 +11530,355 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, return v; } -/* 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 + +/* S_format_hexfp(): helper function for Perl_sv_vcatpvfn_flags(). + * + * Processes the %a/%A hexadecimal floating-point format, since the + * built-in snprintf()s which are used for most of the f/p formats, don't + * universally handle %a/%A. + * Populates buf of length bufsize, and returns the length of the created + * string. + * The rest of the args have the same meaning as the local vars of the + * 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 +S_format_hexfp(pTHX_ char * const buf, const STRLEN bufsize, const char c, + const NV nv, const vcatpvfn_long_double_t fv, + bool has_precis, STRLEN precis, STRLEN width, + bool alt, char plus, bool left, bool fill) +{ + /* Hexadecimal floating point. */ + char* p = buf; + U8 vhex[VHEX_SIZE]; + U8* v = vhex; /* working pointer to vhex */ + U8* vend; /* pointer to one beyond last digit of vhex */ + U8* vfnz = NULL; /* first non-zero */ + U8* vlnz = NULL; /* last non-zero */ + U8* v0 = NULL; /* first output */ + const bool lower = (c == 'a'); + /* At output the values of vhex (up to vend) will + * be mapped through the xdig to get the actual + * human-readable xdigits. */ + const char* xdig = PL_hexdigit; + 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 */ + bool negative = FALSE; + STRLEN elen; + + /* XXX: NaN, Inf -- though they are printed as "NaN" and "Inf". + * + * For example with denormals, (assuming the vanilla + * 64-bit double): the exponent is zero. 1xp-1074 is + * the smallest denormal and the smallest double, it + * could be output also as 0x0.0000000000001p-1022 to + * match its internal structure. */ + + vend = S_hextract(aTHX_ nv, &exponent, &subnormal, vhex, NULL); + S_hextract(aTHX_ nv, &exponent, &subnormal, vhex, vend); + +#if NVSIZE > DOUBLESIZE +# ifdef HEXTRACT_HAS_IMPLICIT_BIT + /* In this case there is an implicit bit, + * and therefore the exponent is shifted by one. */ + exponent--; +# else +# ifdef 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() + * returned the scientific-style floating exponent. We want + * to map the last one as: + * -16831..-16384 -> -16382 (the last normal is 0x1p-16382) + * -16835..-16388 -> -16384 + * since we want to keep the first hexdigit + * as one of the [8421]. */ + exponent = -4 * ( (exponent + 1) / -4) - 2; + } else { + exponent -= 4; + } +# endif + /* TBD: other non-implicit-bit platforms than the x86-80. */ +# endif +#endif + + negative = fv < 0 || Perl_signbit(nv); + if (negative) + *p++ = '-'; + else if (plus) + *p++ = plus; + *p++ = '0'; + if (lower) { + *p++ = 'x'; + } + else { + *p++ = 'X'; + xdig += 16; /* Use uppercase hex. */ + } + + /* Find the first non-zero xdigit. */ + for (v = vhex; v < vend; v++) { + if (*v) { + vfnz = v; + break; + } + } + + if (vfnz) { + /* Find the last non-zero xdigit. */ + for (v = vend - 1; v >= vhex; v--) { + if (*v) { + vlnz = v; + break; + } + } + +#if NVSIZE == DOUBLESIZE + if (fv != 0.0) + exponent--; +#endif + + if (subnormal) { +#ifndef NV_X86_80_BIT + if (vfnz[0] > 1) { + /* IEEE 754 subnormals (but not the x86 80-bit): + * we want "normalize" the subnormal, + * so we need to right shift the hex nybbles + * so that the output of the subnormal starts + * from the first true bit. (Another, equally + * valid, policy would be to dump the subnormal + * nybbles as-is, to display the "physical" layout.) */ + int i, n; + U8 *vshr; + /* Find the ceil(log2(v[0])) of + * the top non-zero nybble. */ + for (i = vfnz[0], n = 0; i > 1; i >>= 1, n++) { } + assert(n < 4); + vlnz[1] = 0; + for (vshr = vlnz; vshr >= vfnz; vshr--) { + vshr[1] |= (vshr[0] & (0xF >> (4 - n))) << (4 - n); + vshr[0] >>= n; + } + if (vlnz[1]) { + vlnz++; + } + } +#endif + v0 = vfnz; + } else { + v0 = vhex; + } + + if (has_precis) { + U8* ve = (subnormal ? vlnz + 1 : vend); + SSize_t vn = ve - v0; + assert(vn >= 1); + if (precis < (Size_t)(vn - 1)) { + bool overflow = FALSE; + if (v0[precis + 1] < 0x8) { + /* Round down, nothing to do. */ + } else if (v0[precis + 1] > 0x8) { + /* Round up. */ + v0[precis]++; + overflow = v0[precis] > 0xF; + v0[precis] &= 0xF; + } else { /* v0[precis] == 0x8 */ + /* Half-point: round towards the one + * with the even least-significant digit: + * 08 -> 0 88 -> 8 + * 18 -> 2 98 -> a + * 28 -> 2 a8 -> a + * 38 -> 4 b8 -> c + * 48 -> 4 c8 -> c + * 58 -> 6 d8 -> e + * 68 -> 6 e8 -> e + * 78 -> 8 f8 -> 10 */ + if ((v0[precis] & 0x1)) { + v0[precis]++; + } + overflow = v0[precis] > 0xF; + v0[precis] &= 0xF; + } + + if (overflow) { + for (v = v0 + precis - 1; v >= v0; v--) { + (*v)++; + overflow = *v > 0xF; + (*v) &= 0xF; + if (!overflow) { + break; + } + } + if (v == v0 - 1 && overflow) { + /* If the overflow goes all the + * way to the front, we need to + * insert 0x1 in front, and adjust + * the exponent. */ + Move(v0, v0 + 1, vn - 1, char); + *v0 = 0x1; + exponent += 4; + } + } + + /* The new effective "last non zero". */ + vlnz = v0 + precis; + } + else { + zerotail = + subnormal ? precis - vn + 1 : + precis - (vlnz - vhex); + } + } + + v = v0; + *p++ = xdig[*v++]; + + /* If there are non-zero xdigits, the radix + * is output after the first one. */ + if (vfnz < vlnz) { + hexradix = TRUE; + } + } + else { + *p++ = '0'; + exponent = 0; + zerotail = precis; + } + + /* The radix is always output if precis, or if alt. */ + if (precis > 0 || alt) { + hexradix = TRUE; + } + + if (hexradix) { +#ifndef USE_LOCALE_NUMERIC + *p++ = '.'; +#else + if (PL_numeric_radix_sv) { + STRLEN n; + const char* r = SvPV(PL_numeric_radix_sv, n); + assert(IN_LC(LC_NUMERIC)); + Copy(r, p, n, char); + p += n; + } + else { + *p++ = '.'; + } +#endif + } + + if (vlnz) { + while (v <= vlnz) + *p++ = xdig[*v++]; + } + + if (zerotail > 0) { + while (zerotail--) { + *p++ = '0'; + } + } + + 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); + + if (elen < width) { + STRLEN gap = (STRLEN)(width - elen); + if (left) { + /* Pad the back with spaces. */ + memset(buf + elen, ' ', gap); + } + else if (fill) { + /* Insert the zeros after the "0x" and the + * the potential sign, but before the digits, + * otherwise we end up with "0000xH.HHH...", + * when we want "0x000H.HHH..." */ + STRLEN nzero = gap; + char* zerox = buf + 2; + STRLEN nmove = elen - 2; + if (negative || plus) { + zerox++; + nmove--; + } + Move(zerox, zerox + nzero, nmove, char); + memset(zerox, fill ? '0' : ' ', nzero); + } + else { + /* Move it to the right. */ + Move(buf, buf + gap, + elen, char); + /* Pad the front with spaces. */ + memset(buf, ' ', gap); + } + elen = width; + } + return elen; +} + + +/* +=for apidoc sv_vcatpvfn + +=for apidoc sv_vcatpvfn_flags + +Processes its arguments like C<vsprintf> and appends the formatted output +to an SV. Uses an array of SVs if the C-style variable argument list is +missing (C<NULL>). Argument reordering (using format specifiers like C<%2$d> +or C<%*2$d>) is supported only when using an array of SVs; using a C-style +C<va_list> argument list with a format string that uses argument reordering +will yield an exception. + +When running with taint checks enabled, indicates via +C<maybe_tainted> if results are untrustworthy (often due to the use of +locales). + +If called as C<sv_vcatpvfn> or flags has the C<SV_GMAGIC> bit set, calls get magic. + +It assumes that pat has the same utf8-ness as sv. It's the caller's +responsibility to ensure that this is so. + +Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>. + +=cut +*/ + 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. * 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? */ - bool hexfp = FALSE; /* hexadecimal floating point? */ - +#ifdef USE_LOCALE_NUMERIC DECLARATION_FOR_LC_NUMERIC_MANIPULATION; + bool lc_numeric_set = FALSE; /* called STORE_LC_NUMERIC_SET_TO_NEEDED? */ +#endif PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS; PERL_UNUSED_ARG(maybe_tainted); @@ -11476,182 +11889,131 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* no matter what, this is a string now */ (void)SvPV_force_nomg(sv, origlen); - /* 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()"); + /* the code that scans for flags etc following a % relies on + * a '\0' being present to avoid falling off the end. Ideally that + * should be fixed */ + assert(pat[patlen] == '\0'); - 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 (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; + } + + /* "%-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 "%.<number>[gf]" */ - if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.' - && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) { - unsigned digits = 0; - const char *pp; - - pp = pat + 2; - while (*pp >= '0' && *pp <= '9') - digits = 10 * digits + (*pp++ - '0'); - - /* XXX: Why do this `svix < svmax` test? Couldn't we just - format the first argument and WARN_REDUNDANT if svmax > 1? - Munged by Nicholas Clark in v5.13.0-209-g95ea86d */ - if (pp - pat == (int)patlen - 1 && svix < svmax) { - const NV nv = SvNV(*svargs); + /* 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))) { - if (*pp == 'g') { - /* Add check for digits != 0 because it seems that some - gconverts are buggy in this case, and we don't yet have - a Configure test for this. */ - if (digits && digits < sizeof(ebuf) - NV_DIG - 10) { - /* 0, point, slack */ - STORE_LC_NUMERIC_SET_TO_NEEDED(); - SNPRINTF_G(nv, ebuf, size, digits); - sv_catpv_nomg(sv, ebuf); - if (*ebuf) /* May return an empty string for digits==0 */ - return; - } - } else if (!digits) { - STRLEN l; + STRLEN l; + char *p; - if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) { - sv_catpvn_nomg(sv, p, l); - return; - } + if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) { + sv_catpvn_nomg(sv, p, l); + return; } } - } - } + } #endif /* !USE_LONG_DOUBLE */ + } - if (!args && svix < svmax && DO_UTF8(*svargs)) - has_utf8 = TRUE; patend = (char*)pat + patlen; - for (p = (char*)pat; p < patend; p = q) { - bool alt = FALSE; - bool left = FALSE; - bool vectorize = FALSE; - bool vectorarg = FALSE; - bool vec_utf8 = FALSE; - char fill = ' '; - char plus = 0; - char intsize = 0; - STRLEN width = 0; - STRLEN zeros = 0; - bool has_precis = FALSE; - STRLEN precis = 0; - const I32 osvix = svix; - bool is_utf8 = FALSE; /* is this item utf8? */ - bool used_explicit_ix = FALSE; - bool arg_missing = FALSE; -#ifdef HAS_LDBL_SPRINTF_BUG - /* This is to try to fix a bug with irix/nonstop-ux/powerux and - with sfio - Allen <[email protected]> */ - bool fix_ldbl_sprintf_bug = FALSE; -#endif + for (fmtstart = pat; fmtstart < patend; fmtstart = q) { + char intsize = 0; /* size qualifier in "%hi..." etc */ + bool alt = FALSE; /* has "%#..." */ + bool left = FALSE; /* has "%-..." */ + bool fill = FALSE; /* has "%0..." */ + char plus = 0; /* has "%+..." */ + STRLEN width = 0; /* value of "%NNN..." */ + bool has_precis = FALSE; /* has "%.NNN..." */ + STRLEN precis = 0; /* value of "%.NNN..." */ + 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..." */ + 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 */ + + Size_t efix = 0; /* explicit format parameter index */ + const Size_t osvix = svix; /* original index in case of bad fmt */ + + 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" */ + STRLEN esignlen = 0; /* length of e.g. "-0x" */ + STRLEN zeros = 0; /* how many '0' to prepend */ + + const char *eptr = NULL; /* the address of the element string */ + STRLEN elen = 0; /* the length of the element string */ + + char c; /* the actual format ('d', s' etc) */ - char esignbuf[4]; - U8 utf8buf[UTF8_MAXBYTES+1]; - STRLEN esignlen = 0; - - const char *eptr = NULL; - const char *fmtstart; - STRLEN elen = 0; - SV *vecsv = NULL; - const U8 *vecstr = NULL; - STRLEN veclen = 0; - char c = 0; - int i; - unsigned base = 0; - IV iv = 0; - UV uv = 0; - /* We need a long double target in case HAS_LONG_DOUBLE, - * even without USE_LONG_DOUBLE, so that we can printf with - * long double formats, even without NV being long double. - * But we call the target 'fv' instead of 'nv', since most of - * the time it is not (most compilers these days recognize - * "long double", even if only as a synonym for "double"). - */ -#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && \ - defined(PERL_PRIgldbl) && !defined(USE_QUADMATH) - long double fv; -# ifdef Perl_isfinitel -# define FV_ISFINITE(x) Perl_isfinitel(x) -# endif -# define FV_GF PERL_PRIgldbl -# if defined(__VMS) && defined(__ia64) && defined(__IEEE_FLOAT) - /* Work around breakage in OTS$CVT_FLOAT_T_X */ -# define NV_TO_FV(nv,fv) STMT_START { \ - double _dv = nv; \ - fv = Perl_isnan(_dv) ? LDBL_QNAN : _dv; \ - } STMT_END -# else -# define NV_TO_FV(nv,fv) (fv)=(nv) -# endif -#else - NV fv; -# define FV_GF NVgf -# define NV_TO_FV(nv,fv) (fv)=(nv) -#endif -#ifndef FV_ISFINITE -# define FV_ISFINITE(x) Perl_isfinite((NV)(x)) -#endif - NV nv; - STRLEN have; - STRLEN need; - STRLEN gap; - const char *dotstr = "."; - STRLEN dotstrlen = 1; - I32 efix = 0; /* explicit format parameter index */ - I32 ewix = 0; /* explicit width index */ - I32 epix = 0; /* explicit precision index */ - I32 evix = 0; /* explicit vector index */ - bool asterisk = FALSE; - bool infnan = FALSE; /* 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: @@ -11665,85 +12027,16 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p [%bcdefginopsuxDFOUX] format (mandatory) */ - if (args) { -/* - As of perl5.9.3, printf format checking is on by default. - Internally, perl uses %p formats to provide an escape to - some extended formatting. This block deals with those - extensions: if it does not match, (char*)q is reset and - the normal format processing code is used. - - Currently defined extensions are: - %p include pointer address (standard) - %-p (SVf) include an SV (previously %_) - %-<num>p include an SV with precision <num> - %2p include a HEK - %3p include a HEK with precision of 256 - %4p char* preceded by utf8 flag and length - %<num>p (where num is 1 or > 4) reserved for future - extensions - - Robin Barker 2005-07-14 (but modified since) - - %1p (VDf) removed. RMB 2007-10-19 -*/ - char* r = q; - bool sv = FALSE; - STRLEN n = 0; - if (*q == '-') - sv = *q++; - else if (strnEQ(q, UTF8f, sizeof(UTF8f)-1)) { /* UTF8f */ - /* The argument has already gone through cBOOL, so the cast - is safe. */ - is_utf8 = (bool)va_arg(*args, int); - elen = va_arg(*args, UV); - /* if utf8 length is larger than 0x7ffff..., then it might - * have been a signed value that wrapped */ - if (elen > ((~(STRLEN)0) >> 1)) { - assert(0); /* in DEBUGGING build we want to crash */ - elen= 0; /* otherwise we want to treat this as an empty string */ - } - eptr = va_arg(*args, char *); - q += sizeof(UTF8f)-1; - goto string; - } - n = expect_number(&q); - if (*q++ == 'p') { - if (sv) { /* SVf */ - if (n) { - precis = n; - has_precis = TRUE; - } - argsv = MUTABLE_SV(va_arg(*args, void*)); - eptr = SvPV_const(argsv, elen); - if (DO_UTF8(argsv)) - is_utf8 = TRUE; - goto string; - } - else if (n==2 || n==3) { /* HEKf */ - HEK * const hek = va_arg(*args, HEK *); - eptr = HEK_KEY(hek); - elen = HEK_LEN(hek); - if (HEK_UTF8(hek)) is_utf8 = TRUE; - if (n==3) precis = 256, has_precis = TRUE; - goto string; - } - else if (n) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "internal %%<num>p might conflict with future printf extensions"); - } - } - q = r; - } - - if ( (width = expect_number(&q)) ) { + if (IS_1_TO_9(*q)) { + width = expect_number(&q); if (*q == '$') { if (args) Perl_croak_nocontext( "Cannot yet reorder sv_catpvfn() arguments from va_list"); ++q; - efix = width; - used_explicit_ix = TRUE; + efix = (Size_t)width; + width = 0; + no_redundant_warning = TRUE; } else { goto gotwidth; } @@ -11767,7 +12060,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p continue; case '0': - fill = *q++; + fill = TRUE; + q++; continue; case '#': @@ -11781,73 +12075,102 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p break; } + /* at this point we can expect one of: + * + * 123 an explicit width + * * width taken from next arg + * *12$ width taken from 12th arg + * or no width + * + * But any width specification may be preceded by a v, in one of its + * forms: + * v + * *v + * *12$v + * So an asterisk may be either a width specifier or a vector + * separator arg specifier, and we don't know which initially + */ + tryasterisk: if (*q == '*') { + STRLEN ix; /* explicit width/vector separator index */ q++; - if ( (ewix = expect_number(&q)) ) { + if (IS_1_TO_9(*q)) { + ix = expect_number(&q); if (*q++ == '$') { 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; } - asterisk = TRUE; - } - if (*q == 'v') { + else + ix = 0; + + if (*q == 'v') { + SV *vecsv; + /* The asterisk was for *v, *NNN$v: vectorizing, but not + * with the default "." */ + q++; + if (vectorize) + goto unknown; + if (args) + vecsv = va_arg(*args, SV*); + 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 + 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; + } + vectorize = TRUE; + goto tryasterisk; + } + + /* the asterisk specified a width */ + { + 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++; if (vectorize) goto unknown; - if ((vectorarg = asterisk)) { - evix = ewix; - ewix = 0; - asterisk = FALSE; - } vectorize = TRUE; - goto tryasterisk; - } - - if (!asterisk) - { - if( *q == '0' ) - fill = *q++; - width = expect_number(&q); - } + dotstr = "."; + dotstrlen = 1; + goto tryasterisk; - if (vectorize && vectorarg) { - /* vectorizing, but not with the default "." */ - if (args) - vecsv = va_arg(*args, SV*); - else if (evix) { - FETCH_VCATPVFN_ARGUMENT( - vecsv, evix > 0 && evix <= svmax, svargs[evix-1]); - } else { - FETCH_VCATPVFN_ARGUMENT( - vecsv, svix < svmax, svargs[svix++]); - } - 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; - } + } + else { + /* explicit width? */ + if(*q == '0') { + fill = TRUE; + q++; + } + if (IS_1_TO_9(*q)) + width = expect_number(&q); } - if (asterisk) { - if (args) - i = va_arg(*args, int); - else - i = (ewix ? ewix <= svmax : svix < svmax) ? - SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0; - left |= (i < 0); - width = (i < 0) ? -i : i; - } gotwidth: /* PRECISION */ @@ -11855,72 +12178,52 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (*q == '.') { q++; if (*q == '*') { + STRLEN ix; /* explicit precision index */ q++; - if ( (epix = expect_number(&q)) ) { + if (IS_1_TO_9(*q)) { + ix = expect_number(&q); if (*q++ == '$') { 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; } - if (args) - i = va_arg(*args, int); - else { - SV *precsv; - if (epix) - FETCH_VCATPVFN_ARGUMENT( - precsv, epix > 0 && epix <= svmax, svargs[epix-1]); - else - FETCH_VCATPVFN_ARGUMENT( - precsv, svix < svmax, svargs[svix++]); - i = precsv == &PL_sv_no ? 0 : SvIVx(precsv); + else + ix = 0; + + { + 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; } } - if (vectorize) { - if (args) { - VECTORIZE_ARGS - } - 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; - } - } - /* SIZE */ switch (*q) { @@ -11990,63 +12293,35 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* CONVERSION */ - if (*q == '%') { - eptr = q++; + c = *q++; /* c now holds the conversion type */ + + /* '%' doesn't have an arg, so skip arg processing */ + if (c == '%') { + eptr = q - 1; elen = 1; - if (vectorize) { - c = '%'; + if (vectorize) goto unknown; - } goto string; } - if (!vectorize && !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 (vectorize && !strchr("BbDdiOouUXx", c)) + goto unknown; + + /* get next arg (individual branches do their own va_arg() + * handling for the args case) */ + + if (!args) { + efix = efix ? efix - 1 : svix++; + argsv = efix < sv_count ? svargs[efix] + : (arg_missing = TRUE, &PL_sv_no); } - if (argsv && strchr("BbcDdiOopuUXx",*q)) { - /* XXX va_arg(*args) case? need peek, use va_copy? */ - SvGETMAGIC(argsv); - if (UNLIKELY(SvAMAGIC(argsv))) - argsv = sv_2num(argsv); - infnan = UNLIKELY(isinfnansv(argsv)); - } - switch (c = *q++) { + switch (c) { /* STRINGS */ - case 'c': - if (vectorize) - goto unknown; - if (infnan) - Perl_croak(aTHX_ "Cannot printf %" NVgf " with '%c'", - /* no va_arg() case */ - SvNV_nomg(argsv), (int)c); - uv = (args) ? va_arg(*args, int) : SvIV_nomg(argsv); - if ((uv > 255 || - (!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv))) - && !IN_BYTES) { - eptr = (char*)utf8buf; - elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf; - is_utf8 = TRUE; - } - else { - c = (char)uv; - eptr = &c; - elen = 1; - } - goto string; - case 's': - if (vectorize) - goto unknown; if (args) { eptr = va_arg(*args, char*); if (eptr) @@ -12085,14 +12360,99 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* INTEGERS */ case 'p': - if (infnan) { - goto floating_point; - } - if (alt || vectorize) + if (alt) goto unknown; + + /* %p extensions: + * + * "%...p" is normally treated like "%...x", except that the + * number to print is the SV's address (or a pointer address + * for C-ish sprintf). + * + * However, the C-ish sprintf variant allows a few special + * extensions. These are currently: + * + * %-p (SVf) Like %s, but gets the string from an SV* + * arg rather than a char* arg. + * (This was previously %_). + * + * %-<num>p Ditto but like %.<num>s (i.e. num is max width) + * + * %2p (HEKf) Like %s, but using the key string in a HEK + * + * %3p (HEKf256) Ditto but like %.256s + * + * %d%lu%4p (UTF8f) A utf8 string. Consumes 3 args: + * (cBOOL(utf8), len, string_buf). + * It's handled by the "case 'd'" branch + * rather than here. + * + * %<num>p where num is 1 or > 4: reserved for future + * extensions. Warns, but then is treated as a + * general %p (print hex address) format. + */ + + if ( args + && !intsize + && !fill + && !plus + && !has_precis + /* not %*p or %*1$p - any width was explicit */ + && q[-2] != '*' + && q[-2] != '$' + ) { + if (left) { /* %-p (SVf), %-NNNp */ + if (width) { + precis = width; + has_precis = TRUE; + } + argsv = MUTABLE_SV(va_arg(*args, void*)); + eptr = SvPV_const(argsv, elen); + if (DO_UTF8(argsv)) + is_utf8 = TRUE; + width = 0; + goto string; + } + else if (width == 2 || width == 3) { /* HEKf, HEKf256 */ + HEK * const hek = va_arg(*args, HEK *); + eptr = HEK_KEY(hek); + elen = HEK_LEN(hek); + if (HEK_UTF8(hek)) + is_utf8 = TRUE; + if (width == 3) { + precis = 256; + has_precis = TRUE; + } + width = 0; + goto string; + } + else if (width) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "internal %%<num>p might conflict with future printf extensions"); + } + } + + /* treat as normal %...p */ + uv = PTR2UV(args ? va_arg(*args, void*) : argsv); base = 16; - goto integer; + goto do_integer; + + case 'c': + /* Ignore any size specifiers, since they're not documented as + * being allowed for %c (ideally we should warn on e.g. '%hc'). + * Setting a default intsize, along with a positive + * (which signals unsigned) base, causes, for C-ish use, the + * va_arg to be interpreted as as unsigned int, when it's + * actually signed, which will convert -ve values to high +ve + * values. Note that unlike the libc %c, values > 255 will + * convert to high unicode points rather than being truncated + * to 8 bits. For perlish use, it will do SvUV(argsv), which + * will again convert -ve args to high -ve values. + */ + intsize = 0; + base = 1; /* special value that indicates we're doing a 'c' */ + goto get_int_arg_val; case 'D': #ifdef IV_IS_QUAD @@ -12100,80 +12460,42 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #else intsize = 'l'; #endif - /* FALLTHROUGH */ + base = -10; + goto get_int_arg_val; + case 'd': - case 'i': - if (infnan) { - goto floating_point; - } - if (vectorize) { - STRLEN ulen; - if (!veclen) - goto donevalidconversion; - if (vec_utf8) - uv = utf8n_to_uvchr(vecstr, veclen, &ulen, - UTF8_ALLOW_ANYUV); - else { - uv = *vecstr; - ulen = 1; - } - vecstr += ulen; - veclen -= ulen; - if (plus) - esignbuf[esignlen++] = plus; - } - else if (args) { - switch (intsize) { - case 'c': iv = (char)va_arg(*args, int); break; - case 'h': iv = (short)va_arg(*args, int); break; - case 'l': iv = va_arg(*args, long); break; - case 'V': iv = va_arg(*args, IV); break; - case 'z': iv = va_arg(*args, SSize_t); break; -#ifdef HAS_PTRDIFF_T - 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 'q': -#if IVSIZE >= 8 - iv = va_arg(*args, Quad_t); break; -#else - goto unknown; -#endif - } - } - else { - IV tiv = SvIV_nomg(argsv); /* work around GCC bug #13488 */ - switch (intsize) { - case 'c': iv = (char)tiv; break; - case 'h': iv = (short)tiv; break; - case 'l': iv = (long)tiv; break; - case 'V': - default: iv = tiv; break; - case 'q': -#if IVSIZE >= 8 - iv = (Quad_t)tiv; break; -#else - goto unknown; -#endif - } - } - if ( !vectorize ) /* we already set uv above */ - { - if (iv >= 0) { - uv = iv; - if (plus) - esignbuf[esignlen++] = plus; - } - else { - uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv); - esignbuf[esignlen++] = '-'; - } + /* probably just a plain %d, but it might be the start of the + * special UTF8f format, which usually looks something like + * "%d%lu%4p" (the lu may vary by platform) + */ + assert((UTF8f)[0] == 'd'); + assert((UTF8f)[1] == '%'); + + if ( args /* UTF8f only valid for C-ish sprintf */ + && q == fmtstart + 1 /* plain %d, not %....d */ + && patend >= fmtstart + sizeof(UTF8f) - 1 /* long enough */ + && *q == '%' + && strnEQ(q + 1, UTF8f + 2, sizeof(UTF8f) - 3)) + { + /* The argument has already gone through cBOOL, so the cast + is safe. */ + is_utf8 = (bool)va_arg(*args, int); + elen = va_arg(*args, UV); + /* if utf8 length is larger than 0x7ffff..., then it might + * have been a signed value that wrapped */ + if (elen > ((~(STRLEN)0) >> 1)) { + assert(0); /* in DEBUGGING build we want to crash */ + elen = 0; /* otherwise we want to treat this as an empty string */ + } + eptr = va_arg(*args, char *); + q += sizeof(UTF8f) - 2; + goto string; } - base = 10; - goto integer; + + /* FALLTHROUGH */ + case 'i': + base = -10; + goto get_int_arg_val; case 'U': #ifdef IV_IS_QUAD @@ -12184,12 +12506,12 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* FALLTHROUGH */ case 'u': base = 10; - goto uns_integer; + goto get_int_arg_val; case 'B': case 'b': base = 2; - goto uns_integer; + goto get_int_arg_val; case 'O': #ifdef IV_IS_QUAD @@ -12200,21 +12522,53 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* FALLTHROUGH */ case 'o': base = 8; - goto uns_integer; + goto get_int_arg_val; case 'X': case 'x': base = 16; - uns_integer: - if (infnan) { - goto floating_point; - } + get_int_arg_val: + if (vectorize) { STRLEN ulen; - vector: + SV *vecsv; + + if (base < 0) { + base = -base; + if (plus) + 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); @@ -12225,64 +12579,145 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p vecstr += ulen; veclen -= ulen; } - else if (args) { - switch (intsize) { - case 'c': uv = (unsigned char)va_arg(*args, unsigned); break; - case 'h': uv = (unsigned short)va_arg(*args, unsigned); break; - case 'l': uv = va_arg(*args, unsigned long); break; - case 'V': uv = va_arg(*args, UV); break; - case 'z': uv = va_arg(*args, Size_t); break; + else { + /* test arg for inf/nan. This can trigger an unwanted + * 'str' overload, so manually force 'num' overload first + * if necessary */ + if (argsv) { + SvGETMAGIC(argsv); + if (UNLIKELY(SvAMAGIC(argsv))) + argsv = sv_2num(argsv); + if (UNLIKELY(isinfnansv(argsv))) + goto handle_infnan_argsv; + } + + if (base < 0) { + /* signed int type */ + IV iv; + base = -base; + if (args) { + switch (intsize) { + case 'c': iv = (char)va_arg(*args, int); break; + case 'h': iv = (short)va_arg(*args, int); break; + case 'l': iv = va_arg(*args, long); break; + case 'V': iv = va_arg(*args, IV); break; + case 'z': iv = va_arg(*args, SSize_t); break; #ifdef HAS_PTRDIFF_T - case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */ + case 't': iv = va_arg(*args, ptrdiff_t); break; #endif + default: iv = va_arg(*args, int); break; #ifdef I_STDINT - case 'j': uv = va_arg(*args, uintmax_t); break; + case 'j': iv = va_arg(*args, intmax_t); break; #endif - default: uv = va_arg(*args, unsigned); break; - case 'q': + case 'q': #if IVSIZE >= 8 - uv = va_arg(*args, Uquad_t); break; + iv = va_arg(*args, Quad_t); break; #else - goto unknown; + goto unknown; #endif - } - } - else { - UV tuv = SvUV_nomg(argsv); /* work around GCC bug #13488 */ - switch (intsize) { - case 'c': uv = (unsigned char)tuv; break; - case 'h': uv = (unsigned short)tuv; break; - case 'l': uv = (unsigned long)tuv; break; - case 'V': - default: uv = tuv; break; - case 'q': + } + } + else { + /* 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; + case 'l': iv = (long)tiv; break; + case 'V': + default: iv = tiv; break; + case 'q': #if IVSIZE >= 8 - uv = (Uquad_t)tuv; break; + iv = (Quad_t)tiv; break; #else - goto unknown; + goto unknown; #endif - } - } + } + } - integer: + /* now convert iv to uv */ + if (iv >= 0) { + uv = iv; + if (plus) + esignbuf[esignlen++] = plus; + } + else { + uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv); + esignbuf[esignlen++] = '-'; + } + } + else { + /* unsigned int type */ + if (args) { + switch (intsize) { + case 'c': uv = (unsigned char)va_arg(*args, unsigned); + break; + case 'h': uv = (unsigned short)va_arg(*args, unsigned); + break; + case 'l': uv = va_arg(*args, unsigned long); break; + case 'V': uv = va_arg(*args, UV); break; + case 'z': uv = va_arg(*args, Size_t); break; +#ifdef HAS_PTRDIFF_T + /* will sign extend, but there is no + * 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 + default: uv = va_arg(*args, unsigned); break; + case 'q': +#if IVSIZE >= 8 + uv = va_arg(*args, Uquad_t); break; +#else + goto unknown; +#endif + } + } + else { + /* 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; + case 'l': uv = (unsigned long)tuv; break; + case 'V': + default: uv = tuv; break; + case 'q': +#if IVSIZE >= 8 + uv = (Uquad_t)tuv; break; +#else + goto unknown; +#endif **** PATCH TRUNCATED AT 2000 LINES -- 1641 NOT SHOWN **** -- Perl5 Master Repository
