In perl.git, the branch blead has been updated <https://perl5.git.perl.org/perl.git/commitdiff/ef65a74af186beb93566cf827c5f543f4aa14645?hp=c0227122a5447e00b1f129874141e867a945afc2>
- Log ----------------------------------------------------------------- commit ef65a74af186beb93566cf827c5f543f4aa14645 Author: Karl Williamson <[email protected]> Date: Thu Mar 21 09:35:49 2019 -0600 PATCH: [perl #133880] assertion failure This was caused by attempting to continue parsing after an error is found, and later assuming that what came before was valid. The fix is to put in something valid that's usable until the parse eventually dies from what caused this, or some other error. commit b22e993787de8895a38a87d1fd16646f6653e6eb Author: Karl Williamson <[email protected]> Date: Thu Mar 21 09:02:24 2019 -0600 locale.c: White-space, comment only Indent a block newly formed in the previous commit. Wrap some too-long lines commit 70bd6bc82ba64c1d197d3ec823f43c4a454b2920 Author: Karl Williamson <[email protected]> Date: Wed Mar 20 22:59:39 2019 -0600 locale.c: Don't try to recreate the LC_ALL C locale On threaded perls, we create a locale object for LC_ALL "C" early in the startup phase. When the user asks for that locale, we can just switch to it instead of trying to create a new one. Doing the creation worked, but ended up with a memory leak. My guess, and its only a guess, is that it's a bug in glibc newlocale.c, in which it does an early return, not doing proper cleanup, when it discovers it can re-use an existing locale without needing to create a new one. The reason I think its a glibc bug is that the sample one-liner sent to me PERL_DESTRUCT_LEVEL=2 valgrind --leak-check=full ./perl -DLv -Ilib -e'require POSIX;POSIX::setlocale(&POSIX::LC_ALL, "C");' 2>&1 | more produced a stack output of where the leaked memory had been allocated. I put a print immediately after that line, and prints at the points where things get freed. Every allocation was matched by an attempt to free it. But clearly at least one failed. freelocale() returns void, so can't be checked for failing. Anyway, it's better to try not to create a new locale when we already have an existing one, and doing so, as this commit does, causes the leak to go away. No tests are added, as there are plenty of similar tests already in the suite, and they all should have been leaking. commit 19ee3daf45fd9f6312e89aeae0bc6dc8563e6c4a Author: Karl Williamson <[email protected]> Date: Wed Mar 20 22:58:38 2019 -0600 Add, improve some debugging stmts for -DL (locales) ----------------------------------------------------------------------- Summary of changes: locale.c | 116 ++++++++++++++++++++++++++++++++++++++++++-------------------- perl.c | 5 +++ t/op/tr.t | 8 ++++- toke.c | 8 +++-- 4 files changed, 97 insertions(+), 40 deletions(-) diff --git a/locale.c b/locale.c index 2b123d16ee..8e440cb80d 100644 --- a/locale.c +++ b/locale.c @@ -1002,89 +1002,131 @@ S_emulate_setlocale(const int category, # ifdef DEBUGGING if (DEBUG_Lv_TEST || debug_initialization) { - PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale now using %p\n", __FILE__, __LINE__, PL_C_locale_obj); + PerlIO_printf(Perl_debug_log, + "%s:%d: emulate_setlocale now using %p\n", + __FILE__, __LINE__, PL_C_locale_obj); } # endif - /* If we weren't in a thread safe locale, set so that newlocale() below - which uses 'old_obj', uses an empty one. Same for our reserved C object. - The latter is defensive coding, so that, even if there is some bug, we - will never end up trying to modify either of these, as if passed to - newlocale(), they can be. */ - if (old_obj == LC_GLOBAL_LOCALE || old_obj == PL_C_locale_obj) { - old_obj = (locale_t) 0; - } - - /* Ready to create a new locale by modification of the exising one */ - new_obj = newlocale(mask, locale, old_obj); - - if (! new_obj) { - dSAVE_ERRNO; + /* If we are switching to the LC_ALL C locale, it already exists. Use + * it instead of trying to create a new locale */ + if (mask == LC_ALL_MASK && isNAME_C_OR_POSIX(locale)) { # ifdef DEBUGGING - if (DEBUG_L_TEST || debug_initialization) { - PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale creating new object failed: %d\n", __FILE__, __LINE__, GET_ERRNO); + if (DEBUG_Lv_TEST || debug_initialization) { + PerlIO_printf(Perl_debug_log, + "%s:%d: will stay in C object\n", __FILE__, __LINE__); } # endif - if (! uselocale(old_obj)) { + new_obj = PL_C_locale_obj; + + /* We already had switched to the C locale in preparation for freeing + * 'old_obj' */ + if (old_obj != LC_GLOBAL_LOCALE && old_obj != PL_C_locale_obj) { + freelocale(old_obj); + } + } + else { + /* If we weren't in a thread safe locale, set so that newlocale() below + * which uses 'old_obj', uses an empty one. Same for our reserved C + * object. The latter is defensive coding, so that, even if there is + * some bug, we will never end up trying to modify either of these, as + * if passed to newlocale(), they can be. */ + if (old_obj == LC_GLOBAL_LOCALE || old_obj == PL_C_locale_obj) { + old_obj = (locale_t) 0; + } + + /* Ready to create a new locale by modification of the exising one */ + new_obj = newlocale(mask, locale, old_obj); + + if (! new_obj) { + dSAVE_ERRNO; # ifdef DEBUGGING if (DEBUG_L_TEST || debug_initialization) { - PerlIO_printf(Perl_debug_log, "%s:%d: switching back failed: %d\n", __FILE__, __LINE__, GET_ERRNO); + PerlIO_printf(Perl_debug_log, + "%s:%d: emulate_setlocale creating new object" + " failed: %d\n", __FILE__, __LINE__, GET_ERRNO); } # endif - } - RESTORE_ERRNO; - return NULL; - } + if (! uselocale(old_obj)) { # ifdef DEBUGGING - if (DEBUG_Lv_TEST || debug_initialization) { - PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale created %p; should have freed %p\n", __FILE__, __LINE__, new_obj, old_obj); - } + if (DEBUG_L_TEST || debug_initialization) { + PerlIO_printf(Perl_debug_log, + "%s:%d: switching back failed: %d\n", + __FILE__, __LINE__, GET_ERRNO); + } # endif - /* And switch into it */ - if (! uselocale(new_obj)) { - dSAVE_ERRNO; + } + RESTORE_ERRNO; + return NULL; + } # ifdef DEBUGGING - if (DEBUG_L_TEST || debug_initialization) { - PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale switching to new object failed\n", __FILE__, __LINE__); + if (DEBUG_Lv_TEST || debug_initialization) { + PerlIO_printf(Perl_debug_log, + "%s:%d: emulate_setlocale created %p", + __FILE__, __LINE__, new_obj); + if (old_obj) { + PerlIO_printf(Perl_debug_log, + "; should have freed %p", old_obj); + } + PerlIO_printf(Perl_debug_log, "\n"); } # endif - if (! uselocale(old_obj)) { + /* And switch into it */ + if (! uselocale(new_obj)) { + dSAVE_ERRNO; # ifdef DEBUGGING if (DEBUG_L_TEST || debug_initialization) { - PerlIO_printf(Perl_debug_log, "%s:%d: switching back failed: %d\n", __FILE__, __LINE__, GET_ERRNO); + PerlIO_printf(Perl_debug_log, + "%s:%d: emulate_setlocale switching to new object" + " failed\n", __FILE__, __LINE__); } # endif + if (! uselocale(old_obj)) { + +# ifdef DEBUGGING + + if (DEBUG_L_TEST || debug_initialization) { + PerlIO_printf(Perl_debug_log, + "%s:%d: switching back failed: %d\n", + __FILE__, __LINE__, GET_ERRNO); + } + +# endif + + } + freelocale(new_obj); + RESTORE_ERRNO; + return NULL; } - freelocale(new_obj); - RESTORE_ERRNO; - return NULL; } # ifdef DEBUGGING if (DEBUG_Lv_TEST || debug_initialization) { - PerlIO_printf(Perl_debug_log, "%s:%d: emulate_setlocale now using %p\n", __FILE__, __LINE__, new_obj); + PerlIO_printf(Perl_debug_log, + "%s:%d: emulate_setlocale now using %p\n", + __FILE__, __LINE__, new_obj); } # endif diff --git a/perl.c b/perl.c index 3c49f9650f..cdefa99018 100644 --- a/perl.c +++ b/perl.c @@ -1139,11 +1139,16 @@ perl_destruct(pTHXx) * below */ const locale_t old_locale = uselocale(LC_GLOBAL_LOCALE); if (old_locale != LC_GLOBAL_LOCALE) { + DEBUG_Lv(PerlIO_printf(Perl_debug_log, + "%s:%d: Freeing %p\n", __FILE__, __LINE__, old_locale)); freelocale(old_locale); } } # ifdef USE_LOCALE_NUMERIC if (PL_underlying_numeric_obj) { + DEBUG_Lv(PerlIO_printf(Perl_debug_log, + "%s:%d: Freeing %p\n", __FILE__, __LINE__, + PL_underlying_numeric_obj)); freelocale(PL_underlying_numeric_obj); PL_underlying_numeric_obj = (locale_t) NULL; } diff --git a/t/op/tr.t b/t/op/tr.t index 0f74936fdb..47d603d4fd 100644 --- a/t/op/tr.t +++ b/t/op/tr.t @@ -13,7 +13,7 @@ BEGIN { use utf8; -plan tests => 300; +plan tests => 301; # Test this first before we extend the stack with other operations. # This caused an asan failure due to a bad write past the end of the stack. @@ -1137,6 +1137,12 @@ for ("", nullrocow) { [\x{E5CD}-\x{E5DF}\x{EA80}-\x{EAFA}\x{EB0E}-\x{EB8E}\x{EAFB}-\x{EB0D}\x{E5B5}-\x{E5CC}]; is $x, "\x{E5CE}", '[perl #130656]'; + +} + +{ + fresh_perl_like('y/\x{a00}0-\N{}//', qr/Unknown charname/, { }, + 'RT #133880 illegal \N{}'); } 1; diff --git a/toke.c b/toke.c index 755740d6c4..9bed338ecc 100644 --- a/toke.c +++ b/toke.c @@ -3783,8 +3783,12 @@ S_scan_const(pTHX_ char *start) } } else /* Here is \N{NAME} but not \N{U+...}. */ - if ((res = get_and_check_backslash_N_name_wrapper(s, e))) - { + if (! (res = get_and_check_backslash_N_name_wrapper(s, e))) + { /* Failed. We should die eventually, but for now use a NUL + to keep parsing */ + *d++ = '\0'; + } + else { /* Successfully evaluated the name */ STRLEN len; const char *str = SvPV_const(res, len); if (PL_lex_inpat) { -- Perl5 Master Repository
