In perl.git, the branch blead has been updated <https://perl5.git.perl.org/perl.git/commitdiff/d8fb0a68932bdb9b3896fb7811a6a5aff0a8d5b8?hp=1159483a303d3acd96053c88ea1bbf1fd4cf8196>
- Log ----------------------------------------------------------------- commit d8fb0a68932bdb9b3896fb7811a6a5aff0a8d5b8 Author: Karl Williamson <[email protected]> Date: Wed Nov 8 20:18:10 2017 -0700 Bump version of B/t/OptreeCheck to 0.16 commit 2ac5cb3d95aef19c0451b99cd61a1b979dacd58f Author: Karl Williamson <[email protected]> Date: Wed Nov 8 20:16:34 2017 -0700 Bump version of B/O.pm to 1.03 commit 11b2cef65dac01e8723c9a6f6e640665cb752a2c Author: Karl Williamson <[email protected]> Date: Mon Aug 28 17:16:27 2017 -0600 perl.h: Use STMT_START { ... } STMT_END This should be used in macros that have statements. commit 80752aac697a5e8f04103d8ee4733d099239403a Author: Karl Williamson <[email protected]> Date: Mon Aug 28 17:11:29 2017 -0600 perl.h: White-space only Indent some nested #defines, remove an extra empty line commit cb9da808be7106e6164fb99580a0466145b3cfe8 Author: Karl Williamson <[email protected]> Date: Thu Aug 10 16:03:16 2017 -0600 toke.c: Add comment commit 624504c5a60da0880a7d1d6d3e66f65c68ba28ae Author: Karl Williamson <[email protected]> Date: Thu Aug 10 15:52:35 2017 -0600 Dest buffer needs to be bigger for utf16_to_utf8() These undocumented functions require the destination buffer to have the worst case size. However that size (previously listed as 3/2 * input) is wrong for EBCDIC. Correct the comments, and the single use of these in core. These functions do not have a way to avoid overflowing, which strikes me as wrong. commit 63ab03b3966fa7dcc24a137305becdb56bbf4e5a Author: Karl Williamson <[email protected]> Date: Thu Aug 10 14:33:40 2017 -0600 _byte_dump_string(): Don't output leading space This changes this function to not put an initial space character in the returned string. commit 604d7733597968dd3d3b15a0c50861ee7ade3f96 Author: Karl Williamson <[email protected]> Date: Thu Aug 10 21:39:06 2017 -0600 POSIX.xs: Move constant tests out of loop Whether or not a locale is in UTF-8 doesn't change in this loop; calculate it once, prior to the loop commit 9eda1ea6670ffea7d0f59d985c0ad45d7b53cdb8 Author: Karl Williamson <[email protected]> Date: Tue Aug 1 12:41:12 2017 -0600 numeric.c: Refactor #if #else in Perl_my_aotf This simplifies things, eliminating nested #if's commit 1ae85f6c8d94d4c819717d5024cbdbe30cd7d8f1 Author: Karl Williamson <[email protected]> Date: Tue Aug 1 12:38:09 2017 -0600 numeric.c: Rename some variables The new names are clearer. ----------------------------------------------------------------------- Summary of changes: embed.fnc | 2 +- ext/B/O.pm | 2 +- ext/B/t/OptreeCheck.pm | 2 +- ext/POSIX/POSIX.xs | 44 +++++++++++++++++++++++----------- ext/XS-APItest/APItest.xs | 2 +- numeric.c | 25 ++++++++++++------- perl.h | 61 ++++++++++++++++++++++++----------------------- proto.h | 4 ++-- toke.c | 7 +++++- utf8.c | 28 +++++++++++++++------- 10 files changed, 110 insertions(+), 67 deletions(-) diff --git a/embed.fnc b/embed.fnc index 527e476f7a..edd6659104 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1720,7 +1720,7 @@ EXMp |void |_invlist_dump |NN PerlIO *file|I32 level \ Ap |void |taint_env Ap |void |taint_proper |NULLOK const char* f|NN const char *const s EpM |char * |_byte_dump_string \ - |NN const U8 * s \ + |NN const U8 * const start \ |const STRLEN len \ |const bool format #if defined(PERL_IN_UTF8_C) diff --git a/ext/B/O.pm b/ext/B/O.pm index 09a905eaee..81c879835b 100644 --- a/ext/B/O.pm +++ b/ext/B/O.pm @@ -1,6 +1,6 @@ package O; -our $VERSION = '1.02'; +our $VERSION = '1.03'; use B (); diff --git a/ext/B/t/OptreeCheck.pm b/ext/B/t/OptreeCheck.pm index 34d01e1532..b1d23ce0ea 100644 --- a/ext/B/t/OptreeCheck.pm +++ b/ext/B/t/OptreeCheck.pm @@ -5,7 +5,7 @@ use warnings; use vars qw($TODO $Level $using_open); require "test.pl"; -our $VERSION = '0.15'; +our $VERSION = '0.16'; # now export checkOptree, and those test.pl functions used by tests our @EXPORT = qw( checkOptree plan skip skip_all pass is like unlike diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index f4a93290ce..047a84f61d 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -2124,14 +2124,29 @@ localeconv() #else struct lconv *lcbuf; + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; + /* localeconv() deals with both LC_NUMERIC and LC_MONETARY, but * LC_MONETARY is already in the correct locale */ - DECLARATION_FOR_LC_NUMERIC_MANIPULATION; +# ifdef USE_LOCALE_MONETARY + + const bool is_monetary_utf8 = _is_cur_LC_category_utf8(LC_MONETARY); +# endif +# ifdef USE_LOCALE_NUMERIC + + bool is_numeric_utf8; + STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); + is_numeric_utf8 = _is_cur_LC_category_utf8(LC_NUMERIC); +# endif + RETVAL = newHV(); sv_2mortal((SV*)RETVAL); - if ((lcbuf = localeconv())) { + + lcbuf = localeconv(); + + if (lcbuf) { const struct lconv_offset *strings = lconv_strings; const struct lconv_offset *integers = lconv_integers; const char *ptr = (const char *) lcbuf; @@ -2139,18 +2154,18 @@ localeconv() while (strings->name) { /* This string may be controlled by either LC_NUMERIC, or * LC_MONETARY */ - bool is_utf8_locale -#if defined(USE_LOCALE_NUMERIC) && defined(USE_LOCALE_MONETARY) - = _is_cur_LC_category_utf8((isLC_NUMERIC_STRING(strings->name)) - ? LC_NUMERIC - : LC_MONETARY); -#elif defined(USE_LOCALE_NUMERIC) - = _is_cur_LC_category_utf8(LC_NUMERIC); -#elif defined(USE_LOCALE_MONETARY) - = _is_cur_LC_category_utf8(LC_MONETARY); -#else - = FALSE; -#endif + const bool is_utf8_locale = +# if defined(USE_LOCALE_NUMERIC) && defined(USE_LOCALE_MONETARY) + (isLC_NUMERIC_STRING(strings->name)) + ? is_numeric_utf8 + : is_monetary_utf8; +# elif defined(USE_LOCALE_NUMERIC) + is_numeric_utf8; +# elif defined(USE_LOCALE_MONETARY) + is_monetary_utf8; +# else + FALSE; +# endif const char *value = *((const char **)(ptr + strings->offset)); @@ -2181,6 +2196,7 @@ localeconv() integers++; } } + RESTORE_LC_NUMERIC_STANDARD(); #endif /* HAS_LOCALECONV */ OUTPUT: diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 99a3957e6c..ffdc56c38e 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -2885,7 +2885,7 @@ utf16_to_utf8 (sv, ...) len = SvUV(ST(1)); } /* Mortalise this right now, as we'll be testing croak()s */ - dest = sv_2mortal(newSV(len * 3 / 2 + 1)); + dest = sv_2mortal(newSV(len * 2 + 1)); if (ix) { utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got); } else { diff --git a/numeric.c b/numeric.c index 7514b748ff..7065486497 100644 --- a/numeric.c +++ b/numeric.c @@ -1212,11 +1212,18 @@ Perl_my_atof(pTHX_ const char* s) /* 's' must be NUL terminated */ NV x = 0.0; + + PERL_ARGS_ASSERT_MY_ATOF; + #ifdef USE_QUADMATH + Perl_my_atof2(aTHX_ s, &x); - return x; -#elif defined(USE_LOCALE_NUMERIC) - PERL_ARGS_ASSERT_MY_ATOF; + +#elif ! defined(USE_LOCALE_NUMERIC) + + Perl_atof2(s, x); + +#else { DECLARATION_FOR_LC_NUMERIC_MANIPULATION; @@ -1229,9 +1236,11 @@ Perl_my_atof(pTHX_ const char* s) * that we have to determine this beforehand because on some * systems, Perl_atof2 is just a wrapper around the system's atof. * */ - const char * const standard = strchr(s, '.'); - const char * const local = strstr(s, SvPV_nolen(PL_numeric_radix_sv)); - const bool use_standard_radix = standard && (!local || standard < local); + const char * const standard_pos = strchr(s, '.'); + const char * const local_pos + = strstr(s, SvPV_nolen(PL_numeric_radix_sv)); + const bool use_standard_radix + = standard_pos && (!local_pos || standard_pos < local_pos); if (use_standard_radix) SET_NUMERIC_STANDARD(); @@ -1245,9 +1254,9 @@ Perl_my_atof(pTHX_ const char* s) Perl_atof2(s, x); RESTORE_LC_NUMERIC(); } -#else - Perl_atof2(s, x); + #endif + return x; } diff --git a/perl.h b/perl.h index 44b9805f83..1e4f8bc4d1 100644 --- a/perl.h +++ b/perl.h @@ -5556,7 +5556,6 @@ typedef struct am_table_short AMTS; } STMT_END # endif /* PERL_CORE or PERL_IN_XSUB_RE */ - #else /* No locale usage */ # define LOCALE_INIT # define LOCALE_TERM @@ -5677,18 +5676,18 @@ expression, but with an empty argument list, like this: */ -#define _NOT_IN_NUMERIC_STANDARD (! PL_numeric_standard) +# define _NOT_IN_NUMERIC_STANDARD (! PL_numeric_standard) /* We can lock the category to stay in the C locale, making requests to the * contrary be noops, in the dynamic scope by setting PL_numeric_standard to 2. * */ -#define _NOT_IN_NUMERIC_UNDERLYING \ +# define _NOT_IN_NUMERIC_UNDERLYING \ (! PL_numeric_local && PL_numeric_standard < 2) -#define DECLARATION_FOR_LC_NUMERIC_MANIPULATION \ +# define DECLARATION_FOR_LC_NUMERIC_MANIPULATION \ void (*_restore_LC_NUMERIC_function)(pTHX) = NULL -#define STORE_LC_NUMERIC_SET_TO_NEEDED() \ +# define STORE_LC_NUMERIC_SET_TO_NEEDED() \ if (IN_LC(LC_NUMERIC)) { \ if (_NOT_IN_NUMERIC_UNDERLYING) { \ Perl_set_numeric_local(aTHX); \ @@ -5702,38 +5701,38 @@ expression, but with an empty argument list, like this: } \ } -#define RESTORE_LC_NUMERIC() \ +# define RESTORE_LC_NUMERIC() \ if (_restore_LC_NUMERIC_function) { \ _restore_LC_NUMERIC_function(aTHX); \ } /* The next two macros set unconditionally. These should be rarely used, and * only after being sure that this is what is needed */ -#define SET_NUMERIC_STANDARD() \ +# define SET_NUMERIC_STANDARD() \ STMT_START { if (_NOT_IN_NUMERIC_STANDARD) \ Perl_set_numeric_standard(aTHX); \ } STMT_END -#define SET_NUMERIC_UNDERLYING() \ +# define SET_NUMERIC_UNDERLYING() \ STMT_START { if (_NOT_IN_NUMERIC_UNDERLYING) \ Perl_set_numeric_local(aTHX); } STMT_END /* The rest of these LC_NUMERIC macros toggle to one or the other state, with * the RESTORE_foo ones called to switch back, but only if need be */ -#define STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD() \ +# define STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD() \ bool _was_local = _NOT_IN_NUMERIC_STANDARD; \ if (_was_local) Perl_set_numeric_standard(aTHX); /* Doesn't change to underlying locale unless within the scope of some form of * 'use locale'. This is the usual desired behavior. */ -#define STORE_LC_NUMERIC_STANDARD_SET_UNDERLYING() \ +# define STORE_LC_NUMERIC_STANDARD_SET_UNDERLYING() \ bool _was_standard = _NOT_IN_NUMERIC_UNDERLYING \ && IN_LC(LC_NUMERIC); \ if (_was_standard) Perl_set_numeric_local(aTHX); /* Rarely, we want to change to the underlying locale even outside of 'use * locale'. This is principally in the POSIX:: functions */ -#define STORE_LC_NUMERIC_FORCE_TO_UNDERLYING() \ +# define STORE_LC_NUMERIC_FORCE_TO_UNDERLYING() \ if (_NOT_IN_NUMERIC_UNDERLYING) { \ Perl_set_numeric_local(aTHX); \ _restore_LC_NUMERIC_function = &Perl_set_numeric_standard; \ @@ -5741,10 +5740,10 @@ expression, but with an empty argument list, like this: /* Lock/unlock to the C locale until unlock is called. This needs to be * recursively callable. [perl #128207] */ -#define LOCK_LC_NUMERIC_STANDARD() \ +# define LOCK_LC_NUMERIC_STANDARD() \ (__ASSERT_(PL_numeric_standard) \ PL_numeric_standard++) -#define UNLOCK_LC_NUMERIC_STANDARD() \ +# define UNLOCK_LC_NUMERIC_STANDARD() \ STMT_START { \ if (PL_numeric_standard > 1) { \ PL_numeric_standard--; \ @@ -5754,29 +5753,29 @@ expression, but with an empty argument list, like this: } \ } STMT_END -#define RESTORE_LC_NUMERIC_UNDERLYING() \ +# define RESTORE_LC_NUMERIC_UNDERLYING() \ if (_was_local) Perl_set_numeric_local(aTHX); -#define RESTORE_LC_NUMERIC_STANDARD() \ +# define RESTORE_LC_NUMERIC_STANDARD() \ if (_restore_LC_NUMERIC_function) { \ _restore_LC_NUMERIC_function(aTHX); \ } #else /* !USE_LOCALE_NUMERIC */ -#define SET_NUMERIC_STANDARD() -#define SET_NUMERIC_UNDERLYING() -#define IS_NUMERIC_RADIX(a, b) (0) -#define STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD() -#define STORE_LC_NUMERIC_STANDARD_SET_UNDERLYING() -#define STORE_LC_NUMERIC_FORCE_TO_UNDERLYING() -#define RESTORE_LC_NUMERIC_UNDERLYING() -#define RESTORE_LC_NUMERIC_STANDARD() -#define DECLARATION_FOR_LC_NUMERIC_MANIPULATION -#define STORE_LC_NUMERIC_SET_TO_NEEDED() -#define RESTORE_LC_NUMERIC() -#define LOCK_LC_NUMERIC_STANDARD() -#define UNLOCK_LC_NUMERIC_STANDARD() +# define SET_NUMERIC_STANDARD() +# define SET_NUMERIC_UNDERLYING() +# define IS_NUMERIC_RADIX(a, b) (0) +# define STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD() +# define STORE_LC_NUMERIC_STANDARD_SET_UNDERLYING() +# define STORE_LC_NUMERIC_FORCE_TO_UNDERLYING() +# define RESTORE_LC_NUMERIC_UNDERLYING() +# define RESTORE_LC_NUMERIC_STANDARD() +# define DECLARATION_FOR_LC_NUMERIC_MANIPULATION +# define STORE_LC_NUMERIC_SET_TO_NEEDED() +# define RESTORE_LC_NUMERIC() +# define LOCK_LC_NUMERIC_STANDARD() +# define UNLOCK_LC_NUMERIC_STANDARD() #endif /* !USE_LOCALE_NUMERIC */ @@ -5786,8 +5785,10 @@ expression, but with an empty argument list, like this: #define DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED \ DECLARATION_FOR_LC_NUMERIC_MANIPULATION #define DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED() \ - DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED; \ - STORE_LC_NUMERIC_SET_TO_NEEDED(); + STMT_START { \ + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; \ + STORE_LC_NUMERIC_SET_TO_NEEDED(); \ + STMT_END #define LOCK_NUMERIC_STANDARD() LOCK_LC_NUMERIC_STANDARD() #define RESTORE_NUMERIC_LOCAL() RESTORE_LC_NUMERIC_UNDERLYING() #define RESTORE_NUMERIC_STANDARD() RESTORE_LC_NUMERIC_STANDARD() diff --git a/proto.h b/proto.h index d8c61e577d..1af9126325 100644 --- a/proto.h +++ b/proto.h @@ -41,9 +41,9 @@ PERL_CALLCONV void* Perl_Slab_Alloc(pTHX_ size_t sz) PERL_CALLCONV void Perl_Slab_Free(pTHX_ void *op); #define PERL_ARGS_ASSERT_SLAB_FREE \ assert(op) -PERL_CALLCONV char * Perl__byte_dump_string(pTHX_ const U8 * s, const STRLEN len, const bool format); +PERL_CALLCONV char * Perl__byte_dump_string(pTHX_ const U8 * const start, const STRLEN len, const bool format); #define PERL_ARGS_ASSERT__BYTE_DUMP_STRING \ - assert(s) + assert(start) PERL_CALLCONV void Perl__force_out_malformed_utf8_message(pTHX_ const U8 *const p, const U8 * const e, const U32 flags, const bool die_here); #define PERL_ARGS_ASSERT__FORCE_OUT_MALFORMED_UTF8_MESSAGE \ assert(p); assert(e) diff --git a/toke.c b/toke.c index da3ecdb316..79df0bcbc5 100644 --- a/toke.c +++ b/toke.c @@ -11906,9 +11906,14 @@ S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) } } + /* 'chars' isn't quite the right name, as code points above 0xFFFF + * require 4 bytes per char */ chars = SvCUR(utf16_buffer) >> 1; have = SvCUR(utf8_buffer); - SvGROW(utf8_buffer, have + chars * 3 + 1); + + /* Assume the worst case size as noted by the functions: twice the + * number of input bytes */ + SvGROW(utf8_buffer, have + chars * 4 + 1); if (reverse) { end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer), diff --git a/utf8.c b/utf8.c index c6d08b6635..b731780fe4 100644 --- a/utf8.c +++ b/utf8.c @@ -952,10 +952,10 @@ Perl__is_utf8_char_helper(const U8 * const s, const U8 * e, const U32 flags) } char * -Perl__byte_dump_string(pTHX_ const U8 * s, const STRLEN len, const bool format) +Perl__byte_dump_string(pTHX_ const U8 * const start, const STRLEN len, const bool format) { /* Returns a mortalized C string that is a displayable copy of the 'len' - * bytes starting at 's'. 'format' gives how to display each byte. + * bytes starting at 'start'. 'format' gives how to display each byte. * Currently, there are only two formats, so it is currently a bool: * 0 \xab * 1 ab (that is a space between two hex digit bytes) @@ -963,7 +963,8 @@ Perl__byte_dump_string(pTHX_ const U8 * s, const STRLEN len, const bool format) const STRLEN output_len = 4 * len + 1; /* 4 bytes per each input, plus a trailing NUL */ - const U8 * const e = s + len; + const U8 * s = start; + const U8 * const e = start + len; char * output; char * d; @@ -973,12 +974,14 @@ Perl__byte_dump_string(pTHX_ const U8 * s, const STRLEN len, const bool format) SAVEFREEPV(output); d = output; - for (; s < e; s++) { + for (s = start; s < e; s++) { const unsigned high_nibble = (*s & 0xF0) >> 4; const unsigned low_nibble = (*s & 0x0F); if (format) { - *d++ = ' '; + if (s > start) { + *d++ = ' '; + } } else { *d++ = '\\'; @@ -2361,10 +2364,19 @@ Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *lenp) } /* - * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8. + * Convert native (big-endian) UTF-16 to UTF-8. For reversed (little-endian), + * use utf16_to_utf8_reversed(). + * + * UTF-16 requires 2 bytes for every code point below 0x10000; otherwise 4 bytes. + * UTF-8 requires 1-3 bytes for every code point below 0x1000; otherwise 4 bytes. + * UTF-EBCDIC requires 1-4 bytes for every code point below 0x1000; otherwise 4-5 bytes. + * + * These functions don't check for overflow. The worst case is every code + * point in the input is 2 bytes, and requires 4 bytes on output. (If the code + * is never going to run in EBCDIC, it is 2 bytes requiring 3 on output.) Therefore the + * destination must be pre-extended to 2 times the source length. * - * Destination must be pre-extended to 3/2 source. Do not use in-place. - * We optimize for native, for obvious reasons. */ + * Do not use in-place. We optimize for native, for obvious reasons. */ U8* Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen) -- Perl5 Master Repository
