Re: Smoke [blead] v5.26.0-1591-g56e48c1076 FAIL(XM) os/390 25.00 (2964/)
[email protected] (Karl Williamson) Mon, 4 Dec 2017 22:47:48 -0700
| Newsgroups | perl.mvs,perl.perl5.porters,perl.daily-build.reports |
|---|---|
| Message-ID | <[email protected]> |
--------------7C84F43286CA6769E29FEAF5 Content-Type: text/plain; charset=utf-8; format=flowed Content-Transfer-Encoding: quoted-printable On 12/04/2017 10:03 PM, Yaroslav Kuzmin wrote: >=20 > Smoke log available https://drive.google.com/file/d/1CwVed6EgFWm29hbiN5= 0NsNEGZGYw7vkP This is looking like it's a problem with the new multi-concat. Attached=20 is a test script that is an instrumented version of one of the failing=20 tests. Please run it by hand and email the results. Say you save the attached file as 'foo' ./perl -I lib foo > foo.out 2>&1 It's been so long since we've had to do special EBCDIC stuff, that I=20 can't remember if I am supposed to convert the script for you or not. I=20 believe it only contains ASCII-range characters. >=20 > Automated smoke report for branch blead 5.27.7 patch 56e48c10762ae38816= 7c2f2449eea8553b396093 v5.26.0-1591-g56e48c1076 > RS12: 2964 (2964/) > on os/390 - 25.00 > using c99 version > smoketime 1 hour 56 minutes (average 58 minutes 11 seconds) >=20 > Summary: FAIL(XM) >=20 > O =3D OK F =3D Failure(s), extended report at the bottom > X =3D Failure(s) under TEST but not under harness > ? =3D still running or test results not (yet) available > Build failures during: - =3D unknown or N/A > c =3D Configure, m =3D make, M =3D make (after miniperl), t =3D make te= st-prep >=20 > v5.26.0-1591-g56e48c1076 Configuration (common) none > ----------- --------------------------------------------------------- > X X M - -Dusedl >> >>> >>>> >>>> +----- PERLIO =3D perlio -DDEBUGGING >>> +------- PERLIO =3D stdio -DDEBUGGING >> +--------- PERLIO =3D perlio > +----------- PERLIO =3D stdio >=20 >=20 > Locally applied patches: > SMOKE56e48c10762ae388167c2f2449eea8553b396093 >=20 > Tests skipped on user request: > # One test name on a line > Failures: (common-args) none > [stdio] -Dusedl > Inconsistent test results (between TEST and harness): > ../t/op/lc.t............................ .........................= .............................. FAILED--expected 1163 tests, saw 56 > ../lib/utf8.t........................... .........................= ............................. FAILED at test 305 > ../t/op/utftaint.t...................... .........................= ........................ FAILED at test 12 > ../lib/DBM_Filter/t/encode.t............ .........................= .............. FAILED at test 14 > ../lib/B/Deparse-core.t................. .........................= ................... FAILED at test 26 > ../ext/XS-APItest/t/handy00.t........... .........................= ............. FAILED at test 132858 > ../t/uni/lex_utf8.t..................... .........................= ....................... FAILED at test 6 > ../t/re/subst.t......................... .........................= ........................... FAILED at test 135 > ../t/op/chop.t.......................... .........................= ............................ FAILED at test 60 > ../t/dist/Carp/t/arg_regexp.t........... .........................= ............... FAILED--expected 42 tests, saw 18 > ../t/re/pat_advanced.t.................. .........................= .................... FAILED at test 218 > ../t/uni/write.t........................ .........................= .......................... FAILED at test 1 > ../t/re/pat_rt_report.t................. .........................= ................... FAILED at test 2467 > ../t/comp/parser_run.t.................. .........................= .................... FAILED at test 2 > ../lib/B/Deparse.t...................... .........................= ........................ FAILED at test 18 > ../t/op/coreamp.t....................... .........................= ......................... FAILED at test 96 > ../t/uni/attrs.t........................ .........................= .......................... FAILED at test 2 > ../t/op/pack.t.......................... .........................= ............................ FAILED at test 14710 > ../t/uni/fold.t......................... .........................= ........................... FAILED--non-zero wait status: 65280 > ../t/dist/Storable/t/code.t............. .........................= ................. FAILED--expected 63 tests, saw 0 > ../t/dist/Devel-PPPort/t/pv_tools.t..... .........................= ......... FAILED at test 7 > ../ext/XS-APItest/t/gv_autoload4.t...... .........................= ........ FAILED at test 23 > ../t/re/substT.t........................ .........................= .......................... FAILED at test 135 > ../t/porting/podcheck.t................. .........................= ................... FAILED--expected 1472 tests, saw 0 > ../lib/feature/unicode_strings.t........ .........................= .......... FAILED at test 3331 > ../t/op/exec.t.......................... .........................= ............................ FAILED at test 28 > ../t/re/pat_re_eval.t................... .........................= ..................... FAILED--expected 497 tests, saw 140 > ../t/dist/Data-Dumper/t/dumper.t........ .........................= ............ FAILED at test 352 > ../t/op/split_unicode.t................. .........................= ................... FAILED at test 37 > ../t/op/write.t......................... .........................= ........................... FAILED at test 176 > ../t/comp/utf.t......................... .........................= ........................... FAILED at test 78 > ../t/dist/Carp/t/arg_string.t........... .........................= ............... FAILED--expected 33 tests, saw 14 > ../t/dist/Data-Dumper/t/bugs.t.......... .........................= .............. FAILED at test 18 > ../t/opbasic/concat.t................... .........................= ..................... FAILED at test 35 > ../t/re/subst_wamp.t.................... .........................= ...................... FAILED at test 135 >=20 > [perlio] -Dusedl > Inconsistent test results (between TEST and harness): > ../lib/utf8.t........................... .........................= ............................. FAILED at test 305 > ../t/op/lc.t............................ .........................= .............................. FAILED--expected 1163 tests, saw 56 > ../lib/DBM_Filter/t/encode.t............ .........................= .............. FAILED at test 14 > ../t/op/utftaint.t...................... .........................= ........................ FAILED at test 4 > ../lib/B/Deparse-core.t................. .........................= ................... FAILED at test 26 > ../t/uni/lex_utf8.t..................... .........................= ....................... FAILED at test 6 > ../ext/XS-APItest/t/handy00.t........... .........................= ............. FAILED at test 132916 > ../t/re/subst.t......................... .........................= ........................... FAILED at test 135 > ../lib/charnames.t...................... .........................= ........................ FAILED at test 39 > ../t/op/chop.t.......................... .........................= ............................ FAILED at test 60 > ../t/dist/Carp/t/arg_regexp.t........... .........................= ............... FAILED--expected 42 tests, saw 18 > ../t/uni/write.t........................ .........................= .......................... FAILED at test 1 > ../t/re/pat_advanced.t.................. .........................= .................... FAILED at test 218 > ../lib/B/Deparse.t...................... .........................= ........................ FAILED at test 32 > ../t/comp/parser_run.t.................. .........................= .................... FAILED at test 2 > ../t/re/pat_rt_report.t................. .........................= ................... FAILED at test 2467 > ../t/uni/attrs.t........................ .........................= .......................... FAILED at test 2 > ../t/op/pack.t.......................... .........................= ............................ FAILED at test 14709 > ../t/uni/fold.t......................... .........................= ........................... FAILED--non-zero wait status: 65280 > ../ext/XS-APItest/t/gv_autoload4.t...... .........................= ........ FAILED at test 23 > ../t/dist/Devel-PPPort/t/pv_tools.t..... .........................= ......... FAILED at test 7 > ../t/dist/Storable/t/code.t............. .........................= ................. FAILED--expected 63 tests, saw 0 > ../t/re/substT.t........................ .........................= .......................... FAILED at test 135 > ../t/porting/podcheck.t................. .........................= ................... FAILED--expected 1472 tests, saw 0 > ../t/op/exec.t.......................... .........................= ............................ FAILED at test 28 > ../t/re/pat_re_eval.t................... .........................= ..................... FAILED--expected 497 tests, saw 140 > ../lib/feature/unicode_strings.t........ .........................= .......... FAILED at test 3331 > ../t/op/write.t......................... .........................= ........................... FAILED at test 176 > ../t/op/split_unicode.t................. .........................= ................... FAILED at test 37 > ../t/dist/Data-Dumper/t/dumper.t........ .........................= ............ FAILED at test 352 > ../t/comp/utf.t......................... .........................= ........................... FAILED at test 135 > ../t/dist/Carp/t/arg_string.t........... .........................= ............... FAILED--expected 33 tests, saw 14 > ../t/opbasic/concat.t................... .........................= ..................... FAILED at test 35 > ../t/re/subst_wamp.t.................... .........................= ...................... FAILED at test 135 > ../t/dist/Data-Dumper/t/bugs.t.......... .........................= .............. FAILED at test 18 >=20 > Compiler messages(os390): >=20 >=20 >=20 > -- > Report by Test::Smoke v1.6 running on perl 5.24.1 > (Reporter v0.052 / Smoker v0.045) >=20 >=20 >=20 > -- >=20 > Regards, >=20 > Yaroslav Kuzmin > Developer C/C++ ,z/OS , Linux > 3 Zhukovskiy Street =C2=B7 Miass, Chelyabinsk region 456318 =C2=B7 Russ= ia > Tel: +7.922.2.38.33.38 > Email: [email protected] > Web: www.rocketsoftware.com >=20 > =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D > Rocket Software, Inc. and subsidiaries =E2=96=A0 77 Fourth Avenue, Walt= ham MA 02451 =E2=96=A0 Main Office Toll Free Number: +1 877.328.2932 > Contact Customer Support: https://my.rocketsoftware.com/RocketCommunity= /RCEmailSupport > Unsubscribe from Marketing Messages/Manage Your Subscription Preference= s - http://www.rocketsoftware.com/manage-your-email-preferences > Privacy Policy - http://www.rocketsoftware.com/company/legal/privacy-po= licy > =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D >=20 > This communication and any attachments may contain confidential informa= tion of Rocket Software, Inc. All unauthorized use, disclosure or distrib= ution is prohibited. If you are not the intended recipient, please notify= Rocket Software immediately and destroy all copies of this communication= . Thank you. >=20 --------------7C84F43286CA6769E29FEAF5 Content-Type: application/x-perl; name="handy_base.pl" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="handy_base.pl" #!perl -w BEGIN { require 'loc_tools.pl'; # Contains locales_enabled() and # find_utf8_ctype_locale() } use strict; use Test::More; use Config; use XS::APItest; my $tab = " " x 4; # Indent subsidiary tests this much use Unicode::UCD qw(search_invlist prop_invmap prop_invlist); my ($charname_list, $charname_map, $format, $default) = prop_invmap("Name Alias"); sub get_charname($) { my $cp = shift; # If there is a an abbreviation for the code point name, use it my $name_index = search_invlist(\@{$charname_list}, $cp); if (defined $name_index) { my $synonyms = $charname_map->[$name_index]; if (ref $synonyms) { my $pat = qr/: abbreviation/; my @abbreviations = grep { $_ =~ $pat } @$synonyms; if (@abbreviations) { return $abbreviations[0] =~ s/$pat//r; } } } # Otherwise, use the full name use charnames (); return charnames::viacode($cp) // "No name"; } sub truth($) { # Converts values so is() works return (shift) ? 1 : 0; } my $base_locale; my $utf8_locale; if(locales_enabled('LC_ALL')) { require POSIX; $base_locale = POSIX::setlocale( &POSIX::LC_ALL, "C"); if (defined $base_locale && $base_locale eq 'C') { use locale; # make \w work right in non-ASCII lands # Some locale implementations don't have the 128-255 characters all # mean nothing. Skip the locale tests in that situation for my $u (128 .. 255) { if (chr(utf8::unicode_to_native($u)) =~ /[[:print:]]/) { undef $base_locale; last; } } $utf8_locale = find_utf8_ctype_locale() if $base_locale; } } sub get_display_locale_or_skip($$) { # Helper function intimately tied to its callers. It knows the loop # iterates with a locale of "", meaning don't use locale; $base_locale # meaning to use a non-UTF-8 locale; and $utf8_locale. # # It checks to see if the current test should be skipped or executed, # returning an empty list for the former, and for the latter: # ( 'locale display name', # bool of is this a UTF-8 locale ) # # The display name is the empty string if not using locale. Functions # with _LC in their name are skipped unless in locale, and functions # without _LC are executed only outside locale. my ($locale, $suffix) = @_; # The test should be skipped if the input is for a non-existent locale return unless defined $locale; # Here the input is defined, either a locale name or "". If the test is # for not using locales, we want to do the test for non-LC functions, # and skip it for LC ones. if ($locale eq "") { return ("", 0) if $suffix !~ /LC/; return; } # Here the input is for a real locale. We don't test the non-LC functions # for locales. return if $suffix !~ /LC/; # Here is for a LC function and a real locale. The base locale is not # UTF-8. return (" ($locale locale)", 0) if $locale eq $base_locale; # The only other possibility is that we have a UTF-8 locale return (" ($locale)", 1); } sub try_malforming($$$) { # Determines if the tests for malformed UTF-8 should be done. When done, # the .xs code creates malformations by pretending the length is shorter # than it actually is. Some things can't be malformed, and sometimes this # test knows that the current code doesn't look for a malformation under # various circumstances. my ($u, $function, $using_locale) = @_; # $u is unicode code point; # Single bytes can't be malformed return 0 if $u < ((ord "A" == 65) ? 128 : 160); # ASCII doesn't need to ever look beyond the first byte. return 0 if $function eq "ASCII"; # Nor, on EBCDIC systems, does CNTRL return 0 if ord "A" != 65 && $function eq "CNTRL"; # No controls above 255, so the code doesn't look at those return 0 if $u > 255 && $function eq "CNTRL"; # No non-ASCII digits below 256, except if using locales. return 0 if $u < 256 && ! $using_locale && $function =~ /X?DIGIT/; return 1; } my %properties = ( # name => Lookup-property name alnum => 'Word', wordchar => 'Word', alphanumeric => 'Alnum', alpha => 'XPosixAlpha', ascii => 'ASCII', blank => 'Blank', cntrl => 'Control', digit => 'Digit', graph => 'Graph', idfirst => '_Perl_IDStart', idcont => '_Perl_IDCont', lower => 'XPosixLower', print => 'Print', psxspc => 'XPosixSpace', punct => 'XPosixPunct', quotemeta => '_Perl_Quotemeta', space => 'XPerlSpace', vertws => 'VertSpace', upper => 'XPosixUpper', xdigit => 'XDigit', ); my %seen; my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; my %utf8_param_code = ( "_safe" => 0, "_safe, malformed" => 1, "deprecated unsafe" => -1, "deprecated mathoms" => -2, ); # This test is split into this number of files. my $num_test_files = $ENV{TEST_JOBS} || 1; $num_test_files = 10 if $num_test_files > 10; my $property_count = -1; foreach my $name (sort keys %properties, 'octal') { # We test every nth property in this run so that this test is split into # smaller chunks to minimize test suite elapsed time when run in parallel. $property_count++; next if $property_count % $num_test_files != $::TEST_CHUNK; my @invlist; if ($name eq 'octal') { # Hand-roll an inversion list with 0-7 in it and nothing else. push @invlist, ord "0", ord "8"; } else { my $property = $properties{$name}; @invlist = prop_invlist($property, '_perl_core_internal_ok'); if (! @invlist) { # An empty return could mean an unknown property, or merely that # it is empty. Call in scalar context to differentiate if (! prop_invlist($property, '_perl_core_internal_ok')) { fail("No inversion list found for $property"); next; } } } # Include all the Latin1 code points, plus 0x100. my @code_points = (0 .. 256); # Then include the next few boundaries above those from this property my $above_latins = 0; foreach my $range_start (@invlist) { next if $range_start < 257; push @code_points, $range_start - 1, $range_start; $above_latins++; last if $above_latins > 5; } # This makes sure we are using the Perl definition of idfirst and idcont, # and not the Unicode. There are a few differences. push @code_points, ord "\N{ESTIMATED SYMBOL}" if $name =~ /^id(first|cont)/; if ($name eq "idcont") { # And some that are continuation but not start push @code_points, ord("\N{GREEK ANO TELEIA}"), ord("\N{COMBINING GRAVE ACCENT}"); } # And finally one non-Unicode code point. push @code_points, 0x110000; # Above Unicode, no prop should match no warnings 'non_unicode'; for my $n (@code_points) { my $u = utf8::native_to_unicode($n); my $function = uc($name); is (@warnings, 0, "Got no unexpected warnings in previous iteration") or diag("@warnings"); undef @warnings; my $matches = search_invlist(\@invlist, $n); if (! defined $matches) { $matches = 0; } else { $matches = truth(! ($matches % 2)); } my $ret; my $char_name = get_charname($n); my $display_name = sprintf "\\x{%02X, %s}", $n, $char_name; my $display_call = "is${function}( $display_name )"; foreach my $suffix ("", "_A", "_L1", "_LC", "_uni", "_uvchr", "_LC_uvchr", "_utf8", "_LC_utf8") { # Not all possible macros have been defined if ($name eq 'vertws') { # vertws is always all of Unicode next if $suffix !~ / ^ _ ( uni | uvchr | utf8 ) $ /x; } elsif ($name eq 'alnum') { # ALNUM_A, ALNUM_L1, and ALNUM_uvchr are not defined as these # suffixes were added later, after WORDCHAR was created to be # a clearer synonym for ALNUM next if $suffix eq '_A' || $suffix eq '_L1' || $suffix eq '_uvchr'; } elsif ($name eq 'octal') { next if $suffix ne "" && $suffix ne '_A' && $suffix ne '_L1'; } elsif ($name eq 'quotemeta') { # There is only one macro for this, and is defined only for # Latin1 range next if $suffix ne "" } foreach my $locale ("", $base_locale, $utf8_locale) { my ($display_locale, $locale_is_utf8) = get_display_locale_or_skip($locale, $suffix); next unless defined $display_locale; use if $locale, "locale"; POSIX::setlocale( &POSIX::LC_ALL, $locale) if $locale; if ($suffix !~ /utf8/) { # _utf8 has to handled specially my $display_call = "is${function}$suffix( $display_name )$display_locale"; $ret = truth eval "test_is${function}$suffix($n)"; if (is ($@, "", "$display_call didn't give error")) { my $truth = $matches; if ($truth) { # The single byte functions are false for # above-Latin1 if ($n >= 256) { $truth = 0 if $suffix=~ / ^ ( _A | _L [1C] )? $ /x; } elsif ( $u >= 128 && $name ne 'quotemeta') { # The no-suffix and _A functions are false # for non-ASCII. So are _LC functions on a # non-UTF-8 locale $truth = 0 if $suffix eq "_A" || $suffix eq "" || ( $suffix =~ /LC/ && ! $locale_is_utf8); } } is ($ret, $truth, "${tab}And correctly returns $truth"); } } else { # _utf8 suffix my $char = chr($n); utf8::upgrade($char); $char = quotemeta $char if $char eq '\\' || $char eq "'"; my $truth; if ( $suffix =~ /LC/ && ! $locale_is_utf8 && $n < 256 && $u >= 128) { # The C-locale _LC function returns FALSE for Latin1 # above ASCII $truth = 0; } else { $truth = $matches; } foreach my $utf8_param("_safe", "_safe, malformed", "deprecated unsafe" ) { my $utf8_param_code = $utf8_param_code{$utf8_param}; my $expect_error = $utf8_param_code > 0; next if $expect_error && ! try_malforming($u, $function, $suffix =~ /LC/); diag __LINE__; diag $function; diag $suffix; diag $display_name; diag $utf8_param; diag $display_locale; diag ord $char; diag $utf8_param_code; diag __LINE__; diag "test_is${function}$suffix('$char'," . " $utf8_param_code)"; my $display_call = "is${function}$suffix( $display_name" . ", $utf8_param )$display_locale"; $ret = truth eval "test_is${function}$suffix('$char'," . " $utf8_param_code)"; if ($expect_error) { isnt ($@, "", "expected and got error in $display_call"); like($@, qr/Malformed UTF-8 character/, "${tab}And got expected message"); if (is (@warnings, 1, "${tab}Got a single warning besides")) { like($warnings[0], qr/Malformed UTF-8 character.*short/, "${tab}Got expected warning"); } else { diag("@warnings"); } undef @warnings; } elsif (is ($@, "", "$display_call didn't give error")) { is ($ret, $truth, "${tab}And correctly returned $truth"); if ($utf8_param_code < 0) { my $warnings_ok; my $unique_function = "is" . $function . $suffix; if (! $seen{$unique_function}++) { $warnings_ok = is(@warnings, 1, "${tab}This is first call to" . " $unique_function; Got a single" . " warning"); if ($warnings_ok) { $warnings_ok = like($warnings[0], qr/starting in Perl .* will require an additional parameter/, "${tab}The warning was the expected" . " deprecation one"); } } else { $warnings_ok = is(@warnings, 0, "${tab}This subsequent call to" . " $unique_function did not warn"); } $warnings_ok or diag("@warnings"); undef @warnings; } } } } } } } } my %to_properties = ( FOLD => 'Case_Folding', LOWER => 'Lowercase_Mapping', TITLE => 'Titlecase_Mapping', UPPER => 'Uppercase_Mapping', ); $property_count = -1; foreach my $name (sort keys %to_properties) { $property_count++; next if $property_count % $num_test_files != $::TEST_CHUNK; my $property = $to_properties{$name}; my ($list_ref, $map_ref, $format, $missing) = prop_invmap($property, ); if (! $list_ref || ! $map_ref) { fail("No inversion map found for $property"); next; } if ($format !~ / ^ a l? $ /x) { fail("Unexpected inversion map format ('$format') found for $property"); next; } # Include all the Latin1 code points, plus 0x100. my @code_points = (0 .. 256); # Then include the next few multi-char folds above those from this # property, and include the next few single folds as well my $above_latins = 0; my $multi_char = 0; for my $i (0 .. @{$list_ref} - 1) { my $range_start = $list_ref->[$i]; next if $range_start < 257; if (ref $map_ref->[$i] && $multi_char < 5) { push @code_points, $range_start - 1 if $code_points[-1] != $range_start - 1; push @code_points, $range_start; $multi_char++; } elsif ($above_latins < 5) { push @code_points, $range_start - 1 if $code_points[-1] != $range_start - 1; push @code_points, $range_start; $above_latins++; } last if $above_latins >= 5 && $multi_char >= 5; } # And finally one non-Unicode code point. push @code_points, 0x110000; # Above Unicode, no prop should match no warnings 'non_unicode'; # $n is native; $u unicode. for my $n (@code_points) { my $u = utf8::native_to_unicode($n); my $function = $name; my $index = search_invlist(\@{$list_ref}, $n); my $ret; my $char_name = get_charname($n); my $display_name = sprintf "\\N{U+%02X, %s}", $n, $char_name; foreach my $suffix ("", "_L1", "_LC") { # This is the only macro defined for L1 next if $suffix eq "_L1" && $function ne "LOWER"; SKIP: foreach my $locale ("", $base_locale, $utf8_locale) { # titlecase is not defined in locales. next if $name eq 'TITLE' && $suffix eq "_LC"; my ($display_locale, $locale_is_utf8) = get_display_locale_or_skip($locale, $suffix); next unless defined $display_locale; skip("to${name}_LC does not work for LATIN SMALL LETTER SHARP S" . "$display_locale", 1) if $u == 0xDF && $name =~ / FOLD | UPPER /x && $suffix eq "_LC" && $locale_is_utf8; use if $locale, "locale"; POSIX::setlocale( &POSIX::LC_ALL, $locale) if $locale; my $display_call = "to${function}$suffix(" . " $display_name )$display_locale"; $ret = eval "test_to${function}$suffix($n)"; if (is ($@, "", "$display_call didn't give error")) { my $should_be; if ($n > 255) { $should_be = $n; } elsif ( $u > 127 && ( $suffix eq "" || ($suffix eq "_LC" && ! $locale_is_utf8))) { $should_be = $n; } elsif ($map_ref->[$index] != $missing) { $should_be = $map_ref->[$index] + $n - $list_ref->[$index] } else { $should_be = $n; } is ($ret, $should_be, sprintf("${tab}And correctly returned 0x%02X", $should_be)); } } } # The _uni, uvchr, and _utf8 functions return both the ordinal of the # first code point of the result, and the result in utf8. The .xs # tests return these in an array, in [0] and [1] respectively, with # [2] the length of the utf8 in bytes. my $utf8_should_be = ""; my $first_ord_should_be; if (ref $map_ref->[$index]) { # A multi-char result for my $n (0 .. @{$map_ref->[$index]} - 1) { $utf8_should_be .= chr $map_ref->[$index][$n]; } $first_ord_should_be = $map_ref->[$index][0]; } else { # A single-char result $first_ord_should_be = ($map_ref->[$index] != $missing) ? $map_ref->[$index] + $n - $list_ref->[$index] : $n; $utf8_should_be = chr $first_ord_should_be; } utf8::upgrade($utf8_should_be); # Test _uni, uvchr foreach my $suffix ('_uni', '_uvchr') { my $s; my $len; my $display_call = "to${function}$suffix( $display_name )"; $ret = eval "test_to${function}$suffix($n)"; if (is ($@, "", "$display_call didn't give error")) { is ($ret->[0], $first_ord_should_be, sprintf("${tab}And correctly returned 0x%02X", $first_ord_should_be)); is ($ret->[1], $utf8_should_be, "${tab}Got correct utf8"); use bytes; is ($ret->[2], length $utf8_should_be, "${tab}Got correct number of bytes for utf8 length"); } } # Test _utf8 my $char = chr($n); utf8::upgrade($char); $char = quotemeta $char if $char eq '\\' || $char eq "'"; foreach my $utf8_param("_safe", "_safe, malformed", "deprecated unsafe", "deprecated mathoms", ) { use Config; next if $utf8_param eq 'deprecated mathoms' && $Config{'ccflags'} =~ /-DNO_MATHOMS/; my $utf8_param_code = $utf8_param_code{$utf8_param}; my $expect_error = $utf8_param_code > 0; # Skip if can't malform (because is a UTF-8 invariant) next if $expect_error && $u < ((ord "A" == 65) ? 128 : 160); my $display_call = "to${function}_utf8($display_name, $utf8_param )"; $ret = eval "test_to${function}_utf8('$char', $utf8_param_code)"; if ($expect_error) { isnt ($@, "", "expected and got error in $display_call"); like($@, qr/Malformed UTF-8 character/, "${tab}And got expected message"); undef @warnings; } elsif (is ($@, "", "$display_call didn't give error")) { is ($ret->[0], $first_ord_should_be, sprintf("${tab}And correctly returned 0x%02X", $first_ord_should_be)); is ($ret->[1], $utf8_should_be, "${tab}Got correct utf8"); use bytes; is ($ret->[2], length $utf8_should_be, "${tab}Got correct number of bytes for utf8 length"); if ($utf8_param_code < 0) { my $warnings_ok; if (! $seen{"${function}_utf8$utf8_param"}++) { $warnings_ok = is(@warnings, 1, "${tab}Got a single warning"); if ($warnings_ok) { my $expected; if ($utf8_param_code == -2) { my $lc_func = lc $function; $expected = qr/starting in Perl .* to_utf8_$lc_func\(\) will be removed/; } else { $expected = qr/starting in Perl .* will require an additional parameter/; } $warnings_ok = like($warnings[0], $expected, "${tab}Got expected deprecation warning"); } } else { $warnings_ok = is(@warnings, 0, "${tab}Deprecation warned only the one time"); } $warnings_ok or diag("@warnings"); undef @warnings; } } } } } # This is primarily to make sure that no non-Unicode warnings get generated is(scalar @warnings, 0, "No unexpected warnings were generated in the tests") or diag @warnings; done_testing; --------------7C84F43286CA6769E29FEAF5--