# machines, and that is tested elsewhere
use XS::APItest;
-
+use Data::Dumper;
my $pound_sign = chr utf8::unicode_to_native(163);
sub isASCII { ord "A" == 65 }
. '"';
}
+sub output_warnings(@) {
+ diag "The warnings were:\n" . join("", @_);
+}
+
# This test file can't use byte_utf8a_to_utf8n() from t/charset_tools.pl
# because that uses the same functions we are testing here. So UTF-EBCDIC
# strings are hard-coded as I8 strings in this file instead, and we use array
? sub { return shift }
: sub { return join "", map { chr $native_to_i8[ord $_] }
split "", shift };
+sub start_byte_to_cont($) {
+
+ # Extract the code point information from the input UTF-8 start byte, and
+ # return a continuation byte containing the same information. This is
+ # used in constructing an overlong malformation from valid input.
+
+ my $byte = shift;
+ my $len = test_UTF8_SKIP($byte);
+ if ($len < 2) {
+ die "";
+ }
+
+ $byte = ord native_to_I8($byte);
+
+ # Copied from utf8.h. This gets rid of the leading 1 bits.
+ $byte &= ((($len) >= 7) ? 0x00 : (0x1F >> (($len)-2)));
+
+ $byte |= (isASCII) ? 0x80 : ord I8_to_native("\xA0");
+ return chr $byte;
+}
my $is64bit = length sprintf("%x", ~0) > 8;
-# Test utf8n_to_uvchr(). These provide essentially complete code coverage.
-# Copied from utf8.h
+# Test utf8n_to_uvchr_error(). These provide essentially complete code
+# coverage. Copied from utf8.h
my $UTF8_ALLOW_EMPTY = 0x0001;
+my $UTF8_GOT_EMPTY = $UTF8_ALLOW_EMPTY;
my $UTF8_ALLOW_CONTINUATION = 0x0002;
+my $UTF8_GOT_CONTINUATION = $UTF8_ALLOW_CONTINUATION;
my $UTF8_ALLOW_NON_CONTINUATION = 0x0004;
+my $UTF8_GOT_NON_CONTINUATION = $UTF8_ALLOW_NON_CONTINUATION;
my $UTF8_ALLOW_SHORT = 0x0008;
+my $UTF8_GOT_SHORT = $UTF8_ALLOW_SHORT;
my $UTF8_ALLOW_LONG = 0x0010;
-my $UTF8_DISALLOW_SURROGATE = 0x0020;
-my $UTF8_WARN_SURROGATE = 0x0040;
-my $UTF8_DISALLOW_NONCHAR = 0x0080;
-my $UTF8_WARN_NONCHAR = 0x0100;
-my $UTF8_DISALLOW_SUPER = 0x0200;
-my $UTF8_WARN_SUPER = 0x0400;
-my $UTF8_DISALLOW_ABOVE_31_BIT = 0x0800;
-my $UTF8_WARN_ABOVE_31_BIT = 0x1000;
-my $UTF8_CHECK_ONLY = 0x2000;
+my $UTF8_GOT_LONG = $UTF8_ALLOW_LONG;
+my $UTF8_GOT_OVERFLOW = 0x0020;
+my $UTF8_DISALLOW_SURROGATE = 0x0040;
+my $UTF8_GOT_SURROGATE = $UTF8_DISALLOW_SURROGATE;
+my $UTF8_WARN_SURROGATE = 0x0080;
+my $UTF8_DISALLOW_NONCHAR = 0x0100;
+my $UTF8_GOT_NONCHAR = $UTF8_DISALLOW_NONCHAR;
+my $UTF8_WARN_NONCHAR = 0x0200;
+my $UTF8_DISALLOW_SUPER = 0x0400;
+my $UTF8_GOT_SUPER = $UTF8_DISALLOW_SUPER;
+my $UTF8_WARN_SUPER = 0x0800;
+my $UTF8_DISALLOW_ABOVE_31_BIT = 0x1000;
+my $UTF8_GOT_ABOVE_31_BIT = $UTF8_DISALLOW_ABOVE_31_BIT;
+my $UTF8_WARN_ABOVE_31_BIT = 0x2000;
+my $UTF8_CHECK_ONLY = 0x4000;
my $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE
= $UTF8_DISALLOW_SUPER|$UTF8_DISALLOW_SURROGATE;
my $UTF8_DISALLOW_ILLEGAL_INTERCHANGE
my $final_continuation = 0xBF;
my $start = (isASCII) ? 0xC2 : 0xC5;
+my $max_bytes = (isASCII) ? 13 : 14; # Max number of bytes in a UTF-8 sequence
+ # representing a single code point
+
my $continuation = $first_continuation - 1;
while ($cp < 255) {
$u < 0x200000 ? 4 :
$u < 0x4000000 ? 5 :
$u < 0x80000000 ? 6 : (($is64bit)
- ? ($u < 0x1000000000 ? 7 : 13)
+ ? ($u < 0x1000000000 ? 7 : $max_bytes)
: 7)
)
: ($u < 0xA0 ? 1 :
$u < 0x40000 ? 4 :
$u < 0x400000 ? 5 :
$u < 0x4000000 ? 6 :
- $u < 0x40000000 ? 7 : 14 );
+ $u < 0x40000000 ? 7 : $max_bytes );
}
# If this test fails, subsequent ones are meaningless.
unless (is(scalar @warnings, 0,
" Verify is_utf8_valid_partial_char_flags generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
my $b = substr($n_chr, $j, 1);
my $display_flags = sprintf "0x%x", $this_utf8_flags;
my $display_bytes = display_bytes($bytes);
- my $ret_ref = test_utf8n_to_uvchr($bytes, $len, $this_utf8_flags);
+ my $ret_ref = test_utf8n_to_uvchr_error($bytes, $len, $this_utf8_flags);
# Rest of tests likely meaningless if it gets the wrong code point.
next unless is($ret_ref->[0], $n,
- "Verify utf8n_to_uvchr($display_bytes, $display_flags) returns $hex_n");
+ "Verify utf8n_to_uvchr_error($display_bytes, $display_flags)"
+ . "returns $hex_n");
is($ret_ref->[1], $len,
- "Verify utf8n_to_uvchr() for $hex_n returns expected length: $len");
+ "Verify utf8n_to_uvchr_error() for $hex_n returns expected length:"
+ . " $len");
unless (is(scalar @warnings, 0,
- "Verify utf8n_to_uvchr() for $hex_n generated no warnings"))
+ "Verify utf8n_to_uvchr_error() for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
+ is($ret_ref->[2], 0,
+ "Verify utf8n_to_uvchr_error() returned no error bits");
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isUTF8_CHAR() for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isUTF8_CHAR() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isUTF8_CHAR_flags() for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isUTF8_CHAR_flags() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isSTRICT_UTF8_CHAR() for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isSTRICT_UTF8_CHAR() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isUTF8_CHAR() for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isC9_STRICT_UTF8_CHAR() for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isC9_STRICT_UTF8_CHAR() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify isUTF8_CHAR() for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"Verify valid_utf8_to_uvchr() for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
# Similarly for uvchr_to_utf8
unless (is(scalar @warnings, 0,
"Verify uvchr_to_utf8_flags($hex_n, $display_flags) for $hex_n generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
# Now append this code point to a string that we will test various
# Now test the malformations. All these raise category utf8 warnings.
my @malformations = (
[ "zero length string malformation", "", 0,
- $UTF8_ALLOW_EMPTY, 0, 0,
+ $UTF8_ALLOW_EMPTY, $UTF8_GOT_EMPTY, 0, 0,
qr/empty string/
],
[ "orphan continuation byte malformation", I8_to_native("${I8c}a"),
2,
- $UTF8_ALLOW_CONTINUATION, $REPLACEMENT, 1,
+ $UTF8_ALLOW_CONTINUATION, $UTF8_GOT_CONTINUATION, $REPLACEMENT, 1,
qr/unexpected continuation byte/
],
[ "premature next character malformation (immediate)",
(isASCII) ? "\xc2\xc2\x80" : I8_to_native("\xc5\xc5\xa0"),
3,
- $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 1,
+ $UTF8_ALLOW_NON_CONTINUATION, $UTF8_GOT_NON_CONTINUATION, $REPLACEMENT, 1,
qr/unexpected non-continuation byte.*immediately after start byte/
],
[ "premature next character malformation (non-immediate)",
- I8_to_native("\xf0${I8c}a"),
+ I8_to_native("\xf1${I8c}a"),
3,
- $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 2,
+ $UTF8_ALLOW_NON_CONTINUATION, $UTF8_GOT_NON_CONTINUATION, $REPLACEMENT, 2,
qr/unexpected non-continuation byte .* 2 bytes after start byte/
],
- [ "too short malformation", I8_to_native("\xf0${I8c}a"), 2,
+ [ "too short malformation", I8_to_native("\xf1${I8c}a"), 2,
# Having the 'a' after this, but saying there are only 2 bytes also
# tests that we pay attention to the passed in length
- $UTF8_ALLOW_SHORT, $REPLACEMENT, 2,
+ $UTF8_ALLOW_SHORT, $UTF8_GOT_SHORT, $REPLACEMENT, 2,
qr/2 bytes, need 4/
],
[ "overlong malformation, lowest 2-byte",
(isASCII) ? "\xc0\x80" : I8_to_native("\xc0\xa0"),
2,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
0, # NUL
2,
- qr/2 bytes, need 1/
+ qr/overlong/
],
[ "overlong malformation, highest 2-byte",
(isASCII) ? "\xc1\xbf" : I8_to_native("\xc4\xbf"),
2,
- $UTF8_ALLOW_LONG,
- (isASCII) ? 0x7F : utf8::unicode_to_native(0xBF),
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
+ (isASCII) ? 0x7F : utf8::unicode_to_native(0x9F),
2,
- qr/2 bytes, need 1/
+ qr/overlong/
],
[ "overlong malformation, lowest 3-byte",
(isASCII) ? "\xe0\x80\x80" : I8_to_native("\xe0\xa0\xa0"),
3,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
0, # NUL
3,
- qr/3 bytes, need 1/
+ qr/overlong/
],
[ "overlong malformation, highest 3-byte",
(isASCII) ? "\xe0\x9f\xbf" : I8_to_native("\xe0\xbf\xbf"),
3,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
(isASCII) ? 0x7FF : 0x3FF,
3,
- qr/3 bytes, need 2/
+ qr/overlong/
],
[ "overlong malformation, lowest 4-byte",
(isASCII) ? "\xf0\x80\x80\x80" : I8_to_native("\xf0\xa0\xa0\xa0"),
4,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
0, # NUL
4,
- qr/4 bytes, need 1/
+ qr/overlong/
],
[ "overlong malformation, highest 4-byte",
(isASCII) ? "\xf0\x8F\xbf\xbf" : I8_to_native("\xf0\xaf\xbf\xbf"),
4,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
(isASCII) ? 0xFFFF : 0x3FFF,
4,
- qr/4 bytes, need 3/
+ qr/overlong/
],
[ "overlong malformation, lowest 5-byte",
(isASCII)
? "\xf8\x80\x80\x80\x80"
: I8_to_native("\xf8\xa0\xa0\xa0\xa0"),
5,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
0, # NUL
5,
- qr/5 bytes, need 1/
+ qr/overlong/
],
[ "overlong malformation, highest 5-byte",
(isASCII)
? "\xf8\x87\xbf\xbf\xbf"
: I8_to_native("\xf8\xa7\xbf\xbf\xbf"),
5,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
(isASCII) ? 0x1FFFFF : 0x3FFFF,
5,
- qr/5 bytes, need 4/
+ qr/overlong/
],
[ "overlong malformation, lowest 6-byte",
(isASCII)
? "\xfc\x80\x80\x80\x80\x80"
: I8_to_native("\xfc\xa0\xa0\xa0\xa0\xa0"),
6,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
0, # NUL
6,
- qr/6 bytes, need 1/
+ qr/overlong/
],
[ "overlong malformation, highest 6-byte",
(isASCII)
? "\xfc\x83\xbf\xbf\xbf\xbf"
: I8_to_native("\xfc\xa3\xbf\xbf\xbf\xbf"),
6,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
(isASCII) ? 0x3FFFFFF : 0x3FFFFF,
6,
- qr/6 bytes, need 5/
+ qr/overlong/
],
[ "overlong malformation, lowest 7-byte",
(isASCII)
? "\xfe\x80\x80\x80\x80\x80\x80"
: I8_to_native("\xfe\xa0\xa0\xa0\xa0\xa0\xa0"),
7,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
0, # NUL
7,
- qr/7 bytes, need 1/
+ qr/overlong/
],
[ "overlong malformation, highest 7-byte",
(isASCII)
? "\xfe\x81\xbf\xbf\xbf\xbf\xbf"
: I8_to_native("\xfe\xa1\xbf\xbf\xbf\xbf\xbf"),
7,
- $UTF8_ALLOW_LONG,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
(isASCII) ? 0x7FFFFFFF : 0x3FFFFFF,
7,
- qr/7 bytes, need 6/
+ qr/overlong/
],
);
"\xfe\x84\x80\x80\x80\x80\x80", # Represents 2**32
7,
0, # There is no way to allow this malformation
+ $UTF8_GOT_OVERFLOW,
$REPLACEMENT,
7,
- qr/overflow/
+ qr/overflows/
],
[ "overflow malformation, can tell on first byte",
"\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
- 13,
+ $max_bytes,
0, # There is no way to allow this malformation
+ $UTF8_GOT_OVERFLOW,
$REPLACEMENT,
- 13,
- qr/overflow/
+ $max_bytes,
+ qr/overflows/
];
}
else {
(isASCII)
? "\xff\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80"
: I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
- (isASCII) ? 13 : 14,
- $UTF8_ALLOW_LONG,
+ $max_bytes,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
0, # NUL
- (isASCII) ? 13 : 14,
- qr/1[34] bytes, need 1/, # 1[34] to work on either ASCII or EBCDIC
+ $max_bytes,
+ qr/overlong/,
],
[ "overlong malformation, highest max-byte",
(isASCII) # 2**36-1 on ASCII; 2**30-1 on EBCDIC
? "\xff\x80\x80\x80\x80\x80\x80\xbf\xbf\xbf\xbf\xbf\xbf"
: I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xbf\xbf\xbf\xbf\xbf\xbf"),
- (isASCII) ? 13 : 14,
- $UTF8_ALLOW_LONG,
+ $max_bytes,
+ $UTF8_ALLOW_LONG, $UTF8_GOT_LONG,
(isASCII) ? 0xFFFFFFFFF : 0x3FFFFFFF,
- (isASCII) ? 13 : 14,
- qr/1[34] bytes, need 7/,
+ $max_bytes,
+ qr/overlong/,
];
if (! $is64bit) { # 32-bit EBCDIC
push @malformations,
[ "overflow malformation",
I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"),
- 14,
+ $max_bytes,
0, # There is no way to allow this malformation
+ $UTF8_GOT_OVERFLOW,
$REPLACEMENT,
- 14,
- qr/overflow/
+ $max_bytes,
+ qr/overflows/
];
}
else { # 64-bit
(isASCII)
? "\xff\x80\x90\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"
: I8_to_native("\xff\xb0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
- (isASCII) ? 13 : 14,
+ $max_bytes,
0, # There is no way to allow this malformation
+ $UTF8_GOT_OVERFLOW,
$REPLACEMENT,
- (isASCII) ? 13 : 14,
- qr/overflow/
+ $max_bytes,
+ qr/overflows/
];
}
}
foreach my $test (@malformations) {
- my ($testname, $bytes, $length, $allow_flags, $allowed_uv, $expected_len, $message ) = @$test;
-
- next if ! ok(length($bytes) >= $length, "$testname: Make sure won't read beyond buffer: " . length($bytes) . " >= $length");
+ my ($testname, $bytes, $length, $allow_flags, $expected_error_flags,
+ $allowed_uv, $expected_len, $message ) = @$test;
+
+ if (length($bytes) < $length) {
+ fail("Internal test error: actual buffer length (" . length($bytes)
+ . ") must be at least as high as how far we are allowed to read"
+ . " into it ($length)");
+ diag($testname);
+ next;
+ }
undef @warnings;
unless (is(scalar @warnings, 0,
"$testname: isUTF8_CHAR() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"$testname: isUTF8_CHAR() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
$ret = test_isSTRICT_UTF8_CHAR($bytes, $length);
unless (is(scalar @warnings, 0,
"$testname: isSTRICT_UTF8_CHAR() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
$ret = test_isC9_STRICT_UTF8_CHAR($bytes, $length);
unless (is(scalar @warnings, 0,
"$testname: isC9_STRICT_UTF8_CHAR() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
for my $j (1 .. $length - 1) {
$ret = test_is_utf8_valid_partial_char_flags($bytes, $j, 0);
my $ret_should_be = 0;
my $comment = "";
- if ($testname =~ /premature|short/ && $j < 2) {
- $ret_should_be = 1;
- $comment = ", but need 2 bytes to discern:";
+ if ($testname =~ /premature|short/ && $j < 3) {
+
+ # The tests are hard-coded so these relationships hold
+ my $cut_off = 2;
+ $cut_off = 3 if $testname =~ /non-immediate/;
+ if ($j < $cut_off) {
+ $ret_should_be = 1;
+ $comment = ", but need $cut_off bytes to discern:";
+ }
}
elsif ($testname =~ /overlong/ && ! isASCII && $length == 3) {
# 3-byte overlongs on EBCDIC are determinable on the first byte
unless (is(scalar @warnings, 0,
"$testname: is_utf8_valid_partial_char_flags() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
}
# Test what happens when this malformation is not allowed
undef @warnings;
- my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
+ my $ret_ref = test_utf8n_to_uvchr_error($bytes, $length, 0);
is($ret_ref->[0], 0, "$testname: disallowed: Returns 0");
- is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), disallowed: Returns expected length: $expected_len");
- if (is(scalar @warnings, 1, "$testname: disallowed: Got a single warning ")) {
- like($warnings[0], $message, "$testname: disallowed: Got expected warning");
+ is($ret_ref->[1], $expected_len,
+ "$testname: utf8n_to_uvchr_error(), disallowed: Returns expected"
+ . " length: $expected_len");
+ if (is(scalar @warnings, 1,
+ "$testname: disallowed: Got a single warning "))
+ {
+ like($warnings[0], $message,
+ "$testname: disallowed: Got expected warning");
}
else {
if (scalar @warnings) {
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
}
+ is($ret_ref->[2], $expected_error_flags,
+ "$testname: utf8n_to_uvchr_error(), disallowed:"
+ . " Returns expected error");
{ # Next test when disallowed, and warnings are off.
undef @warnings;
no warnings 'utf8';
- my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
- is($ret_ref->[0], 0, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': Returns 0");
- is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': Returns expected length: $expected_len");
- if (!is(scalar @warnings, 0, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': no warnings generated")) {
- diag "The warnings were: " . join(", ", @warnings);
+ my $ret_ref = test_utf8n_to_uvchr_error($bytes, $length, 0);
+ is($ret_ref->[0], 0,
+ "$testname: utf8n_to_uvchr_error(), disallowed: no warnings 'utf8':"
+ . " Returns 0");
+ is($ret_ref->[1], $expected_len,
+ "$testname: utf8n_to_uvchr_error(), disallowed: no warnings 'utf8':"
+ . " Returns expected length: $expected_len");
+ if (!is(scalar @warnings, 0,
+ "$testname: utf8n_to_uvchr_error(), disallowed: no warnings 'utf8':"
+ . " no warnings generated"))
+ {
+ output_warnings(@warnings);
}
+ is($ret_ref->[2], $expected_error_flags,
+ "$testname: utf8n_to_uvchr_error(), disallowed: Returns"
+ . " expected error");
}
# Test with CHECK_ONLY
undef @warnings;
- $ret_ref = test_utf8n_to_uvchr($bytes, $length, $UTF8_CHECK_ONLY);
+ $ret_ref = test_utf8n_to_uvchr_error($bytes, $length, $UTF8_CHECK_ONLY);
is($ret_ref->[0], 0, "$testname: CHECK_ONLY: Returns 0");
is($ret_ref->[1], -1, "$testname: CHECK_ONLY: returns -1 for length");
if (! is(scalar @warnings, 0, "$testname: CHECK_ONLY: no warnings generated")) {
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
+ is($ret_ref->[2], $expected_error_flags,
+ "$testname: utf8n_to_uvchr_error(), disallowed: Returns expected"
+ . " error");
next if $allow_flags == 0; # Skip if can't allow this malformation
# Test when the malformation is allowed
undef @warnings;
- $ret_ref = test_utf8n_to_uvchr($bytes, $length, $allow_flags);
- is($ret_ref->[0], $allowed_uv, "$testname: utf8n_to_uvchr(), allowed: Returns expected uv: " . sprintf("0x%04X", $allowed_uv));
- is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), allowed: Returns expected length: $expected_len");
- if (!is(scalar @warnings, 0, "$testname: utf8n_to_uvchr(), allowed: no warnings generated"))
+ $ret_ref = test_utf8n_to_uvchr_error($bytes, $length, $allow_flags);
+ is($ret_ref->[0], $allowed_uv,
+ "$testname: utf8n_to_uvchr_error(), allowed: Returns expected uv: "
+ . sprintf("0x%04X", $allowed_uv));
+ is($ret_ref->[1], $expected_len,
+ "$testname: utf8n_to_uvchr_error(), allowed: Returns expected length:"
+ . " $expected_len");
+ if (!is(scalar @warnings, 0,
+ "$testname: utf8n_to_uvchr_error(), allowed: no warnings"
+ . " generated"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
+ is($ret_ref->[2], $expected_error_flags,
+ "$testname: utf8n_to_uvchr_error(), disallowed: Returns"
+ . " expected error");
+}
+
+sub nonportable_regex ($) {
+
+ # Returns a pattern that matches the non-portable message raised either
+ # for the specific input code point, or the one generated when there
+ # is some malformation that precludes the message containing the specific
+ # code point
+
+ my $code_point = shift;
+
+ my $string = sprintf '(Code point 0x%X is not Unicode, and'
+ . '|Any UTF-8 sequence that starts with'
+ . ' "(\\\x[[:xdigit:]]{2})+" is for a'
+ . ' non-Unicode code point, and is) not portable',
+ $code_point;
+ return qr/$string/;
}
# Now test the cases where a legal code point is generated, but may or may not
my @tests = (
[ "lowest surrogate",
(isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"),
- $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
+ $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, $UTF8_GOT_SURROGATE,
'surrogate', 0xD800,
(isASCII) ? 3 : 4,
qr/surrogate/
],
[ "a middle surrogate",
(isASCII) ? "\xed\xa4\x8d" : I8_to_native("\xf1\xb6\xa8\xad"),
- $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
+ $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, $UTF8_GOT_SURROGATE,
'surrogate', 0xD90D,
(isASCII) ? 3 : 4,
qr/surrogate/
],
[ "highest surrogate",
(isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"),
- $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
+ $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, $UTF8_GOT_SURROGATE,
'surrogate', 0xDFFF,
(isASCII) ? 3 : 4,
qr/surrogate/
],
[ "first non_unicode",
(isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"),
- $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
+ $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, $UTF8_GOT_SUPER,
'non_unicode', 0x110000,
(isASCII) ? 4 : 5,
- qr/not Unicode.* may not be portable/
+ qr/(not Unicode|for a non-Unicode code point).* may not be portable/
],
[ "non_unicode whose first byte tells that",
(isASCII) ? "\xf5\x80\x80\x80" : I8_to_native("\xfa\xa0\xa0\xa0\xa0"),
- $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
+ $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, $UTF8_GOT_SUPER,
'non_unicode',
(isASCII) ? 0x140000 : 0x200000,
(isASCII) ? 4 : 5,
- qr/not Unicode.* may not be portable/
+ qr/(not Unicode|for a non-Unicode code point).* may not be portable/
],
[ "first of 32 consecutive non-character code points",
(isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xFDD0,
(isASCII) ? 3 : 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "a mid non-character code point of the 32 consecutive ones",
(isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xFDE0,
(isASCII) ? 3 : 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "final of 32 consecutive non-character code points",
(isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xFDEF,
(isASCII) ? 3 : 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+FFFE",
(isASCII) ? "\xef\xbf\xbe" : I8_to_native("\xf1\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xFFFE,
(isASCII) ? 3 : 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+FFFF",
(isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xFFFF,
(isASCII) ? 3 : 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+1FFFE",
(isASCII) ? "\xf0\x9f\xbf\xbe" : I8_to_native("\xf3\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x1FFFE, 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+1FFFF",
(isASCII) ? "\xf0\x9f\xbf\xbf" : I8_to_native("\xf3\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x1FFFF, 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+2FFFE",
(isASCII) ? "\xf0\xaf\xbf\xbe" : I8_to_native("\xf5\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x2FFFE, 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+2FFFF",
(isASCII) ? "\xf0\xaf\xbf\xbf" : I8_to_native("\xf5\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x2FFFF, 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+3FFFE",
(isASCII) ? "\xf0\xbf\xbf\xbe" : I8_to_native("\xf7\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x3FFFE, 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+3FFFF",
(isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x3FFFF, 4,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+4FFFE",
(isASCII) ? "\xf1\x8f\xbf\xbe" : I8_to_native("\xf8\xa9\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x4FFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+4FFFF",
(isASCII) ? "\xf1\x8f\xbf\xbf" : I8_to_native("\xf8\xa9\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x4FFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+5FFFE",
(isASCII) ? "\xf1\x9f\xbf\xbe" : I8_to_native("\xf8\xab\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x5FFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+5FFFF",
(isASCII) ? "\xf1\x9f\xbf\xbf" : I8_to_native("\xf8\xab\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x5FFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+6FFFE",
(isASCII) ? "\xf1\xaf\xbf\xbe" : I8_to_native("\xf8\xad\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x6FFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+6FFFF",
(isASCII) ? "\xf1\xaf\xbf\xbf" : I8_to_native("\xf8\xad\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x6FFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+7FFFE",
(isASCII) ? "\xf1\xbf\xbf\xbe" : I8_to_native("\xf8\xaf\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x7FFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+7FFFF",
(isASCII) ? "\xf1\xbf\xbf\xbf" : I8_to_native("\xf8\xaf\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x7FFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+8FFFE",
(isASCII) ? "\xf2\x8f\xbf\xbe" : I8_to_native("\xf8\xb1\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x8FFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+8FFFF",
(isASCII) ? "\xf2\x8f\xbf\xbf" : I8_to_native("\xf8\xb1\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x8FFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+9FFFE",
(isASCII) ? "\xf2\x9f\xbf\xbe" : I8_to_native("\xf8\xb3\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x9FFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+9FFFF",
(isASCII) ? "\xf2\x9f\xbf\xbf" : I8_to_native("\xf8\xb3\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x9FFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+AFFFE",
(isASCII) ? "\xf2\xaf\xbf\xbe" : I8_to_native("\xf8\xb5\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xAFFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+AFFFF",
(isASCII) ? "\xf2\xaf\xbf\xbf" : I8_to_native("\xf8\xb5\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xAFFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+BFFFE",
(isASCII) ? "\xf2\xbf\xbf\xbe" : I8_to_native("\xf8\xb7\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xBFFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+BFFFF",
(isASCII) ? "\xf2\xbf\xbf\xbf" : I8_to_native("\xf8\xb7\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xBFFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+CFFFE",
(isASCII) ? "\xf3\x8f\xbf\xbe" : I8_to_native("\xf8\xb9\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xCFFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+CFFFF",
(isASCII) ? "\xf3\x8f\xbf\xbf" : I8_to_native("\xf8\xb9\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xCFFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+DFFFE",
(isASCII) ? "\xf3\x9f\xbf\xbe" : I8_to_native("\xf8\xbb\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xDFFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+DFFFF",
(isASCII) ? "\xf3\x9f\xbf\xbf" : I8_to_native("\xf8\xbb\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xDFFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+EFFFE",
(isASCII) ? "\xf3\xaf\xbf\xbe" : I8_to_native("\xf8\xbd\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xEFFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+EFFFF",
(isASCII) ? "\xf3\xaf\xbf\xbf" : I8_to_native("\xf8\xbd\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xEFFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+FFFFE",
(isASCII) ? "\xf3\xbf\xbf\xbe" : I8_to_native("\xf8\xbf\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xFFFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+FFFFF",
(isASCII) ? "\xf3\xbf\xbf\xbf" : I8_to_native("\xf8\xbf\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0xFFFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+10FFFE",
(isASCII) ? "\xf4\x8f\xbf\xbe" : I8_to_native("\xf9\xa1\xbf\xbf\xbe"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x10FFFE,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
],
[ "non-character code point U+10FFFF",
(isASCII) ? "\xf4\x8f\xbf\xbf" : I8_to_native("\xf9\xa1\xbf\xbf\xbf"),
- $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, $UTF8_GOT_NONCHAR,
'nonchar', 0x10FFFF,
(isASCII) ? 4 : 5,
qr/Unicode non-character.*is not recommended for open interchange/
# This code point is chosen so that it is representable in a UV on
# 32-bit machines
$UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
- 'utf8', 0x80000000, (isASCII) ? 7 :14,
- qr/Code point 0x80000000 is not Unicode, and not portable/
+ $UTF8_GOT_ABOVE_31_BIT,
+ 'utf8', 0x80000000, (isASCII) ? 7 : $max_bytes,
+ nonportable_regex(0x80000000)
+ ],
+ [ "highest 32 bit code point",
+ (isASCII)
+ ? "\xfe\x83\xbf\xbf\xbf\xbf\xbf"
+ : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa3\xbf\xbf\xbf\xbf\xbf\xbf"),
+ $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
+ $UTF8_GOT_ABOVE_31_BIT,
+ 'utf8', 0xFFFFFFFF, (isASCII) ? 7 : $max_bytes,
+ nonportable_regex(0xffffffff)
],
[ "requires at least 32 bits, and use SUPER-type flags, instead of ABOVE_31_BIT",
(isASCII)
? "\xfe\x82\x80\x80\x80\x80\x80"
: I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
- $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
- 'utf8', 0x80000000, (isASCII) ? 7 :14,
- qr/Code point 0x80000000 is not Unicode, and not portable/
+ $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, $UTF8_GOT_SUPER,
+ 'utf8', 0x80000000, (isASCII) ? 7 : $max_bytes,
+ nonportable_regex(0x80000000)
],
[ "overflow with warnings/disallow for more than 31 bits",
# This tests the interaction of WARN_ABOVE_31_BIT/DISALLOW_ABOVE_31_BIT
: ((isASCII)
? "\xfe\x86\x80\x80\x80\x80\x80"
: I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"))),
-
- # We include both warning categories to make sure the ABOVE_31_BIT one
- # has precedence
- "$UTF8_WARN_ABOVE_31_BIT|$UTF8_WARN_SUPER",
- "$UTF8_DISALLOW_ABOVE_31_BIT",
+ $UTF8_WARN_ABOVE_31_BIT,
+ $UTF8_DISALLOW_ABOVE_31_BIT,
+ $UTF8_GOT_ABOVE_31_BIT,
'utf8', 0,
- (! isASCII) ? 14 : ($is64bit) ? 13 : 7,
- qr/overflow at byte .*, after start byte 0xf/
+ (! isASCII) ? $max_bytes : ($is64bit) ? $max_bytes : 7, # XXX
+ qr/overflows/
],
);
-if ($is64bit) {
+if (! $is64bit) {
+ if (isASCII) {
+ no warnings qw{portable overflow};
+ push @tests,
+ [ "Lowest 33 bit code point: overflow",
+ "\xFE\x84\x80\x80\x80\x80\x80",
+ $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
+ $UTF8_GOT_ABOVE_31_BIT,
+ 'utf8', 0x100000000, 7,
+ qr/and( is)? not portable/
+ ];
+ }
+}
+else {
no warnings qw{portable overflow};
push @tests,
[ "More than 32 bits",
? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
: I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
$UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
- 'utf8', 0x1000000000, (isASCII) ? 13 : 14,
- qr/Code point 0x.* is not Unicode, and not portable/
+ $UTF8_GOT_ABOVE_31_BIT,
+ 'utf8', 0x1000000000, $max_bytes,
+ qr/and( is)? not portable/
];
if (! isASCII) {
push @tests, # These could falsely show wrongly in a naive implementation
[ "requires at least 32 bits",
I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
$UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
- 'utf8', 0x800000000, 14,
- qr/Code point 0x800000000 is not Unicode, and not portable/
+ $UTF8_GOT_ABOVE_31_BIT,
+ 'utf8', 0x800000000, $max_bytes,
+ nonportable_regex(0x80000000)
],
[ "requires at least 32 bits",
I8_to_native("\xff\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
$UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
- 'utf8', 0x10000000000, 14,
- qr/Code point 0x10000000000 is not Unicode, and not portable/
+ $UTF8_GOT_ABOVE_31_BIT,
+ 'utf8', 0x10000000000, $max_bytes,
+ nonportable_regex(0x10000000000)
],
[ "requires at least 32 bits",
I8_to_native("\xff\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
$UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
- 'utf8', 0x200000000000, 14,
- qr/Code point 0x200000000000 is not Unicode, and not portable/
+ $UTF8_GOT_ABOVE_31_BIT,
+ 'utf8', 0x200000000000, $max_bytes,
+ nonportable_regex(0x20000000000)
],
[ "requires at least 32 bits",
I8_to_native("\xff\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
$UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
- 'utf8', 0x4000000000000, 14,
- qr/Code point 0x4000000000000 is not Unicode, and not portable/
+ $UTF8_GOT_ABOVE_31_BIT,
+ 'utf8', 0x4000000000000, $max_bytes,
+ nonportable_regex(0x4000000000000)
],
[ "requires at least 32 bits",
I8_to_native("\xff\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
$UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
- 'utf8', 0x80000000000000, 14,
- qr/Code point 0x80000000000000 is not Unicode, and not portable/
+ $UTF8_GOT_ABOVE_31_BIT,
+ 'utf8', 0x80000000000000, $max_bytes,
+ nonportable_regex(0x80000000000000)
],
[ "requires at least 32 bits",
I8_to_native("\xff\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
+ #IBM-1047 \xFE\x41\x41\x41\x41\x41\x41\x43\x41\x41\x41\x41\x41\x41
$UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
- 'utf8', 0x1000000000000000, 14,
- qr/Code point 0x1000000000000000 is not Unicode, and not portable/
+ $UTF8_GOT_ABOVE_31_BIT,
+ 'utf8', 0x1000000000000000, $max_bytes,
+ nonportable_regex(0x1000000000000000)
];
}
}
foreach my $test (@tests) {
- my ($testname, $bytes, $warn_flags, $disallow_flags, $category, $allowed_uv, $expected_len, $message ) = @$test;
+ my ($testname, $bytes, $warn_flags, $disallow_flags, $expected_error_flags,
+ $category, $allowed_uv, $expected_len, $message ) = @$test;
my $length = length $bytes;
- my $will_overflow = $testname =~ /overflow/;
+ my $will_overflow = $testname =~ /overflow/ ? 'overflow' : "";
{
use warnings;
unless (is(scalar @warnings, 0,
"isUTF8_CHAR() and isUTF8_CHAR()_flags $testname: generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"isSTRICT_UTF8_CHAR() and isUTF8_CHAR_flags $testname: generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
undef @warnings;
unless (is(scalar @warnings, 0,
"isC9_STRICT_UTF8_CHAR() and isUTF8_CHAR_flags $testname: generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
# Test partial character handling, for each byte not a full character
unless (is(scalar @warnings, 0,
"$testname: is_utf8_valid_partial_char_flags() generated no warnings"))
{
- diag "The warnings were: " . join(", ", @warnings);
+ output_warnings(@warnings);
}
}
}
foreach my $disallow_flag (0, $disallow_flags) {
foreach my $do_warning (0, 1) {
- my $eval_warn = $do_warning
- ? "use warnings '$warning'"
- : $warning eq "utf8"
- ? "no warnings 'utf8'"
- : "use warnings 'utf8'; no warnings '$warning'";
-
- # is effectively disallowed if will overflow, even if the
- # flag indicates it is allowed, fix up test name to
- # indicate this as well
- my $disallowed = $disallow_flag || $will_overflow;
-
- my $this_name = "utf8n_to_uvchr() $testname: " . (($disallow_flag)
- ? 'disallowed'
- : ($disallowed)
- ? 'ABOVE_31_BIT allowed'
- : 'allowed');
- $this_name .= ", $eval_warn";
- $this_name .= ", " . (($warn_flag)
- ? 'with warning flag'
- : 'no warning flag');
-
- undef @warnings;
- my $ret_ref;
- my $display_bytes = display_bytes($bytes);
- my $call = "Call was: $eval_warn; \$ret_ref = test_utf8n_to_uvchr('$display_bytes', $length, $warn_flag|$disallow_flag)";
- my $eval_text = "$eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)";
- eval "$eval_text";
- if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
- diag "\$!='$!'; eval'd=\"$call\"";
- next;
- }
- if ($disallowed) {
- unless (is($ret_ref->[0], 0, "$this_name: Returns 0"))
- {
- diag $call;
- }
- }
- else {
- unless (is($ret_ref->[0], $allowed_uv,
- "$this_name: Returns expected uv: "
- . sprintf("0x%04X", $allowed_uv)))
- {
- diag $call;
- }
- }
- unless (is($ret_ref->[1], $expected_len,
- "$this_name: Returns expected length: $expected_len"))
+ # We try each of the above with various combinations of
+ # malformations that can occur on the same input sequence.
+ foreach my $short ("",
+ "short",
+ "unexpected non-continuation")
{
- diag $call;
- }
+ # The non-characters can't be discerned with a short
+ # malformation
+ next if $short && $testname =~ /non-character/;
+
+ foreach my $overlong ("", "overlong") {
+
+ # If we're already at the longest possible, we
+ # can't create an overlong (which would be longer)
+ # can't handle anything larger.
+ next if $overlong && $expected_len >= $max_bytes;
+
+ my @malformations;
+ my @expected_errors;
+ push @malformations, $short if $short;
+ push @malformations, $overlong if $overlong;
+
+ # The overflow malformation test in the input
+ # array is coerced into being treated like one of
+ # the others.
+ if ($will_overflow) {
+ push @malformations, 'overflow';
+ push @expected_errors, $UTF8_GOT_OVERFLOW;
+ }
- if (! $do_warning
- && ($warning eq 'utf8' || $warning eq $category))
- {
- if (!is(scalar @warnings, 0,
- "$this_name: No warnings generated"))
- {
- diag $call;
- diag "The warnings were: " . join(", ", @warnings);
- }
- }
- elsif ($will_overflow
- && ! $disallow_flag
- && $warning eq 'utf8')
- {
+ my $malformations_name = join "/", @malformations;
+ $malformations_name .= " malformation"
+ if $malformations_name;
+ $malformations_name .= "s" if @malformations > 1;
+ my $this_bytes = $bytes;
+ my $this_length = $length;
+ my $expected_uv = $allowed_uv;
+ my $this_expected_len = $expected_len;
+ if ($malformations_name) {
+ $expected_uv = 0;
+
+ # Coerce the input into the desired
+ # malformation
+ if ($malformations_name =~ /overlong/) {
+
+ # For an overlong, we convert the original
+ # start byte into a continuation byte with
+ # the same data bits as originally. ...
+ substr($this_bytes, 0, 1)
+ = start_byte_to_cont(substr($this_bytes,
+ 0, 1));
+
+ # ... Then we prepend it with a known
+ # overlong sequence. This should evaluate
+ # to the exact same code point as the
+ # original.
+ $this_bytes
+ = I8_to_native("\xff")
+ . (I8_to_native(chr $first_continuation)
+ x ( $max_bytes - 1 - length($this_bytes)))
+ . $this_bytes;
+ $this_length = length($this_bytes);
+ $this_expected_len = $max_bytes;
+ push @expected_errors, $UTF8_GOT_LONG;
+ }
+ if ($malformations_name =~ /short/) {
+
+ # Just tell the test to not look far
+ # enough into the input.
+ $this_length--;
+ $this_expected_len--;
+ push @expected_errors, $UTF8_GOT_SHORT;
+ }
+ elsif ($malformations_name
+ =~ /non-continuation/)
+ {
+ # Change the final continuation byte into
+ # a non one.
+ substr($this_bytes, -1, 1) = '?';
+ $this_expected_len--;
+ push @expected_errors,
+ $UTF8_GOT_NON_CONTINUATION;
+ }
+ }
- # Will get the overflow message instead of the expected
- # message under these circumstances, as they would
- # otherwise accept an overflowed value, which the code
- # should not allow, so falls back to overflow.
- if (is(scalar @warnings, 1,
- "$this_name: Got a single warning "))
- {
- unless (like($warnings[0], qr/overflow/,
- "$this_name: Got overflow warning"))
+ my $eval_warn = $do_warning
+ ? "use warnings '$warning'"
+ : $warning eq "utf8"
+ ? "no warnings 'utf8'"
+ : ( "use warnings 'utf8';"
+ . " no warnings '$warning'");
+
+ # Is effectively disallowed if we've set up a
+ # malformation, even if the flag indicates it is
+ # allowed. Fix up test name to indicate this as
+ # well
+ my $disallowed = $disallow_flag
+ || $malformations_name;
+ my $this_name = "utf8n_to_uvchr_error() $testname: "
+ . (($disallow_flag)
+ ? 'disallowed'
+ : $disallowed
+ ? $disallowed
+ : 'allowed');
+ $this_name .= ", $eval_warn";
+ $this_name .= ", " . (($warn_flag)
+ ? 'with warning flag'
+ : 'no warning flag');
+
+ undef @warnings;
+ my $ret_ref;
+ my $display_bytes = display_bytes($this_bytes);
+ my $call = "Call was: $eval_warn; \$ret_ref"
+ . " = test_utf8n_to_uvchr_error("
+ . "'$display_bytes', $this_length,"
+ . "$warn_flag"
+ . "|$disallow_flag)";
+ my $eval_text = "$eval_warn; \$ret_ref"
+ . " = test_utf8n_to_uvchr_error("
+ . "'$this_bytes',"
+ . " $this_length, $warn_flag"
+ . "|$disallow_flag)";
+ eval "$eval_text";
+ if (! ok ("$@ eq ''",
+ "$this_name: eval succeeded"))
{
- diag $call;
+ diag "\$!='$!'; eval'd=\"$call\"";
+ next;
}
- }
- else {
- diag $call;
- if (scalar @warnings) {
- diag "The warnings were: "
- . join(", ", @warnings);
+ if ($disallowed) {
+ unless (is($ret_ref->[0], 0,
+ "$this_name: Returns 0"))
+ {
+ diag $call;
+ }
}
- }
- }
- elsif ($warn_flag
- && ($warning eq 'utf8' || $warning eq $category))
- {
- if (is(scalar @warnings, 1,
- "$this_name: Got a single warning "))
- {
- unless (like($warnings[0], $message,
- "$this_name: Got expected warning"))
+ else {
+ unless (is($ret_ref->[0], $expected_uv,
+ "$this_name: Returns expected uv: "
+ . sprintf("0x%04X", $expected_uv)))
+ {
+ diag $call;
+ }
+ }
+ unless (is($ret_ref->[1], $this_expected_len,
+ "$this_name: Returns expected length:"
+ . " $this_expected_len"))
{
diag $call;
}
- }
- else {
- diag $call;
- if (scalar @warnings) {
- diag "The warnings were: "
- . join(", ", @warnings);
- }
- }
- }
- # Check CHECK_ONLY results when the input is disallowed. Do
- # this when actually disallowed, not just when the
- # $disallow_flag is set
- if ($disallowed) {
- undef @warnings;
- $ret_ref = test_utf8n_to_uvchr($bytes, $length,
- $disallow_flag|$UTF8_CHECK_ONLY);
- unless (is($ret_ref->[0], 0, "$this_name, CHECK_ONLY: Returns 0")) {
- diag $call;
- }
- unless (is($ret_ref->[1], -1,
- "$this_name: CHECK_ONLY: returns -1 for length"))
- {
- diag $call;
- }
- if (! is(scalar @warnings, 0,
- "$this_name, CHECK_ONLY: no warnings generated"))
- {
- diag $call;
- diag "The warnings were: " . join(", ", @warnings);
- }
- }
+ my $errors = $ret_ref->[2];
- # Now repeat some of the above, but for
- # uvchr_to_utf8_flags(). Since this comes from an
- # existing code point, it hasn't overflowed.
- next if $will_overflow;
-
- # The warning and disallow flags passed in are for
- # utf8n_to_uvchr(). Convert them for
- # uvchr_to_utf8_flags().
- my $uvchr_warn_flag = 0;
- my $uvchr_disallow_flag = 0;
- if ($warn_flag) {
- if ($warn_flag == $UTF8_WARN_SURROGATE) {
- $uvchr_warn_flag = $UNICODE_WARN_SURROGATE
- }
- elsif ($warn_flag == $UTF8_WARN_NONCHAR) {
- $uvchr_warn_flag = $UNICODE_WARN_NONCHAR
- }
- elsif ($warn_flag == $UTF8_WARN_SUPER) {
- $uvchr_warn_flag = $UNICODE_WARN_SUPER
- }
- elsif ($warn_flag == $UTF8_WARN_ABOVE_31_BIT) {
- $uvchr_warn_flag = $UNICODE_WARN_ABOVE_31_BIT;
- }
- else {
- fail(sprintf "Unexpected warn flag: %x",
- $warn_flag);
- next;
- }
- }
- if ($disallow_flag) {
- if ($disallow_flag == $UTF8_DISALLOW_SURROGATE) {
- $uvchr_disallow_flag = $UNICODE_DISALLOW_SURROGATE
- }
- elsif ($disallow_flag == $UTF8_DISALLOW_NONCHAR) {
- $uvchr_disallow_flag = $UNICODE_DISALLOW_NONCHAR
- }
- elsif ($disallow_flag == $UTF8_DISALLOW_SUPER) {
- $uvchr_disallow_flag = $UNICODE_DISALLOW_SUPER
- }
- elsif ($disallow_flag == $UTF8_DISALLOW_ABOVE_31_BIT) {
- $uvchr_disallow_flag =
- $UNICODE_DISALLOW_ABOVE_31_BIT;
- }
- else {
- fail(sprintf "Unexpected disallow flag: %x",
- $disallow_flag);
- next;
- }
- }
+ for (my $i = @expected_errors - 1; $i >= 0; $i--) {
+ if (ok($expected_errors[$i] & $errors,
+ "Expected and got error bit return"
+ . " for $malformations[$i] malformation"))
+ {
+ $errors &= ~$expected_errors[$i];
+ }
+ splice @expected_errors, $i, 1;
+ }
+ unless (is(scalar @expected_errors, 0,
+ "Got all the expected malformation errors"))
+ {
+ diag Dumper \@expected_errors;
+ }
- $disallowed = $uvchr_disallow_flag;
+ if ($warn_flag || $disallow_flag) {
+ is($errors, $expected_error_flags,
+ "Got the correct error flag");
+ }
+ else {
+ is($errors, 0, "Got no other error flag");
+ }
- $this_name = "uvchr_to_utf8_flags() $testname: "
- . (($uvchr_disallow_flag)
- ? 'disallowed'
- : ($disallowed)
- ? 'ABOVE_31_BIT allowed'
- : 'allowed');
- $this_name .= ", $eval_warn";
- $this_name .= ", " . (($uvchr_warn_flag)
- ? 'with warning flag'
- : 'no warning flag');
+ if (@malformations) {
+ if (! $do_warning && $warning eq 'utf8') {
+ goto no_warnings_expected;
+ }
+
+ # Check that each malformation generates a
+ # warning, removing that warning if found
+ MALFORMATION:
+ foreach my $malformation (@malformations) {
+ foreach (my $i = 0; $i < @warnings; $i++) {
+ if ($warnings[$i] =~ /$malformation/) {
+ pass("Expected and got"
+ . "'$malformation' warning");
+ splice @warnings, $i, 1;
+ next MALFORMATION;
+ }
+ }
+ fail("Expected '$malformation' warning"
+ . " but didn't get it");
+
+ }
+ }
- undef @warnings;
- my $ret;
- my $warn_flag = sprintf "0x%x", $uvchr_warn_flag;
- my $disallow_flag = sprintf "0x%x", $uvchr_disallow_flag;
- $call = sprintf "call was: $eval_warn; \$ret = test_uvchr_to_utf8_flags(0x%x, $warn_flag|$disallow_flag)", $allowed_uv;
- $eval_text = "$eval_warn; \$ret = test_uvchr_to_utf8_flags($allowed_uv, $warn_flag|$disallow_flag)";
- eval "$eval_text";
- if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
- diag "\$!='$!'; eval'd=\"$eval_text\"";
- next;
- }
- if ($disallowed) {
- unless (is($ret, undef, "$this_name: Returns undef")) {
- diag $call;
- }
- }
- else {
- unless (is($ret, $bytes, "$this_name: Returns expected string")) {
- diag $call;
- }
- }
- if (! $do_warning
- && ($warning eq 'utf8' || $warning eq $category))
- {
- if (!is(scalar @warnings, 0,
- "$this_name: No warnings generated"))
- {
- diag $call;
- diag "The warnings were: " . join(", ", @warnings);
- }
- }
- elsif ($uvchr_warn_flag
- && ($warning eq 'utf8' || $warning eq $category))
- {
- if (is(scalar @warnings, 1,
- "$this_name: Got a single warning "))
- {
- unless (like($warnings[0], $message,
+ # Any overflow will override any super or above-31
+ # warnings.
+ goto no_warnings_expected if $will_overflow;
+
+ if ( ! $do_warning
+ && ( $warning eq 'utf8'
+ || $warning eq $category))
+ {
+ goto no_warnings_expected;
+ }
+ elsif ($warn_flag) {
+ if (is(scalar @warnings, 1,
+ "$this_name: Got a single warning "))
+ {
+ unless (like($warnings[0], $message,
"$this_name: Got expected warning"))
+ {
+ diag $call;
+ }
+ }
+ else {
+ diag $call;
+ if (scalar @warnings) {
+ output_warnings(@warnings);
+ }
+ }
+ }
+ else {
+ no_warnings_expected:
+ unless (is(scalar @warnings, 0,
+ "$this_name: Got no warnings"))
+ {
+ diag $call;
+ output_warnings(@warnings);
+ }
+ }
+
+ # Check CHECK_ONLY results when the input is
+ # disallowed. Do this when actually disallowed,
+ # not just when the $disallow_flag is set
+ if ($disallowed) {
+ undef @warnings;
+ $ret_ref = test_utf8n_to_uvchr_error(
+ $this_bytes, $this_length,
+ $disallow_flag|$UTF8_CHECK_ONLY);
+ unless (is($ret_ref->[0], 0,
+ "$this_name, CHECK_ONLY: Returns 0"))
+ {
+ diag $call;
+ }
+ unless (is($ret_ref->[1], -1,
+ "$this_name: CHECK_ONLY: returns -1 for"
+ . " length"))
+ {
+ diag $call;
+ }
+ if (! is(scalar @warnings, 0,
+ "$this_name, CHECK_ONLY: no warnings"
+ . " generated"))
+ {
+ diag $call;
+ output_warnings(@warnings);
+ }
+ }
+
+ # Now repeat some of the above, but for
+ # uvchr_to_utf8_flags(). Since this comes from an
+ # existing code point, it hasn't overflowed, and
+ # isn't malformed.
+ next if @malformations;
+
+ # The warning and disallow flags passed in are for
+ # utf8n_to_uvchr_error(). Convert them for
+ # uvchr_to_utf8_flags().
+ my $uvchr_warn_flag = 0;
+ my $uvchr_disallow_flag = 0;
+ if ($warn_flag) {
+ if ($warn_flag == $UTF8_WARN_SURROGATE) {
+ $uvchr_warn_flag = $UNICODE_WARN_SURROGATE
+ }
+ elsif ($warn_flag == $UTF8_WARN_NONCHAR) {
+ $uvchr_warn_flag = $UNICODE_WARN_NONCHAR
+ }
+ elsif ($warn_flag == $UTF8_WARN_SUPER) {
+ $uvchr_warn_flag = $UNICODE_WARN_SUPER
+ }
+ elsif ($warn_flag == $UTF8_WARN_ABOVE_31_BIT) {
+ $uvchr_warn_flag
+ = $UNICODE_WARN_ABOVE_31_BIT;
+ }
+ else {
+ fail(sprintf "Unexpected warn flag: %x",
+ $warn_flag);
+ next;
+ }
+ }
+ if ($disallow_flag) {
+ if ($disallow_flag == $UTF8_DISALLOW_SURROGATE)
+ {
+ $uvchr_disallow_flag
+ = $UNICODE_DISALLOW_SURROGATE;
+ }
+ elsif ($disallow_flag == $UTF8_DISALLOW_NONCHAR)
+ {
+ $uvchr_disallow_flag
+ = $UNICODE_DISALLOW_NONCHAR;
+ }
+ elsif ($disallow_flag == $UTF8_DISALLOW_SUPER) {
+ $uvchr_disallow_flag
+ = $UNICODE_DISALLOW_SUPER;
+ }
+ elsif ($disallow_flag
+ == $UTF8_DISALLOW_ABOVE_31_BIT)
+ {
+ $uvchr_disallow_flag =
+ $UNICODE_DISALLOW_ABOVE_31_BIT;
+ }
+ else {
+ fail(sprintf "Unexpected disallow flag: %x",
+ $disallow_flag);
+ next;
+ }
+ }
+
+ $disallowed = $uvchr_disallow_flag;
+
+ $this_name = "uvchr_to_utf8_flags() $testname: "
+ . (($uvchr_disallow_flag)
+ ? 'disallowed'
+ : ($disallowed)
+ ? 'ABOVE_31_BIT allowed'
+ : 'allowed');
+ $this_name .= ", $eval_warn";
+ $this_name .= ", " . (($uvchr_warn_flag)
+ ? 'with warning flag'
+ : 'no warning flag');
+
+ undef @warnings;
+ my $ret;
+ my $warn_flag = sprintf "0x%x", $uvchr_warn_flag;
+ my $disallow_flag = sprintf "0x%x",
+ $uvchr_disallow_flag;
+ $call = sprintf("call was: $eval_warn; \$ret"
+ . " = test_uvchr_to_utf8_flags("
+ . " 0x%x, $warn_flag|$disallow_flag)",
+ $allowed_uv);
+ $eval_text = "$eval_warn; \$ret ="
+ . " test_uvchr_to_utf8_flags("
+ . "$allowed_uv, $warn_flag|"
+ . "$disallow_flag)";
+ eval "$eval_text";
+ if (! ok ("$@ eq ''", "$this_name: eval succeeded"))
{
- diag $call;
+ diag "\$!='$!'; eval'd=\"$eval_text\"";
+ next;
}
- }
- else {
- diag $call;
- if (scalar @warnings) {
- diag "The warnings were: "
- . join(", ", @warnings);
+ if ($disallowed) {
+ unless (is($ret, undef,
+ "$this_name: Returns undef"))
+ {
+ diag $call;
+ }
+ }
+ else {
+ unless (is($ret, $bytes,
+ "$this_name: Returns expected string"))
+ {
+ diag $call;
+ }
+ }
+ if (! $do_warning
+ && ($warning eq 'utf8' || $warning eq $category))
+ {
+ if (!is(scalar @warnings, 0,
+ "$this_name: No warnings generated"))
+ {
+ diag $call;
+ output_warnings(@warnings);
+ }
+ }
+ elsif ( $uvchr_warn_flag
+ && ( $warning eq 'utf8'
+ || $warning eq $category))
+ {
+ if (is(scalar @warnings, 1,
+ "$this_name: Got a single warning "))
+ {
+ unless (like($warnings[0], $message,
+ "$this_name: Got expected warning"))
+ {
+ diag $call;
+ }
+ }
+ else {
+ diag $call;
+ output_warnings(@warnings)
+ if scalar @warnings;
+ }
}
}
}
}
}
+SKIP:
+{
+ isASCII
+ or skip "These tests probably break on non-ASCII", 1;
+ my $simple = join "", "A" .. "J";
+ my $utf_ch = "\x{7fffffff}";
+ utf8::encode($utf_ch);
+ my $utf_ch_len = length $utf_ch;
+ note "utf_ch_len $utf_ch_len";
+ my $utf = $utf_ch x 10;
+ my $bad_start = substr($utf, 1);
+ # $bad_end ends with a start byte and a single continuation
+ my $bad_end = substr($utf, 0, length($utf)-$utf_ch_len+2);
+
+ # WARNING: all offsets are *byte* offsets
+ my @hop_tests =
+ (
+ # string s off expected name
+ [ $simple, 0, 5, 5, "simple in range, forward" ],
+ [ $simple, 10, -5, 5, "simple in range, backward" ],
+ [ $simple, 5, 10, 10, "simple out of range, forward" ],
+ [ $simple, 5, -10, 0, "simple out of range, backward" ],
+ [ $utf, $utf_ch_len * 5, 5, length($utf), "utf in range, forward" ],
+ [ $utf, $utf_ch_len * 5, -5, 0, "utf in range, backward" ],
+ [ $utf, $utf_ch_len * 5, 4, $utf_ch_len * 9, "utf in range b, forward" ],
+ [ $utf, $utf_ch_len * 5, -4, $utf_ch_len, "utf in range b, backward" ],
+ [ $utf, $utf_ch_len * 5, 6, length($utf), "utf out of range, forward" ],
+ [ $utf, $utf_ch_len * 5, -6, 0, "utf out of range, backward" ],
+ [ $bad_start, 0, 1, 1, "bad start, forward 1 from 0" ],
+ [ $bad_start, 0, $utf_ch_len-1, $utf_ch_len-1, "bad start, forward ch_len-1 from 0" ],
+ [ $bad_start, 0, $utf_ch_len, $utf_ch_len*2-1, "bad start, forward ch_len from 0" ],
+ [ $bad_start, $utf_ch_len-1, -1, 0, "bad start, back 1 from first start byte" ],
+ [ $bad_start, $utf_ch_len-2, -1, 0, "bad start, back 1 from before first start byte" ],
+ [ $bad_start, 0, -1, 0, "bad start, back 1 from 0" ],
+ [ $bad_start, length $bad_start, -10, 0, "bad start, back 10 from end" ],
+ [ $bad_end, 0, 10, length $bad_end, "bad end, forward 10 from 0" ],
+ [ $bad_end, length($bad_end)-1, 10, length $bad_end, "bad end, forward 1 from end-1" ],
+ );
+
+ for my $test (@hop_tests) {
+ my ($str, $s_off, $off, $want, $name) = @$test;
+ my $result = test_utf8_hop_safe($str, $s_off, $off);
+ is($result, $want, "utf8_hop_safe: $name");
+ }
+}
+
done_testing;
https://perl5.git.perl.org / perl5.git / blobdiff