In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/620f73f47d224d7d6fbe47dfaab9dddde6988742?hp=3df91f1a10601c50feeed86614da0d5be5b1ac59>
- Log ----------------------------------------------------------------- commit 620f73f47d224d7d6fbe47dfaab9dddde6988742 Author: Karl Williamson <[email protected]> Date: Mon Jul 18 18:49:40 2016 -0600 lib/locale.t: Fix tests, add a test The tests assumed that the lowest collating non-NUL control was \001. This isn't necessarily true, and in a few locales caused the test to fail. M lib/locale.t commit 91c0e2e00f5144f79001f8ee8b627500b54809da Author: Karl Williamson <[email protected]> Date: Tue May 24 11:41:32 2016 -0600 locale.c: Add some debugging statements M locale.c ----------------------------------------------------------------------- Summary of changes: lib/locale.t | 19 +++++++++++++++---- locale.c | 35 ++++++++++++++++++++++++++++++----- 2 files changed, 45 insertions(+), 9 deletions(-) diff --git a/lib/locale.t b/lib/locale.t index 7917ea8..075b0e6 100644 --- a/lib/locale.t +++ b/lib/locale.t @@ -1738,11 +1738,22 @@ foreach my $Locale (@Locale) { use locale; + my @sorted_controls = sort @{$posixes{'cntrl'}}; + debug "sorted :cntrl: = ", disp_chars(@sorted_controls), "\n"; + + ++$locales_test_number; + $test_names{$locales_test_number} + = 'Verify that \0 sorts before any other control'; + my $ok = $sorted_controls[0] eq "\0"; + report_result($Locale, $locales_test_number, $ok); + shift @sorted_controls; + my $lowest_control = $sorted_controls[0]; + ++$locales_test_number; $test_names{$locales_test_number} - = 'Skip in locales where \001 has primary sorting weight; ' + = 'Skip in locales where all controls have primary sorting weight; ' . 'otherwise verify that \0 doesn\'t have primary sorting weight'; - if ("a\001c" lt "ab") { + if ("a${lowest_control}c" lt "ab") { report_result($Locale, $locales_test_number, 1); } else { @@ -1753,14 +1764,14 @@ foreach my $Locale (@Locale) { ++$locales_test_number; $test_names{$locales_test_number} = 'Verify that strings with embedded NUL collate'; - my $ok = "a\0a\0a" lt "a\001a\001a"; + $ok = "a\0a\0a" lt "a${lowest_control}a${lowest_control}a"; report_result($Locale, $locales_test_number, $ok); ++$locales_test_number; $test_names{$locales_test_number} = 'Verify that strings with embedded NUL and ' . 'extra trailing NUL collate'; - $ok = "a\0a\0" lt "a\001a\001"; + $ok = "a\0a\0" lt "a${lowest_control}a${lowest_control}"; report_result($Locale, $locales_test_number, $ok); ++$locales_test_number; diff --git a/locale.c b/locale.c index cc3adac..fb3e676 100644 --- a/locale.c +++ b/locale.c @@ -1488,6 +1488,7 @@ Perl__mem_collxfrm(pTHX_ const char *input_string, includes the collation index prefixed. */ + DEBUG_Lv(PerlIO_printf(Perl_debug_log, "Looking to replace NUL\n")); /* Look through all legal code points (NUL isn't) */ for (j = 1; j < 256; j++) { char * x; /* j's xfrm plus collation index */ @@ -1555,8 +1556,8 @@ Perl__mem_collxfrm(pTHX_ const char *input_string, } DEBUG_L(PerlIO_printf(Perl_debug_log, - "_mem_collxfrm: lowest collating control in the 0-255 " - "range in locale %s is 0x%02X\n", + "_mem_collxfrm: lowest collating non-NUL control in the " + "0-255 range in locale %s is 0x%02X\n", PL_collation_name, cur_min_cp)); if (DEBUG_Lv_TEST) { @@ -1875,10 +1876,34 @@ Perl__mem_collxfrm(pTHX_ const char *input_string, #ifdef DEBUGGING if (DEBUG_Lv_TEST || debug_initialization) { unsigned i; + char * t = s; + bool prev_was_printable = TRUE; + bool first_time = TRUE; PerlIO_printf(Perl_debug_log, - "_mem_collxfrm[%d]: returning %"UVuf" for locale %s '%s'\n", - PL_collation_ix, *xlen, PL_collation_name, input_string); - PerlIO_printf(Perl_debug_log, "Its xfrm is"); + "_mem_collxfrm[%d]: returning %"UVuf" for locale %s string '", + PL_collation_ix, *xlen, PL_collation_name); + while (t < s + len ) { + UV cp = (utf8) + ? utf8_to_uvchr_buf((U8 *) t, s + len, NULL) + : * (U8 *) t; + if (isPRINT(cp)) { + if (! prev_was_printable) { + PerlIO_printf(Perl_debug_log, " "); + } + PerlIO_printf(Perl_debug_log, "%c", (U8) cp); + prev_was_printable = TRUE; + } + else { + if (! first_time) { + PerlIO_printf(Perl_debug_log, " "); + } + PerlIO_printf(Perl_debug_log, "%02"UVXf"", cp); + prev_was_printable = FALSE; + } + t += (utf8) ? UTF8SKIP(t) : 1; + first_time = FALSE; + } + PerlIO_printf(Perl_debug_log, "'\nIts xfrm is"); for (i = COLLXFRM_HDR_LEN; i < *xlen + COLLXFRM_HDR_LEN; i++) { PerlIO_printf(Perl_debug_log, " %02x", (U8) xbuf[i]); } -- Perl5 Master Repository
