This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
APItest/t/utf8.t: Fix EBCDIC test
[perl5.git] / ext / XS-APItest / t / utf8.t
CommitLineData
fed3ba5d
NC		 1#!perl -w
2
3use strict;
4use Test::More;
7dfd8446 5$|=1;
fed3ba5d 6
760c7c2f
KW		 7no warnings 'deprecated'; # Some of the below are above IV_MAX on 32 bit
8 # machines, and that is tested elsewhere
9
fed3ba5d
NC		 10use XS::APItest;
11
4deba822
KW		 12my $pound_sign = chr utf8::unicode_to_native(163);
13
7dfd8446
KW		 14sub isASCII { ord "A" == 65 }
15
16sub display_bytes {
9d2d0ecd 17 use bytes;
7dfd8446
KW		 18 my $string = shift;
19 return '"'
20 . join("", map { sprintf("\\x%02x", ord $_) } split "", $string)
21 . '"';
22}
23
24# This test file can't use byte_utf8a_to_utf8n() from t/charset_tools.pl
25# because that uses the same functions we are testing here. So UTF-EBCDIC
26# strings are hard-coded as I8 strings in this file instead, and we use array
27# lookup to translate into the appropriate code page.
28
29my @i8_to_native = ( # Only code page 1047 so far.
30# _0 _1 _2 _3 _4 _5 _6 _7 _8 _9 _A _B _C _D _E _F
310x00,0x01,0x02,0x03,0x37,0x2D,0x2E,0x2F,0x16,0x05,0x15,0x0B,0x0C,0x0D,0x0E,0x0F,
320x10,0x11,0x12,0x13,0x3C,0x3D,0x32,0x26,0x18,0x19,0x3F,0x27,0x1C,0x1D,0x1E,0x1F,
330x40,0x5A,0x7F,0x7B,0x5B,0x6C,0x50,0x7D,0x4D,0x5D,0x5C,0x4E,0x6B,0x60,0x4B,0x61,
340xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0x7A,0x5E,0x4C,0x7E,0x6E,0x6F,
350x7C,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6,
360xD7,0xD8,0xD9,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xE9,0xAD,0xE0,0xBD,0x5F,0x6D,
370x79,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x91,0x92,0x93,0x94,0x95,0x96,
380x97,0x98,0x99,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xC0,0x4F,0xD0,0xA1,0x07,
390x20,0x21,0x22,0x23,0x24,0x25,0x06,0x17,0x28,0x29,0x2A,0x2B,0x2C,0x09,0x0A,0x1B,
400x30,0x31,0x1A,0x33,0x34,0x35,0x36,0x08,0x38,0x39,0x3A,0x3B,0x04,0x14,0x3E,0xFF,
410x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x51,0x52,0x53,0x54,0x55,0x56,
420x57,0x58,0x59,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x70,0x71,0x72,0x73,
430x74,0x75,0x76,0x77,0x78,0x80,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,0x90,0x9A,0x9B,0x9C,
440x9D,0x9E,0x9F,0xA0,0xAA,0xAB,0xAC,0xAE,0xAF,0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6,
450xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBE,0xBF,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,0xDA,0xDB,
460xDC,0xDD,0xDE,0xDF,0xE1,0xEA,0xEB,0xEC,0xED,0xEE,0xEF,0xFA,0xFB,0xFC,0xFD,0xFE,
47);
48
418080dc
KW		 49my @native_to_i8;
50for (my $i = 0; $i < 256; $i++) {
51 $native_to_i8[$i8_to_native[$i]] = $i;
52}
53
7dfd8446
KW		 54*I8_to_native = (isASCII)
55 ? sub { return shift }
56 : sub { return join "", map { chr $i8_to_native[ord $_] }
57 split "", shift };
418080dc
KW		 58*native_to_I8 = (isASCII)
59 ? sub { return shift }
60 : sub { return join "", map { chr $native_to_i8[ord $_] }
61 split "", shift };
7dfd8446
KW		 62
63my $is64bit = length sprintf("%x", ~0) > 8;
64
65
66# Test utf8n_to_uvchr(). These provide essentially complete code coverage.
67# Copied from utf8.h
68my $UTF8_ALLOW_EMPTY = 0x0001;
69my $UTF8_ALLOW_CONTINUATION = 0x0002;
70my $UTF8_ALLOW_NON_CONTINUATION = 0x0004;
71my $UTF8_ALLOW_SHORT = 0x0008;
72my $UTF8_ALLOW_LONG = 0x0010;
73my $UTF8_DISALLOW_SURROGATE = 0x0020;
74my $UTF8_WARN_SURROGATE = 0x0040;
75my $UTF8_DISALLOW_NONCHAR = 0x0080;
76my $UTF8_WARN_NONCHAR = 0x0100;
77my $UTF8_DISALLOW_SUPER = 0x0200;
78my $UTF8_WARN_SUPER = 0x0400;
1d1c12d9
KW		 79my $UTF8_DISALLOW_ABOVE_31_BIT = 0x0800;
80my $UTF8_WARN_ABOVE_31_BIT = 0x1000;
7dfd8446 81my $UTF8_CHECK_ONLY = 0x2000;
25e3a4e0
KW		 82my $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE
83 = $UTF8_DISALLOW_SUPER|$UTF8_DISALLOW_SURROGATE;
84my $UTF8_DISALLOW_ILLEGAL_INTERCHANGE
85 = $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE|$UTF8_DISALLOW_NONCHAR;
7dfd8446 86
046d01eb
KW		 87# Test uvchr_to_utf8().
88my $UNICODE_WARN_SURROGATE = 0x0001;
89my $UNICODE_WARN_NONCHAR = 0x0002;
90my $UNICODE_WARN_SUPER = 0x0004;
91my $UNICODE_WARN_ABOVE_31_BIT = 0x0008;
92my $UNICODE_DISALLOW_SURROGATE = 0x0010;
93my $UNICODE_DISALLOW_NONCHAR = 0x0020;
94my $UNICODE_DISALLOW_SUPER = 0x0040;
95my $UNICODE_DISALLOW_ABOVE_31_BIT = 0x0080;
96
97my $look_for_everything_utf8n_to
98 = $UTF8_DISALLOW_SURROGATE
7dfd8446
KW		 99 | $UTF8_WARN_SURROGATE
100 | $UTF8_DISALLOW_NONCHAR
101 | $UTF8_WARN_NONCHAR
102 | $UTF8_DISALLOW_SUPER
103 | $UTF8_WARN_SUPER
1d1c12d9
KW		 104 | $UTF8_DISALLOW_ABOVE_31_BIT
105 | $UTF8_WARN_ABOVE_31_BIT;
046d01eb
KW		 106my $look_for_everything_uvchr_to
107 = $UNICODE_DISALLOW_SURROGATE
108 | $UNICODE_WARN_SURROGATE
109 | $UNICODE_DISALLOW_NONCHAR
110 | $UNICODE_WARN_NONCHAR
111 | $UNICODE_DISALLOW_SUPER
112 | $UNICODE_WARN_SUPER
113 | $UNICODE_DISALLOW_ABOVE_31_BIT
114 | $UNICODE_WARN_ABOVE_31_BIT;
7dfd8446 115
fed3ba5d
NC		 116foreach ([0, '', '', 'empty'],
117 [0, 'N', 'N', '1 char'],
118 [1, 'NN', 'N', '1 char substring'],
119 [-2, 'Perl', 'Rules', 'different'],
4deba822
KW		 120 [0, $pound_sign, $pound_sign, 'pound sign'],
121 [1, $pound_sign . 10, $pound_sign . 1, '10 pounds is more than 1 pound'],
122 [1, $pound_sign . $pound_sign, $pound_sign, '2 pound signs are more than 1'],
fed3ba5d
NC		 123 [-2, ' $!', " \x{1F42B}!", 'Camels are worth more than 1 dollar'],
124 [-1, '!', "!\x{1F42A}", 'Initial substrings match'],
125 ) {
126 my ($expect, $left, $right, $desc) = @$_;
127 my $copy = $right;
128 utf8::encode($copy);
129 is(bytes_cmp_utf8($left, $copy), $expect, $desc);
130 next if $right =~ tr/\0-\377//c;
131 utf8::encode($left);
132 is(bytes_cmp_utf8($right, $left), -$expect, "$desc reversed");
133}
134
7dfd8446
KW		 135# The keys to this hash are Unicode code points, their values are the native
136# UTF-8 representations of them. The code points are chosen because they are
137# "interesting" on either or both ASCII and EBCDIC platforms. First we add
138# boundaries where the number of bytes required to represent them increase, or
139# are adjacent to problematic code points, so we want to make sure they aren't
140# considered problematic.
141my %code_points = (
142 0x0100 => (isASCII) ? "\xc4\x80" : I8_to_native("\xc8\xa0"),
143 0x0400 - 1 => (isASCII) ? "\xcf\xbf" : I8_to_native("\xdf\xbf"),
144 0x0400 => (isASCII) ? "\xd0\x80" : I8_to_native("\xe1\xa0\xa0"),
145 0x0800 - 1 => (isASCII) ? "\xdf\xbf" : I8_to_native("\xe1\xbf\xbf"),
146 0x0800 => (isASCII) ? "\xe0\xa0\x80" : I8_to_native("\xe2\xa0\xa0"),
147 0x4000 - 1 => (isASCII) ? "\xe3\xbf\xbf" : I8_to_native("\xef\xbf\xbf"),
148 0x4000 => (isASCII) ? "\xe4\x80\x80" : I8_to_native("\xf0\xb0\xa0\xa0"),
149 0x8000 - 1 => (isASCII) ? "\xe7\xbf\xbf" : I8_to_native("\xf0\xbf\xbf\xbf"),
150
151 # First code point that the implementation of isUTF8_POSSIBLY_PROBLEMATIC,
152 # as of this writing, considers potentially problematic on EBCDIC
153 0x8000 => (isASCII) ? "\xe8\x80\x80" : I8_to_native("\xf1\xa0\xa0\xa0"),
154
155 0xD000 - 1 => (isASCII) ? "\xec\xbf\xbf" : I8_to_native("\xf1\xb3\xbf\xbf"),
156
157 # First code point that the implementation of isUTF8_POSSIBLY_PROBLEMATIC,
158 # as of this writing, considers potentially problematic on ASCII
159 0xD000 => (isASCII) ? "\xed\x80\x80" : I8_to_native("\xf1\xb4\xa0\xa0"),
160
5f8a3d1d 161 # Bracket the surrogates, and include several surrogates
7dfd8446 162 0xD7FF => (isASCII) ? "\xed\x9f\xbf" : I8_to_native("\xf1\xb5\xbf\xbf"),
5f8a3d1d
KW		 163 0xD800 => (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"),
164 0xDC00 => (isASCII) ? "\xed\xb0\x80" : I8_to_native("\xf1\xb7\xa0\xa0"),
165 0xDFFF => (isASCII) ? "\xee\x80\x80" : I8_to_native("\xf1\xb8\xa0\xa0"),
166 0xDFFF => (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"),
7dfd8446
KW		 167 0xE000 => (isASCII) ? "\xee\x80\x80" : I8_to_native("\xf1\xb8\xa0\xa0"),
168
5f8a3d1d 169 # Include the 32 contiguous non characters, and surrounding code points
7dfd8446 170 0xFDCF => (isASCII) ? "\xef\xb7\x8f" : I8_to_native("\xf1\xbf\xae\xaf"),
5f8a3d1d
KW		 171 0xFDD0 => (isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"),
172 0xFDD1 => (isASCII) ? "\xef\xb7\x91" : I8_to_native("\xf1\xbf\xae\xb1"),
173 0xFDD2 => (isASCII) ? "\xef\xb7\x92" : I8_to_native("\xf1\xbf\xae\xb2"),
174 0xFDD3 => (isASCII) ? "\xef\xb7\x93" : I8_to_native("\xf1\xbf\xae\xb3"),
175 0xFDD4 => (isASCII) ? "\xef\xb7\x94" : I8_to_native("\xf1\xbf\xae\xb4"),
176 0xFDD5 => (isASCII) ? "\xef\xb7\x95" : I8_to_native("\xf1\xbf\xae\xb5"),
177 0xFDD6 => (isASCII) ? "\xef\xb7\x96" : I8_to_native("\xf1\xbf\xae\xb6"),
178 0xFDD7 => (isASCII) ? "\xef\xb7\x97" : I8_to_native("\xf1\xbf\xae\xb7"),
179 0xFDD8 => (isASCII) ? "\xef\xb7\x98" : I8_to_native("\xf1\xbf\xae\xb8"),
180 0xFDD9 => (isASCII) ? "\xef\xb7\x99" : I8_to_native("\xf1\xbf\xae\xb9"),
181 0xFDDA => (isASCII) ? "\xef\xb7\x9a" : I8_to_native("\xf1\xbf\xae\xba"),
182 0xFDDB => (isASCII) ? "\xef\xb7\x9b" : I8_to_native("\xf1\xbf\xae\xbb"),
183 0xFDDC => (isASCII) ? "\xef\xb7\x9c" : I8_to_native("\xf1\xbf\xae\xbc"),
184 0xFDDD => (isASCII) ? "\xef\xb7\x9d" : I8_to_native("\xf1\xbf\xae\xbd"),
185 0xFDDE => (isASCII) ? "\xef\xb7\x9e" : I8_to_native("\xf1\xbf\xae\xbe"),
186 0xFDDF => (isASCII) ? "\xef\xb7\x9f" : I8_to_native("\xf1\xbf\xae\xbf"),
187 0xFDE0 => (isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"),
188 0xFDE1 => (isASCII) ? "\xef\xb7\xa1" : I8_to_native("\xf1\xbf\xaf\xa1"),
189 0xFDE2 => (isASCII) ? "\xef\xb7\xa2" : I8_to_native("\xf1\xbf\xaf\xa2"),
190 0xFDE3 => (isASCII) ? "\xef\xb7\xa3" : I8_to_native("\xf1\xbf\xaf\xa3"),
191 0xFDE4 => (isASCII) ? "\xef\xb7\xa4" : I8_to_native("\xf1\xbf\xaf\xa4"),
192 0xFDE5 => (isASCII) ? "\xef\xb7\xa5" : I8_to_native("\xf1\xbf\xaf\xa5"),
193 0xFDE6 => (isASCII) ? "\xef\xb7\xa6" : I8_to_native("\xf1\xbf\xaf\xa6"),
194 0xFDE7 => (isASCII) ? "\xef\xb7\xa7" : I8_to_native("\xf1\xbf\xaf\xa7"),
195 0xFDE8 => (isASCII) ? "\xef\xb7\xa8" : I8_to_native("\xf1\xbf\xaf\xa8"),
196 0xFDEa => (isASCII) ? "\xef\xb7\x99" : I8_to_native("\xf1\xbf\xaf\xa9"),
197 0xFDEA => (isASCII) ? "\xef\xb7\xaa" : I8_to_native("\xf1\xbf\xaf\xaa"),
198 0xFDEB => (isASCII) ? "\xef\xb7\xab" : I8_to_native("\xf1\xbf\xaf\xab"),
199 0xFDEC => (isASCII) ? "\xef\xb7\xac" : I8_to_native("\xf1\xbf\xaf\xac"),
200 0xFDED => (isASCII) ? "\xef\xb7\xad" : I8_to_native("\xf1\xbf\xaf\xad"),
a9e5eeaa 201 0xFDEE => (isASCII) ? "\xef\xb7\xae" : I8_to_native("\xf1\xbf\xaf\xae"),
5f8a3d1d 202 0xFDEF => (isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"),
7dfd8446
KW		 203 0xFDF0 => (isASCII) ? "\xef\xb7\xb0" : I8_to_native("\xf1\xbf\xaf\xb0"),
204
5f8a3d1d 205 # Mostly around non-characters, but some are transitions to longer strings
7dfd8446
KW		 206 0xFFFD => (isASCII) ? "\xef\xbf\xbd" : I8_to_native("\xf1\xbf\xbf\xbd"),
207 0x10000 - 1 => (isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"),
208 0x10000 => (isASCII) ? "\xf0\x90\x80\x80" : I8_to_native("\xf2\xa0\xa0\xa0"),
209 0x1FFFD => (isASCII) ? "\xf0\x9f\xbf\xbd" : I8_to_native("\xf3\xbf\xbf\xbd"),
5f8a3d1d
KW		 210 0x1FFFE => (isASCII) ? "\xf0\x9f\xbf\xbe" : I8_to_native("\xf3\xbf\xbf\xbe"),
211 0x1FFFF => (isASCII) ? "\xf0\x9f\xbf\xbf" : I8_to_native("\xf3\xbf\xbf\xbf"),
7dfd8446
KW		 212 0x20000 => (isASCII) ? "\xf0\xa0\x80\x80" : I8_to_native("\xf4\xa0\xa0\xa0"),
213 0x2FFFD => (isASCII) ? "\xf0\xaf\xbf\xbd" : I8_to_native("\xf5\xbf\xbf\xbd"),
5f8a3d1d
KW		 214 0x2FFFE => (isASCII) ? "\xf0\xaf\xbf\xbe" : I8_to_native("\xf5\xbf\xbf\xbe"),
215 0x2FFFF => (isASCII) ? "\xf0\xaf\xbf\xbf" : I8_to_native("\xf5\xbf\xbf\xbf"),
7dfd8446
KW		 216 0x30000 => (isASCII) ? "\xf0\xb0\x80\x80" : I8_to_native("\xf6\xa0\xa0\xa0"),
217 0x3FFFD => (isASCII) ? "\xf0\xbf\xbf\xbd" : I8_to_native("\xf7\xbf\xbf\xbd"),
5f8a3d1d 218 0x3FFFE => (isASCII) ? "\xf0\xbf\xbf\xbe" : I8_to_native("\xf7\xbf\xbf\xbe"),
7dfd8446
KW		 219 0x40000 - 1 => (isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"),
220 0x40000 => (isASCII) ? "\xf1\x80\x80\x80" : I8_to_native("\xf8\xa8\xa0\xa0\xa0"),
221 0x4FFFD => (isASCII) ? "\xf1\x8f\xbf\xbd" : I8_to_native("\xf8\xa9\xbf\xbf\xbd"),
5f8a3d1d
KW		 222 0x4FFFE => (isASCII) ? "\xf1\x8f\xbf\xbe" : I8_to_native("\xf8\xa9\xbf\xbf\xbe"),
223 0x4FFFF => (isASCII) ? "\xf1\x8f\xbf\xbf" : I8_to_native("\xf8\xa9\xbf\xbf\xbf"),
7dfd8446
KW		 224 0x50000 => (isASCII) ? "\xf1\x90\x80\x80" : I8_to_native("\xf8\xaa\xa0\xa0\xa0"),
225 0x5FFFD => (isASCII) ? "\xf1\x9f\xbf\xbd" : I8_to_native("\xf8\xab\xbf\xbf\xbd"),
5f8a3d1d
KW		 226 0x5FFFE => (isASCII) ? "\xf1\x9f\xbf\xbe" : I8_to_native("\xf8\xab\xbf\xbf\xbe"),
227 0x5FFFF => (isASCII) ? "\xf1\x9f\xbf\xbf" : I8_to_native("\xf8\xab\xbf\xbf\xbf"),
7dfd8446
KW		 228 0x60000 => (isASCII) ? "\xf1\xa0\x80\x80" : I8_to_native("\xf8\xac\xa0\xa0\xa0"),
229 0x6FFFD => (isASCII) ? "\xf1\xaf\xbf\xbd" : I8_to_native("\xf8\xad\xbf\xbf\xbd"),
5f8a3d1d
KW		 230 0x6FFFE => (isASCII) ? "\xf1\xaf\xbf\xbe" : I8_to_native("\xf8\xad\xbf\xbf\xbe"),
231 0x6FFFF => (isASCII) ? "\xf1\xaf\xbf\xbf" : I8_to_native("\xf8\xad\xbf\xbf\xbf"),
7dfd8446
KW		 232 0x70000 => (isASCII) ? "\xf1\xb0\x80\x80" : I8_to_native("\xf8\xae\xa0\xa0\xa0"),
233 0x7FFFD => (isASCII) ? "\xf1\xbf\xbf\xbd" : I8_to_native("\xf8\xaf\xbf\xbf\xbd"),
5f8a3d1d
KW		 234 0x7FFFE => (isASCII) ? "\xf1\xbf\xbf\xbe" : I8_to_native("\xf8\xaf\xbf\xbf\xbe"),
235 0x7FFFF => (isASCII) ? "\xf1\xbf\xbf\xbf" : I8_to_native("\xf8\xaf\xbf\xbf\xbf"),
7dfd8446
KW		 236 0x80000 => (isASCII) ? "\xf2\x80\x80\x80" : I8_to_native("\xf8\xb0\xa0\xa0\xa0"),
237 0x8FFFD => (isASCII) ? "\xf2\x8f\xbf\xbd" : I8_to_native("\xf8\xb1\xbf\xbf\xbd"),
5f8a3d1d
KW		 238 0x8FFFE => (isASCII) ? "\xf2\x8f\xbf\xbe" : I8_to_native("\xf8\xb1\xbf\xbf\xbe"),
239 0x8FFFF => (isASCII) ? "\xf2\x8f\xbf\xbf" : I8_to_native("\xf8\xb1\xbf\xbf\xbf"),
7dfd8446
KW		 240 0x90000 => (isASCII) ? "\xf2\x90\x80\x80" : I8_to_native("\xf8\xb2\xa0\xa0\xa0"),
241 0x9FFFD => (isASCII) ? "\xf2\x9f\xbf\xbd" : I8_to_native("\xf8\xb3\xbf\xbf\xbd"),
5f8a3d1d
KW		 242 0x9FFFE => (isASCII) ? "\xf2\x9f\xbf\xbe" : I8_to_native("\xf8\xb3\xbf\xbf\xbe"),
243 0x9FFFF => (isASCII) ? "\xf2\x9f\xbf\xbf" : I8_to_native("\xf8\xb3\xbf\xbf\xbf"),
7dfd8446
KW		 244 0xA0000 => (isASCII) ? "\xf2\xa0\x80\x80" : I8_to_native("\xf8\xb4\xa0\xa0\xa0"),
245 0xAFFFD => (isASCII) ? "\xf2\xaf\xbf\xbd" : I8_to_native("\xf8\xb5\xbf\xbf\xbd"),
5f8a3d1d
KW		 246 0xAFFFE => (isASCII) ? "\xf2\xaf\xbf\xbe" : I8_to_native("\xf8\xb5\xbf\xbf\xbe"),
247 0xAFFFF => (isASCII) ? "\xf2\xaf\xbf\xbf" : I8_to_native("\xf8\xb5\xbf\xbf\xbf"),
7dfd8446
KW		 248 0xB0000 => (isASCII) ? "\xf2\xb0\x80\x80" : I8_to_native("\xf8\xb6\xa0\xa0\xa0"),
249 0xBFFFD => (isASCII) ? "\xf2\xbf\xbf\xbd" : I8_to_native("\xf8\xb7\xbf\xbf\xbd"),
5f8a3d1d
KW		 250 0xBFFFE => (isASCII) ? "\xf2\xbf\xbf\xbe" : I8_to_native("\xf8\xb7\xbf\xbf\xbe"),
251 0xBFFFF => (isASCII) ? "\xf2\xbf\xbf\xbf" : I8_to_native("\xf8\xb7\xbf\xbf\xbf"),
7dfd8446
KW		 252 0xC0000 => (isASCII) ? "\xf3\x80\x80\x80" : I8_to_native("\xf8\xb8\xa0\xa0\xa0"),
253 0xCFFFD => (isASCII) ? "\xf3\x8f\xbf\xbd" : I8_to_native("\xf8\xb9\xbf\xbf\xbd"),
5f8a3d1d
KW		 254 0xCFFFE => (isASCII) ? "\xf3\x8f\xbf\xbe" : I8_to_native("\xf8\xb9\xbf\xbf\xbe"),
255 0xCFFFF => (isASCII) ? "\xf3\x8f\xbf\xbf" : I8_to_native("\xf8\xb9\xbf\xbf\xbf"),
7dfd8446
KW		 256 0xD0000 => (isASCII) ? "\xf3\x90\x80\x80" : I8_to_native("\xf8\xba\xa0\xa0\xa0"),
257 0xDFFFD => (isASCII) ? "\xf3\x9f\xbf\xbd" : I8_to_native("\xf8\xbb\xbf\xbf\xbd"),
5f8a3d1d
KW		 258 0xDFFFE => (isASCII) ? "\xf3\x9f\xbf\xbe" : I8_to_native("\xf8\xbb\xbf\xbf\xbe"),
259 0xDFFFF => (isASCII) ? "\xf3\x9f\xbf\xbf" : I8_to_native("\xf8\xbb\xbf\xbf\xbf"),
7dfd8446
KW		 260 0xE0000 => (isASCII) ? "\xf3\xa0\x80\x80" : I8_to_native("\xf8\xbc\xa0\xa0\xa0"),
261 0xEFFFD => (isASCII) ? "\xf3\xaf\xbf\xbd" : I8_to_native("\xf8\xbd\xbf\xbf\xbd"),
5f8a3d1d
KW		 262 0xEFFFE => (isASCII) ? "\xf3\xaf\xbf\xbe" : I8_to_native("\xf8\xbd\xbf\xbf\xbe"),
263 0xEFFFF => (isASCII) ? "\xf3\xaf\xbf\xbf" : I8_to_native("\xf8\xbd\xbf\xbf\xbf"),
7dfd8446
KW		 264 0xF0000 => (isASCII) ? "\xf3\xb0\x80\x80" : I8_to_native("\xf8\xbe\xa0\xa0\xa0"),
265 0xFFFFD => (isASCII) ? "\xf3\xbf\xbf\xbd" : I8_to_native("\xf8\xbf\xbf\xbf\xbd"),
5f8a3d1d
KW		 266 0xFFFFE => (isASCII) ? "\xf3\xbf\xbf\xbe" : I8_to_native("\xf8\xbf\xbf\xbf\xbe"),
267 0xFFFFF => (isASCII) ? "\xf3\xbf\xbf\xbf" : I8_to_native("\xf8\xbf\xbf\xbf\xbf"),
7dfd8446
KW		 268 0x100000 => (isASCII) ? "\xf4\x80\x80\x80" : I8_to_native("\xf9\xa0\xa0\xa0\xa0"),
269 0x10FFFD => (isASCII) ? "\xf4\x8f\xbf\xbd" : I8_to_native("\xf9\xa1\xbf\xbf\xbd"),
5f8a3d1d
KW		 270 0x10FFFE => (isASCII) ? "\xf4\x8f\xbf\xbe" : I8_to_native("\xf9\xa1\xbf\xbf\xbe"),
271 0x10FFFF => (isASCII) ? "\xf4\x8f\xbf\xbf" : I8_to_native("\xf9\xa1\xbf\xbf\xbf"),
7dfd8446
KW		 272 0x110000 => (isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"),
273
274 # Things that would be noncharacters if they were in Unicode, and might be
275 # mistaken, if the C code is bad, to be nonchars
276 0x11FFFE => (isASCII) ? "\xf4\x9f\xbf\xbe" : I8_to_native("\xf9\xa3\xbf\xbf\xbe"),
277 0x11FFFF => (isASCII) ? "\xf4\x9f\xbf\xbf" : I8_to_native("\xf9\xa3\xbf\xbf\xbf"),
278 0x20FFFE => (isASCII) ? "\xf8\x88\x8f\xbf\xbe" : I8_to_native("\xfa\xa1\xbf\xbf\xbe"),
279 0x20FFFF => (isASCII) ? "\xf8\x88\x8f\xbf\xbf" : I8_to_native("\xfa\xa1\xbf\xbf\xbf"),
280
281 0x200000 - 1 => (isASCII) ? "\xf7\xbf\xbf\xbf" : I8_to_native("\xf9\xbf\xbf\xbf\xbf"),
282 0x200000 => (isASCII) ? "\xf8\x88\x80\x80\x80" : I8_to_native("\xfa\xa0\xa0\xa0\xa0"),
283 0x400000 - 1 => (isASCII) ? "\xf8\x8f\xbf\xbf\xbf" : I8_to_native("\xfb\xbf\xbf\xbf\xbf"),
284 0x400000 => (isASCII) ? "\xf8\x90\x80\x80\x80" : I8_to_native("\xfc\xa4\xa0\xa0\xa0\xa0"),
285 0x4000000 - 1 => (isASCII) ? "\xfb\xbf\xbf\xbf\xbf" : I8_to_native("\xfd\xbf\xbf\xbf\xbf\xbf"),
286 0x4000000 => (isASCII) ? "\xfc\x84\x80\x80\x80\x80" : I8_to_native("\xfe\xa2\xa0\xa0\xa0\xa0\xa0"),
287 0x4000000 - 1 => (isASCII) ? "\xfb\xbf\xbf\xbf\xbf" : I8_to_native("\xfd\xbf\xbf\xbf\xbf\xbf"),
288 0x4000000 => (isASCII) ? "\xfc\x84\x80\x80\x80\x80" : I8_to_native("\xfe\xa2\xa0\xa0\xa0\xa0\xa0"),
289 0x40000000 - 1 => (isASCII) ? "\xfc\xbf\xbf\xbf\xbf\xbf" : I8_to_native("\xfe\xbf\xbf\xbf\xbf\xbf\xbf"),
290 0x40000000 => (isASCII) ? "\xfd\x80\x80\x80\x80\x80" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0"),
291 0x80000000 - 1 => (isASCII) ? "\xfd\xbf\xbf\xbf\xbf\xbf" : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf"),
c0236afe
KW		 292 0x80000000 => (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"),
293 0xFFFFFFFF => (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"),
7dfd8446 294);
4deba822 295
7dfd8446
KW		 296if ($is64bit) {
297 no warnings qw(overflow portable);
9d2d0ecd
KW		 298 $code_points{0x100000000} = (isASCII)
299 ? "\xfe\x84\x80\x80\x80\x80\x80"
300 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0");
301 $code_points{0x1000000000 - 1} = (isASCII)
302 ? "\xfe\xbf\xbf\xbf\xbf\xbf\xbf"
303 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf\xbf");
304 $code_points{0x1000000000} = (isASCII)
305 ? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
306 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0");
307 $code_points{0xFFFFFFFFFFFFFFFF} = (isASCII)
308 ? "\xff\x80\x8f\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
309 : I8_to_native("\xff\xaf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf");
d566bd20
KW		 310 if (isASCII) { # These could falsely show as overlongs in a naive implementation
311 $code_points{0x40000000000} = "\xff\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80";
312 $code_points{0x1000000000000} = "\xff\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80";
313 $code_points{0x40000000000000} = "\xff\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80";
314 $code_points{0x1000000000000000} = "\xff\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80";
315 # overflows
316 #$code_points{0xfoo} = "\xff\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80";
317 }
318}
319elsif (! isASCII) { # 32-bit EBCDIC. 64-bit is clearer to handle, so doesn't need this test case
320 no warnings qw(overflow portable);
321 $code_points{0x40000000} = I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0");
7dfd8446 322}
eb83ed87 323
7dfd8446
KW		 324# Now add in entries for each of code points 0-255, which require special
325# handling on EBCDIC. Remember the keys are Unicode values, and the values
326# are the native UTF-8. For invariants, the bytes are just the native chr.
327
328my $cp = 0;
329while ($cp < ((isASCII) ? 128 : 160)) { # This is from the definition of
330 # invariant
331 $code_points{$cp} = chr utf8::unicode_to_native($cp);
332 $cp++;
333}
334
335# Done with the invariants. Now do the variants. All in this range are 2
336# byte. Again, we can't use the internal functions to generate UTF-8, as
337# those are what we are trying to test. In the loop, we know what range the
338# continuation bytes can be in, and what the lowest start byte can be. So we
339# cycle through them.
340
341my $first_continuation = (isASCII) ? 0x80 : 0xA0;
342my $final_continuation = 0xBF;
343my $start = (isASCII) ? 0xC2 : 0xC5;
344
345my $continuation = $first_continuation - 1;
346
347while ($cp < 255) {
348 if (++$continuation > $final_continuation) {
349
350 # Wrap to the next start byte when we reach the final continuation
351 # byte possible
352 $continuation = $first_continuation;
353 $start++;
354 }
355 $code_points{$cp} = I8_to_native(chr($start) . chr($continuation));
356
357 $cp++;
358}
eb83ed87
KW		 359
360my @warnings;
361
362use warnings 'utf8';
363local $SIG{__WARN__} = sub { push @warnings, @_ };
364
9f2abfde
KW		 365my %restriction_types;
366
367$restriction_types{""}{'valid_strings'} = "";
368$restriction_types{"c9strict"}{'valid_strings'} = "";
369$restriction_types{"strict"}{'valid_strings'} = "";
370$restriction_types{"fits_in_31_bits"}{'valid_strings'} = "";
371
372# This set of tests looks for basic sanity, and lastly tests various routines
373# for the given code point. If the earlier tests for that code point fail,
374# the later ones probably will too. Malformations are tested in later
7dfd8446
KW		 375# segments of code.
376for my $u (sort { utf8::unicode_to_native($a) <=> utf8::unicode_to_native($b) }
377 keys %code_points)
378{
379 my $hex_u = sprintf("0x%02X", $u);
380 my $n = utf8::unicode_to_native($u);
381 my $hex_n = sprintf("0x%02X", $n);
382 my $bytes = $code_points{$u};
383
384 my $offskip_should_be;
385 {
386 no warnings qw(overflow portable);
387 $offskip_should_be = (isASCII)
388 ? ( $u < 0x80 ? 1 :
389 $u < 0x800 ? 2 :
390 $u < 0x10000 ? 3 :
391 $u < 0x200000 ? 4 :
392 $u < 0x4000000 ? 5 :
393 $u < 0x80000000 ? 6 : (($is64bit)
394 ? ($u < 0x1000000000 ? 7 : 13)
395 : 7)
396 )
397 : ($u < 0xA0 ? 1 :
398 $u < 0x400 ? 2 :
399 $u < 0x4000 ? 3 :
400 $u < 0x40000 ? 4 :
401 $u < 0x400000 ? 5 :
c0236afe
KW		 402 $u < 0x4000000 ? 6 :
403 $u < 0x40000000 ? 7 : 14 );
7dfd8446
KW		 404 }
405
406 # If this test fails, subsequent ones are meaningless.
407 next unless is(test_OFFUNISKIP($u), $offskip_should_be,
408 "Verify OFFUNISKIP($hex_u) is $offskip_should_be");
409 my $invariant = $offskip_should_be == 1;
410 my $display_invariant = $invariant || 0;
411 is(test_OFFUNI_IS_INVARIANT($u), $invariant,
412 "Verify OFFUNI_IS_INVARIANT($hex_u) is $display_invariant");
413
414 my $uvchr_skip_should_be = $offskip_should_be;
415 next unless is(test_UVCHR_SKIP($n), $uvchr_skip_should_be,
416 "Verify UVCHR_SKIP($hex_n) is $uvchr_skip_should_be");
417 is(test_UVCHR_IS_INVARIANT($n), $offskip_should_be == 1,
418 "Verify UVCHR_IS_INVARIANT($hex_n) is $display_invariant");
419
420 my $n_chr = chr $n;
421 utf8::upgrade $n_chr;
422
423 is(test_UTF8_SKIP($n_chr), $uvchr_skip_should_be,
424 "Verify UTF8_SKIP(chr $hex_n) is $uvchr_skip_should_be");
425
426 use bytes;
3d56ecbe
KW		 427 my $byte_length = length $n_chr;
428 for (my $j = 0; $j < $byte_length; $j++) {
429 undef @warnings;
430
431 if ($j == $byte_length - 1) {
432 my $ret = test_is_utf8_valid_partial_char_flags($n_chr, $byte_length, 0);
433 is($ret, 0, " Verify is_utf8_valid_partial_char_flags(" . display_bytes($n_chr) . ") returns 0 for full character");
434 }
435 else {
436 my $bytes_so_far = substr($n_chr, 0, $j + 1);
437 my $ret = test_is_utf8_valid_partial_char_flags($bytes_so_far, $j + 1, 0);
438 is($ret, 1, " Verify is_utf8_valid_partial_char_flags(" . display_bytes($bytes_so_far) . ") returns 1");
439 }
440
441 unless (is(scalar @warnings, 0,
442 " Verify is_utf8_valid_partial_char_flags generated no warnings"))
443 {
444 diag "The warnings were: " . join(", ", @warnings);
445 }
446
7dfd8446
KW		 447 my $b = substr($n_chr, $j, 1);
448 my $hex_b = sprintf("\"\\x%02x\"", ord $b);
449
450 my $byte_invariant = $j == 0 && $uvchr_skip_should_be == 1;
451 my $display_byte_invariant = $byte_invariant || 0;
452 next unless is(test_UTF8_IS_INVARIANT($b), $byte_invariant,
453 " Verify UTF8_IS_INVARIANT($hex_b) for byte $j "
454 . "is $display_byte_invariant");
455
456 my $is_start = $j == 0 && $uvchr_skip_should_be > 1;
457 my $display_is_start = $is_start || 0;
458 next unless is(test_UTF8_IS_START($b), $is_start,
459 " Verify UTF8_IS_START($hex_b) is $display_is_start");
460
461 my $is_continuation = $j != 0 && $uvchr_skip_should_be > 1;
462 my $display_is_continuation = $is_continuation || 0;
463 next unless is(test_UTF8_IS_CONTINUATION($b), $is_continuation,
464 " Verify UTF8_IS_CONTINUATION($hex_b) is "
465 . "$display_is_continuation");
466
467 my $is_continued = $uvchr_skip_should_be > 1;
468 my $display_is_continued = $is_continued || 0;
469 next unless is(test_UTF8_IS_CONTINUED($b), $is_continued,
470 " Verify UTF8_IS_CONTINUED($hex_b) is "
471 . "$display_is_continued");
472
473 my $is_downgradeable_start = $n < 256
474 && $uvchr_skip_should_be > 1
475 && $j == 0;
476 my $display_is_downgradeable_start = $is_downgradeable_start || 0;
477 next unless is(test_UTF8_IS_DOWNGRADEABLE_START($b),
478 $is_downgradeable_start,
479 " Verify UTF8_IS_DOWNGRADEABLE_START($hex_b) is "
480 . "$display_is_downgradeable_start");
481
482 my $is_above_latin1 = $n > 255 && $j == 0;
483 my $display_is_above_latin1 = $is_above_latin1 || 0;
484 next unless is(test_UTF8_IS_ABOVE_LATIN1($b),
485 $is_above_latin1,
486 " Verify UTF8_IS_ABOVE_LATIN1($hex_b) is "
487 . "$display_is_above_latin1");
488
489 my $is_possibly_problematic = $j == 0
490 && $n >= ((isASCII)
491 ? 0xD000
492 : 0x8000);
493 my $display_is_possibly_problematic = $is_possibly_problematic || 0;
494 next unless is(test_isUTF8_POSSIBLY_PROBLEMATIC($b),
495 $is_possibly_problematic,
496 " Verify isUTF8_POSSIBLY_PROBLEMATIC($hex_b) is "
497 . "$display_is_above_latin1");
498 }
499
500 # We are not trying to look for warnings, etc, so if they should occur, it
501 # is an error. But some of the code points here do cause warnings, so we
502 # check here and turn off the ones that apply to such code points. A
503 # later section of the code tests for these kinds of things.
046d01eb 504 my $this_utf8_flags = $look_for_everything_utf8n_to;
7dfd8446 505 my $len = length $bytes;
e23e8bc1
KW		 506
507 my $valid_under_strict = 1;
a82be82b 508 my $valid_under_c9strict = 1;
9f2abfde 509 my $valid_for_fits_in_31_bits = 1;
7dfd8446
KW		 510 if ($n > 0x10FFFF) {
511 $this_utf8_flags &= ~($UTF8_DISALLOW_SUPER|$UTF8_WARN_SUPER);
e23e8bc1 512 $valid_under_strict = 0;
a82be82b 513 $valid_under_c9strict = 0;
5f8a3d1d
KW		 514 if ($n > 2 ** 31 - 1) {
515 $this_utf8_flags &=
516 ~($UTF8_DISALLOW_ABOVE_31_BIT|$UTF8_WARN_ABOVE_31_BIT);
9f2abfde 517 $valid_for_fits_in_31_bits = 0;
5f8a3d1d 518 }
7dfd8446 519 }
5f8a3d1d 520 elsif (($n >= 0xFDD0 && $n <= 0xFDEF) || ($n & 0xFFFE) == 0xFFFE) {
7dfd8446 521 $this_utf8_flags &= ~($UTF8_DISALLOW_NONCHAR|$UTF8_WARN_NONCHAR);
e23e8bc1 522 $valid_under_strict = 0;
7dfd8446 523 }
5f8a3d1d
KW		 524 elsif ($n >= 0xD800 && $n <= 0xDFFF) {
525 $this_utf8_flags &= ~($UTF8_DISALLOW_SURROGATE|$UTF8_WARN_SURROGATE);
526 $valid_under_c9strict = 0;
527 $valid_under_strict = 0;
528 }
7dfd8446
KW		 529
530 undef @warnings;
531
532 my $display_flags = sprintf "0x%x", $this_utf8_flags;
7dfd8446 533 my $display_bytes = display_bytes($bytes);
d7874298 534 my $ret_ref = test_utf8n_to_uvchr($bytes, $len, $this_utf8_flags);
c0d8738e
KW		 535
536 # Rest of tests likely meaningless if it gets the wrong code point.
537 next unless is($ret_ref->[0], $n,
538 "Verify utf8n_to_uvchr($display_bytes, $display_flags) returns $hex_n");
539 is($ret_ref->[1], $len,
540 "Verify utf8n_to_uvchr() for $hex_n returns expected length: $len");
7dfd8446
KW		 541
542 unless (is(scalar @warnings, 0,
543 "Verify utf8n_to_uvchr() for $hex_n generated no warnings"))
544 {
545 diag "The warnings were: " . join(", ", @warnings);
546 }
046d01eb 547
75ffa578
KW		 548 undef @warnings;
549
d7874298 550 my $ret = test_isUTF8_CHAR($bytes, $len);
9d2d0ecd 551 is($ret, $len, "Verify isUTF8_CHAR($display_bytes) returns expected length: $len");
d7874298
KW		 552
553 unless (is(scalar @warnings, 0,
554 "Verify isUTF8_CHAR() for $hex_n generated no warnings"))
555 {
556 diag "The warnings were: " . join(", ", @warnings);
557 }
558
559 undef @warnings;
560
561 $ret = test_isUTF8_CHAR($bytes, $len - 1);
562 is($ret, 0, "Verify isUTF8_CHAR() with too short length parameter returns 0");
563
564 unless (is(scalar @warnings, 0,
565 "Verify isUTF8_CHAR() generated no warnings"))
566 {
567 diag "The warnings were: " . join(", ", @warnings);
568 }
569
570 undef @warnings;
571
25e3a4e0
KW		 572 $ret = test_isUTF8_CHAR_flags($bytes, $len, 0);
573 is($ret, $len, "Verify isUTF8_CHAR_flags($display_bytes, 0) returns expected length: $len");
574
575 unless (is(scalar @warnings, 0,
576 "Verify isUTF8_CHAR_flags() for $hex_n generated no warnings"))
577 {
578 diag "The warnings were: " . join(", ", @warnings);
579 }
580
581 undef @warnings;
582
583 $ret = test_isUTF8_CHAR_flags($bytes, $len - 1, 0);
584 is($ret, 0, "Verify isUTF8_CHAR_flags() with too short length parameter returns 0");
585
586 unless (is(scalar @warnings, 0,
587 "Verify isUTF8_CHAR_flags() generated no warnings"))
588 {
589 diag "The warnings were: " . join(", ", @warnings);
590 }
591
592 undef @warnings;
593
e23e8bc1
KW		 594 $ret = test_isSTRICT_UTF8_CHAR($bytes, $len);
595 my $expected_len = ($valid_under_strict) ? $len : 0;
596 is($ret, $expected_len, "Verify isSTRICT_UTF8_CHAR($display_bytes) returns expected length: $expected_len");
597
598 unless (is(scalar @warnings, 0,
599 "Verify isSTRICT_UTF8_CHAR() for $hex_n generated no warnings"))
600 {
601 diag "The warnings were: " . join(", ", @warnings);
602 }
603
604 undef @warnings;
605
606 $ret = test_isSTRICT_UTF8_CHAR($bytes, $len - 1);
607 is($ret, 0, "Verify isSTRICT_UTF8_CHAR() with too short length parameter returns 0");
608
609 unless (is(scalar @warnings, 0,
610 "Verify isSTRICT_UTF8_CHAR() generated no warnings"))
611 {
612 diag "The warnings were: " . join(", ", @warnings);
613 }
614
25e3a4e0
KW		 615 undef @warnings;
616
617 $ret = test_isUTF8_CHAR_flags($bytes, $len, $UTF8_DISALLOW_ILLEGAL_INTERCHANGE);
618 is($ret, $expected_len, "Verify isUTF8_CHAR_flags('DISALLOW_ILLEGAL_INTERCHANGE') acts like isSTRICT_UTF8_CHAR");
619
620 unless (is(scalar @warnings, 0,
621 "Verify isUTF8_CHAR() for $hex_n generated no warnings"))
622 {
623 diag "The warnings were: " . join(", ", @warnings);
624 }
625
626 undef @warnings;
627
a82be82b
KW		 628 $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $len);
629 $expected_len = ($valid_under_c9strict) ? $len : 0;
630 is($ret, $expected_len, "Verify isC9_STRICT_UTF8_CHAR($display_bytes) returns expected length: $len");
631
632 unless (is(scalar @warnings, 0,
633 "Verify isC9_STRICT_UTF8_CHAR() for $hex_n generated no warnings"))
634 {
635 diag "The warnings were: " . join(", ", @warnings);
636 }
637
638 undef @warnings;
639
640 $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $len - 1);
641 is($ret, 0, "Verify isC9_STRICT_UTF8_CHAR() with too short length parameter returns 0");
642
643 unless (is(scalar @warnings, 0,
644 "Verify isC9_STRICT_UTF8_CHAR() generated no warnings"))
645 {
646 diag "The warnings were: " . join(", ", @warnings);
647 }
648
e23e8bc1
KW		 649 undef @warnings;
650
25e3a4e0
KW		 651 $ret = test_isUTF8_CHAR_flags($bytes, $len, $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE);
652 is($ret, $expected_len, "Verify isUTF8_CHAR_flags('DISALLOW_ILLEGAL_C9_INTERCHANGE') acts like isC9_STRICT_UTF8_CHAR");
653
654 unless (is(scalar @warnings, 0,
655 "Verify isUTF8_CHAR() for $hex_n generated no warnings"))
656 {
657 diag "The warnings were: " . join(", ", @warnings);
658 }
659
660 undef @warnings;
661
75ffa578
KW		 662 $ret_ref = test_valid_utf8_to_uvchr($bytes);
663 is($ret_ref->[0], $n, "Verify valid_utf8_to_uvchr($display_bytes) returns $hex_n");
9d2d0ecd 664 is($ret_ref->[1], $len, "Verify valid_utf8_to_uvchr() for $hex_n returns expected length: $len");
75ffa578
KW		 665
666 unless (is(scalar @warnings, 0,
667 "Verify valid_utf8_to_uvchr() for $hex_n generated no warnings"))
668 {
669 diag "The warnings were: " . join(", ", @warnings);
670 }
671
046d01eb
KW		 672 # Similarly for uvchr_to_utf8
673 my $this_uvchr_flags = $look_for_everything_uvchr_to;
674 if ($n > 2 ** 31 - 1) {
675 $this_uvchr_flags &=
676 ~($UNICODE_DISALLOW_ABOVE_31_BIT|$UNICODE_WARN_ABOVE_31_BIT);
677 }
678 if ($n > 0x10FFFF) {
679 $this_uvchr_flags &= ~($UNICODE_DISALLOW_SUPER|$UNICODE_WARN_SUPER);
680 }
5f8a3d1d 681 elsif (($n >= 0xFDD0 && $n <= 0xFDEF) || ($n & 0xFFFE) == 0xFFFE) {
046d01eb
KW		 682 $this_uvchr_flags &= ~($UNICODE_DISALLOW_NONCHAR|$UNICODE_WARN_NONCHAR);
683 }
5f8a3d1d
KW		 684 elsif ($n >= 0xD800 && $n <= 0xDFFF) {
685 $this_uvchr_flags &= ~($UNICODE_DISALLOW_SURROGATE|$UNICODE_WARN_SURROGATE);
686 }
046d01eb
KW		 687 $display_flags = sprintf "0x%x", $this_uvchr_flags;
688
689 undef @warnings;
690
d7874298 691 $ret = test_uvchr_to_utf8_flags($n, $this_uvchr_flags);
046d01eb
KW		 692 ok(defined $ret, "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returned success");
693 is($ret, $bytes, "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returns correct bytes");
694
695 unless (is(scalar @warnings, 0,
696 "Verify uvchr_to_utf8_flags($hex_n, $display_flags) for $hex_n generated no warnings"))
697 {
698 diag "The warnings were: " . join(", ", @warnings);
699 }
9f2abfde
KW		 700
701 # Now append this code point to a string that we will test various
702 # versions of is_foo_utf8_string_bar on, and keep a count of how many code
703 # points are in it. All the code points in this loop are valid in Perl's
704 # extended UTF-8, but some are not valid under various restrictions. A
705 # string and count is kept separately that is entirely valid for each
706 # restriction. And, for each restriction, we note the first occurrence in
707 # the unrestricted string where we find something not in the restricted
708 # string.
709 $restriction_types{""}{'valid_strings'} .= $bytes;
710 $restriction_types{""}{'valid_counts'}++;
711
712 if ($valid_under_c9strict) {
713 $restriction_types{"c9strict"}{'valid_strings'} .= $bytes;
714 $restriction_types{"c9strict"}{'valid_counts'}++;
715 }
716 elsif (! exists $restriction_types{"c9strict"}{'first_invalid_offset'}) {
717 $restriction_types{"c9strict"}{'first_invalid_offset'}
718 = length $restriction_types{"c9strict"}{'valid_strings'};
719 $restriction_types{"c9strict"}{'first_invalid_count'}
720 = $restriction_types{"c9strict"}{'valid_counts'};
721 }
722
723 if ($valid_under_strict) {
724 $restriction_types{"strict"}{'valid_strings'} .= $bytes;
725 $restriction_types{"strict"}{'valid_counts'}++;
726 }
727 elsif (! exists $restriction_types{"strict"}{'first_invalid_offset'}) {
728 $restriction_types{"strict"}{'first_invalid_offset'}
729 = length $restriction_types{"strict"}{'valid_strings'};
730 $restriction_types{"strict"}{'first_invalid_count'}
731 = $restriction_types{"strict"}{'valid_counts'};
732 }
733
734 if ($valid_for_fits_in_31_bits) {
735 $restriction_types{"fits_in_31_bits"}{'valid_strings'} .= $bytes;
736 $restriction_types{"fits_in_31_bits"}{'valid_counts'}++;
737 }
738 elsif (! exists
739 $restriction_types{"fits_in_31_bits"}{'first_invalid_offset'})
740 {
741 $restriction_types{"fits_in_31_bits"}{'first_invalid_offset'}
742 = length $restriction_types{"fits_in_31_bits"}{'valid_strings'};
743 $restriction_types{"fits_in_31_bits"}{'first_invalid_count'}
744 = $restriction_types{"fits_in_31_bits"}{'valid_counts'};
745 }
746}
747
748my $I8c = (isASCII) ? "\x80" : "\xa0"; # A continuation byte
749my $cont_byte = I8_to_native($I8c);
750my $p = (isASCII) ? "\xe1\x80" : I8_to_native("\xE4\xA0"); # partial
751
752# The loop above tested the single or partial character functions/macros,
753# while building up strings to test the string functions, which we do now.
754
755for my $restriction (sort keys %restriction_types) {
756 use bytes;
757
758 for my $use_flags ("", "_flags") {
759
760 # For each restriction, we test it in both the is_foo_flags functions
761 # and the specially named foo function. But not if there isn't such a
762 # specially named function. Currently, this is the only tested
763 # restriction that doesn't have a specially named function
764 next if $use_flags eq "" && $restriction eq "fits_in_31_bits";
765
766 # Start building up the name of the function we will test.
8bc127bf 767 my $base_name = "is_";
9f2abfde
KW		 768
769 if (! $use_flags && $restriction ne "") {
8bc127bf 770 $base_name .= $restriction . "_";
9f2abfde 771 }
8bc127bf
KW		 772
773 # We test both "is_utf8_string_foo" and "is_fixed_width_buf" functions
774 foreach my $operand ('string', 'fixed_width_buf') {
775
776 # Currently, the only fixed_width_buf functions have the '_flags'
777 # suffix.
778 next if $operand eq 'fixed_width_buf' && $use_flags eq "";
779
780 my $name = "${base_name}utf8_$operand";
9f2abfde
KW		 781
782 # We test each version of the function
783 for my $function ("_loclen", "_loc", "") {
784
785 # We test each function against
786 # a) valid input
787 # b) invalid input created by appending an out-of-place
788 # continuation character to the valid string
8bc127bf
KW		 789 # c) input created by appending a partial character. This
790 # is valid in the 'fixed_width' functions, but invalid in
791 # the 'string' ones
9f2abfde
KW		 792 # d) invalid input created by calling a function that is
793 # expecting a restricted form of the input using the string
794 # that's valid when unrestricted
795 for my $error_type (0, $cont_byte, $p, $restriction) {
796 #diag "restriction=$restriction, use_flags=$use_flags, function=$function, error_type=" . display_bytes($error_type);
797
798 # If there is no restriction, the error type will be "",
799 # which is redundant with 0.
800 next if $error_type eq "";
801
802 my $this_name = "$name$function$use_flags";
803 my $bytes
804 = $restriction_types{$restriction}{'valid_strings'};
805 my $expected_offset = length $bytes;
806 my $expected_count
807 = $restriction_types{$restriction}{'valid_counts'};
808 my $test_name_suffix = "";
809
810 my $this_error_type = $error_type;
811 if ($this_error_type) {
812
813 # Appending a bare continuation byte or a partial
8bc127bf
KW		 814 # character doesn't change the character count or
815 # offset. But in the other cases, we have saved where
816 # the failures should occur, so use those. Appending
817 # a continuation byte makes it invalid; appending a
818 # partial character makes the 'string' form invalid,
819 # but not the 'fixed_width_buf' form.
9f2abfde
KW		 820 if ($this_error_type eq $cont_byte || $this_error_type eq $p) {
821 $bytes .= $this_error_type;
822 if ($this_error_type eq $cont_byte) {
823 $test_name_suffix
824 = " for an unexpected continuation";
825 }
826 else {
827 $test_name_suffix
828 = " if ends with a partial character";
8bc127bf
KW		 829 $this_error_type
830 = 0 if $operand eq "fixed_width_buf";
9f2abfde
KW		 831 }
832 }
833 else {
834 $test_name_suffix
835 = " if contains forbidden code points";
836 if ($this_error_type eq "c9strict") {
837 $bytes = $restriction_types{""}{'valid_strings'};
838 $expected_offset
839 = $restriction_types{"c9strict"}
840 {'first_invalid_offset'};
841 $expected_count
842 = $restriction_types{"c9strict"}
843 {'first_invalid_count'};
844 }
845 elsif ($this_error_type eq "strict") {
846 $bytes = $restriction_types{""}{'valid_strings'};
847 $expected_offset
848 = $restriction_types{"strict"}
849 {'first_invalid_offset'};
850 $expected_count
851 = $restriction_types{"strict"}
852 {'first_invalid_count'};
853
854 }
855 elsif ($this_error_type eq "fits_in_31_bits") {
856 $bytes = $restriction_types{""}{'valid_strings'};
857 $expected_offset
858 = $restriction_types{"fits_in_31_bits"}
859 {'first_invalid_offset'};
860 $expected_count
861 = $restriction_types{"fits_in_31_bits"}
862 {'first_invalid_count'};
863 }
864 else {
865 fail("Internal test error: Unknown error type "
866 . "'$this_error_type'");
867 next;
868 }
869 }
870 }
871
872 my $length = length $bytes;
873 my $ret_ref;
874
875 my $test = "\$ret_ref = test_$this_name(\$bytes, $length";
876
877 # If using the _flags functions, we have to figure out what
878 # flags to pass. This is done to match the restriction.
879 if ($use_flags eq "_flags") {
880 if (! $restriction) {
881 $test .= ", 0"; # The flag
882
883 # Indicate the kind of flag in the test name.
884 $this_name .= "(0)";
885 }
886 else {
887 $this_name .= "($restriction)";
888 if ($restriction eq "c9strict") {
889 $test
890 .= ", $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE";
891 }
892 elsif ($restriction eq "strict") {
893 $test .= ", $UTF8_DISALLOW_ILLEGAL_INTERCHANGE";
894 }
895 elsif ($restriction eq "fits_in_31_bits") {
896 $test .= ", $UTF8_DISALLOW_ABOVE_31_BIT";
897 }
898 else {
899 fail("Internal test error: Unknown restriction "
900 . "'$restriction'");
901 next;
902 }
903 }
904 }
905 $test .= ")";
906
907 # Actually run the test
908 eval $test;
909 if ($@) {
910 fail($test);
911 diag $@;
912 next;
913 }
914
915 my $ret;
916 my $error_offset;
917 my $cp_count;
918
919 if ($function eq "") {
920 $ret = $ret_ref; # For plain function, there's only a
921 # single return value
922 }
923 else { # Otherwise, the multiple values come in an array.
924 $ret = shift @$ret_ref ;
925 $error_offset = shift @$ret_ref;
926 $cp_count = shift@$ret_ref if $function eq "_loclen";
927 }
928
929 if ($this_error_type) {
930 is($ret, 0,
931 "Verify $this_name is FALSE$test_name_suffix");
932 }
933 else {
934 unless(is($ret, 1,
935 "Verify $this_name is TRUE for valid input"
936 . "$test_name_suffix"))
937 {
938 diag("The bytes starting at offset"
939 . " $error_offset are"
940 . display_bytes(substr(
941 $restriction_types{$restriction}
942 {'valid_strings'},
943 $error_offset)));
944 next;
945 }
946 }
947
948 if ($function ne "") {
949 unless (is($error_offset, $expected_offset,
950 "\tAnd returns the correct offset"))
951 {
952 my $min = ($error_offset < $expected_offset)
953 ? $error_offset
954 : $expected_offset;
955 diag display_bytes(substr($bytes, $min));
956 }
957
958 if ($function eq '_loclen') {
959 is($cp_count, $expected_count,
960 "\tAnd returns the correct character count");
961 }
962 }
963 }
964 }
8bc127bf 965 }
9f2abfde 966 }
7dfd8446
KW		 967}
968
969my $REPLACEMENT = 0xFFFD;
970
971# Now test the malformations. All these raise category utf8 warnings.
7dfd8446 972my @malformations = (
eb83ed87
KW		 973 [ "zero length string malformation", "", 0,
974 $UTF8_ALLOW_EMPTY, 0, 0,
975 qr/empty string/
976 ],
152c1f4b 977 [ "orphan continuation byte malformation", I8_to_native("${I8c}a"),
7dfd8446 978 2,
eb83ed87
KW		 979 $UTF8_ALLOW_CONTINUATION, $REPLACEMENT, 1,
980 qr/unexpected continuation byte/
981 ],
7dfd8446 982 [ "premature next character malformation (immediate)",
9d2d0ecd
KW		 983 (isASCII) ? "\xc2\xc2\x80" : I8_to_native("\xc5\xc5\xa0"),
984 3,
eb83ed87
KW		 985 $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 1,
986 qr/unexpected non-continuation byte.*immediately after start byte/
987 ],
7dfd8446 988 [ "premature next character malformation (non-immediate)",
152c1f4b 989 I8_to_native("\xf0${I8c}a"),
7dfd8446 990 3,
eb83ed87
KW		 991 $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 2,
992 qr/unexpected non-continuation byte .* 2 bytes after start byte/
993 ],
152c1f4b 994 [ "too short malformation", I8_to_native("\xf0${I8c}a"), 2,
eb83ed87
KW		 995 # Having the 'a' after this, but saying there are only 2 bytes also
996 # tests that we pay attention to the passed in length
997 $UTF8_ALLOW_SHORT, $REPLACEMENT, 2,
998 qr/2 bytes, need 4/
999 ],
d566bd20
KW		 1000 [ "overlong malformation, lowest 2-byte",
1001 (isASCII) ? "\xc0\x80" : I8_to_native("\xc0\xa0"),
1002 2,
7dfd8446
KW		 1003 $UTF8_ALLOW_LONG,
1004 0, # NUL
1005 2,
eb83ed87 1006 qr/2 bytes, need 1/
c0236afe 1007 ],
d566bd20
KW		 1008 [ "overlong malformation, highest 2-byte",
1009 (isASCII) ? "\xc1\xbf" : I8_to_native("\xc4\xbf"),
1010 2,
1011 $UTF8_ALLOW_LONG,
1012 (isASCII) ? 0x7F : utf8::unicode_to_native(0xBF),
1013 2,
1014 qr/2 bytes, need 1/
1015 ],
1016 [ "overlong malformation, lowest 3-byte",
1017 (isASCII) ? "\xe0\x80\x80" : I8_to_native("\xe0\xa0\xa0"),
1018 3,
1019 $UTF8_ALLOW_LONG,
1020 0, # NUL
1021 3,
1022 qr/3 bytes, need 1/
1023 ],
1024 [ "overlong malformation, highest 3-byte",
1025 (isASCII) ? "\xe0\x9f\xbf" : I8_to_native("\xe0\xbf\xbf"),
1026 3,
1027 $UTF8_ALLOW_LONG,
1028 (isASCII) ? 0x7FF : 0x3FF,
1029 3,
1030 qr/3 bytes, need 2/
1031 ],
1032 [ "overlong malformation, lowest 4-byte",
1033 (isASCII) ? "\xf0\x80\x80\x80" : I8_to_native("\xf0\xa0\xa0\xa0"),
1034 4,
1035 $UTF8_ALLOW_LONG,
1036 0, # NUL
1037 4,
1038 qr/4 bytes, need 1/
1039 ],
1040 [ "overlong malformation, highest 4-byte",
1041 (isASCII) ? "\xf0\x8F\xbf\xbf" : I8_to_native("\xf0\xaf\xbf\xbf"),
1042 4,
1043 $UTF8_ALLOW_LONG,
1044 (isASCII) ? 0xFFFF : 0x3FFF,
1045 4,
1046 qr/4 bytes, need 3/
1047 ],
1048 [ "overlong malformation, lowest 5-byte",
1049 (isASCII)
1050 ? "\xf8\x80\x80\x80\x80"
1051 : I8_to_native("\xf8\xa0\xa0\xa0\xa0"),
1052 5,
1053 $UTF8_ALLOW_LONG,
1054 0, # NUL
1055 5,
1056 qr/5 bytes, need 1/
1057 ],
1058 [ "overlong malformation, highest 5-byte",
1059 (isASCII)
1060 ? "\xf8\x87\xbf\xbf\xbf"
1061 : I8_to_native("\xf8\xa7\xbf\xbf\xbf"),
1062 5,
1063 $UTF8_ALLOW_LONG,
1064 (isASCII) ? 0x1FFFFF : 0x3FFFF,
1065 5,
1066 qr/5 bytes, need 4/
1067 ],
1068 [ "overlong malformation, lowest 6-byte",
1069 (isASCII)
1070 ? "\xfc\x80\x80\x80\x80\x80"
1071 : I8_to_native("\xfc\xa0\xa0\xa0\xa0\xa0"),
1072 6,
1073 $UTF8_ALLOW_LONG,
1074 0, # NUL
1075 6,
1076 qr/6 bytes, need 1/
1077 ],
1078 [ "overlong malformation, highest 6-byte",
1079 (isASCII)
1080 ? "\xfc\x83\xbf\xbf\xbf\xbf"
1081 : I8_to_native("\xfc\xa3\xbf\xbf\xbf\xbf"),
1082 6,
1083 $UTF8_ALLOW_LONG,
1084 (isASCII) ? 0x3FFFFFF : 0x3FFFFF,
1085 6,
1086 qr/6 bytes, need 5/
1087 ],
1088 [ "overlong malformation, lowest 7-byte",
1089 (isASCII)
1090 ? "\xfe\x80\x80\x80\x80\x80\x80"
1091 : I8_to_native("\xfe\xa0\xa0\xa0\xa0\xa0\xa0"),
1092 7,
1093 $UTF8_ALLOW_LONG,
1094 0, # NUL
1095 7,
1096 qr/7 bytes, need 1/
1097 ],
1098 [ "overlong malformation, highest 7-byte",
1099 (isASCII)
1100 ? "\xfe\x81\xbf\xbf\xbf\xbf\xbf"
1101 : I8_to_native("\xfe\xa1\xbf\xbf\xbf\xbf\xbf"),
1102 7,
1103 $UTF8_ALLOW_LONG,
1104 (isASCII) ? 0x7FFFFFFF : 0x3FFFFFF,
1105 7,
1106 qr/7 bytes, need 6/
c0236afe
KW		 1107 ],
1108);
7dfd8446 1109
d566bd20
KW		 1110if (isASCII && ! $is64bit) { # 32-bit ASCII platform
1111 no warnings 'portable';
1112 push @malformations,
1113 [ "overflow malformation",
1114 "\xfe\x84\x80\x80\x80\x80\x80", # Represents 2**32
1115 7,
1116 0, # There is no way to allow this malformation
1117 $REPLACEMENT,
1118 7,
1119 qr/overflow/
1120 ],
1121 [ "overflow malformation, can tell on first byte",
1122 "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
1123 13,
1124 0, # There is no way to allow this malformation
1125 $REPLACEMENT,
1126 13,
1127 qr/overflow/
1128 ];
1129}
1130else {
1131 # On EBCDIC platforms, another overlong test is needed even on 32-bit
1132 # systems, whereas it doesn't happen on ASCII except on 64-bit ones.
1133
1134 no warnings 'portable';
1135 no warnings 'overflow'; # Doesn't run on 32-bit systems, but compiles
1136 push @malformations,
1137 [ "overlong malformation, lowest max-byte",
1138 (isASCII)
1139 ? "\xff\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80"
1140 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1141 (isASCII) ? 13 : 14,
1142 $UTF8_ALLOW_LONG,
1143 0, # NUL
1144 (isASCII) ? 13 : 14,
1145 qr/1[34] bytes, need 1/, # 1[34] to work on either ASCII or EBCDIC
1146 ],
1147 [ "overlong malformation, highest max-byte",
1148 (isASCII) # 2**36-1 on ASCII; 2**30-1 on EBCDIC
1149 ? "\xff\x80\x80\x80\x80\x80\x80\xbf\xbf\xbf\xbf\xbf\xbf"
1150 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xbf\xbf\xbf\xbf\xbf\xbf"),
1151 (isASCII) ? 13 : 14,
1152 $UTF8_ALLOW_LONG,
1153 (isASCII) ? 0xFFFFFFFFF : 0x3FFFFFFF,
1154 (isASCII) ? 13 : 14,
1155 qr/1[34] bytes, need 7/,
1156 ];
1157
1158 if (! $is64bit) { # 32-bit EBCDIC
1159 push @malformations,
1160 [ "overflow malformation",
1161 I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"),
1162 14,
1163 0, # There is no way to allow this malformation
1164 $REPLACEMENT,
1165 14,
1166 qr/overflow/
1167 ];
1168 }
1169 else { # 64-bit
1170 push @malformations,
1171 [ "overflow malformation",
1172 (isASCII)
1173 ? "\xff\x80\x90\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"
1174 : I8_to_native("\xff\xb0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1175 (isASCII) ? 13 : 14,
1176 0, # There is no way to allow this malformation
1177 $REPLACEMENT,
1178 (isASCII) ? 13 : 14,
1179 qr/overflow/
1180 ];
1181 }
1182}
1183
7dfd8446 1184foreach my $test (@malformations) {
eb83ed87
KW		 1185 my ($testname, $bytes, $length, $allow_flags, $allowed_uv, $expected_len, $message ) = @$test;
1186
1187 next if ! ok(length($bytes) >= $length, "$testname: Make sure won't read beyond buffer: " . length($bytes) . " >= $length");
1188
d7874298
KW		 1189 undef @warnings;
1190
1191 my $ret = test_isUTF8_CHAR($bytes, $length);
1192 is($ret, 0, "$testname: isUTF8_CHAR returns 0");
1193 unless (is(scalar @warnings, 0,
1194 "$testname: isUTF8_CHAR() generated no warnings"))
1195 {
1196 diag "The warnings were: " . join(", ", @warnings);
1197 }
1198
25e3a4e0
KW		 1199 undef @warnings;
1200
1201 $ret = test_isUTF8_CHAR_flags($bytes, $length, 0);
1202 is($ret, 0, "$testname: isUTF8_CHAR_flags returns 0");
1203 unless (is(scalar @warnings, 0,
1204 "$testname: isUTF8_CHAR() generated no warnings"))
1205 {
1206 diag "The warnings were: " . join(", ", @warnings);
1207 }
1208
e23e8bc1
KW		 1209 $ret = test_isSTRICT_UTF8_CHAR($bytes, $length);
1210 is($ret, 0, "$testname: isSTRICT_UTF8_CHAR returns 0");
1211 unless (is(scalar @warnings, 0,
1212 "$testname: isSTRICT_UTF8_CHAR() generated no warnings"))
1213 {
1214 diag "The warnings were: " . join(", ", @warnings);
1215 }
1216
a82be82b
KW		 1217 $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $length);
1218 is($ret, 0, "$testname: isC9_STRICT_UTF8_CHAR returns 0");
1219 unless (is(scalar @warnings, 0,
1220 "$testname: isC9_STRICT_UTF8_CHAR() generated no warnings"))
1221 {
1222 diag "The warnings were: " . join(", ", @warnings);
1223 }
1224
3d56ecbe
KW		 1225 for my $j (1 .. $length - 1) {
1226 my $partial = substr($bytes, 0, $j);
1227
1228 undef @warnings;
1229
1230 $ret = test_is_utf8_valid_partial_char_flags($bytes, $j, 0);
1231 my $ret_should_be = 0;
1232 my $comment = "";
1233 if ($testname =~ /premature|short/ && $j < 2) {
1234 $ret_should_be = 1;
1235 $comment = ", but need 2 bytes to discern:";
1236 }
1237 elsif ($testname =~ /overlong/ && $length > 2) {
1238 if ($length <= 7 && $j < 2) {
1239 $ret_should_be = 1;
1240 $comment = ", but need 2 bytes to discern:";
1241 }
1242 elsif ($length > 7 && $j < 7) {
1243 $ret_should_be = 1;
1244 $comment = ", but need 7 bytes to discern:";
1245 }
1246 }
1247 elsif ($testname =~ /overflow/ && $testname !~ /first byte/) {
1248 if (isASCII) {
1249 if ($j < (($is64bit) ? 3 : 2)) {
1250 $comment = ", but need $j bytes to discern:";
1251 $ret_should_be = 1;
1252 }
1253 }
1254 else {
1255 if ($j < (($is64bit) ? 2 : 8)) {
1256 $comment = ", but need $j bytes to discern:";
1257 $ret_should_be = 1;
1258 }
1259 }
1260 }
1261 is($ret, $ret_should_be, "$testname: is_utf8_valid_partial_char_flags("
1262 . display_bytes($partial)
1263 . ")$comment returns $ret_should_be");
1264 unless (is(scalar @warnings, 0,
1265 "$testname: is_utf8_valid_partial_char_flags() generated no warnings"))
1266 {
1267 diag "The warnings were: " . join(", ", @warnings);
1268 }
1269 }
1270
d7874298 1271
eb83ed87
KW		 1272 # Test what happens when this malformation is not allowed
1273 undef @warnings;
bd70aaaf 1274 my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
eb83ed87 1275 is($ret_ref->[0], 0, "$testname: disallowed: Returns 0");
9d2d0ecd 1276 is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), disallowed: Returns expected length: $expected_len");
eb83ed87
KW		 1277 if (is(scalar @warnings, 1, "$testname: disallowed: Got a single warning ")) {
1278 like($warnings[0], $message, "$testname: disallowed: Got expected warning");
1279 }
1280 else {
1281 if (scalar @warnings) {
7dfd8446 1282 diag "The warnings were: " . join(", ", @warnings);
eb83ed87
KW		 1283 }
1284 }
1285
1286 { # Next test when disallowed, and warnings are off.
1287 undef @warnings;
1288 no warnings 'utf8';
bd70aaaf 1289 my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
9d2d0ecd
KW		 1290 is($ret_ref->[0], 0, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': Returns 0");
1291 is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': Returns expected length: $expected_len");
1292 if (!is(scalar @warnings, 0, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': no warnings generated")) {
7dfd8446 1293 diag "The warnings were: " . join(", ", @warnings);
eb83ed87
KW		 1294 }
1295 }
1296
1297 # Test with CHECK_ONLY
1298 undef @warnings;
bd70aaaf 1299 $ret_ref = test_utf8n_to_uvchr($bytes, $length, $UTF8_CHECK_ONLY);
eb83ed87 1300 is($ret_ref->[0], 0, "$testname: CHECK_ONLY: Returns 0");
9d2d0ecd 1301 is($ret_ref->[1], -1, "$testname: CHECK_ONLY: returns -1 for length");
eb83ed87 1302 if (! is(scalar @warnings, 0, "$testname: CHECK_ONLY: no warnings generated")) {
7dfd8446 1303 diag "The warnings were: " . join(", ", @warnings);
eb83ed87
KW		 1304 }
1305
1306 next if $allow_flags == 0; # Skip if can't allow this malformation
1307
1308 # Test when the malformation is allowed
1309 undef @warnings;
bd70aaaf 1310 $ret_ref = test_utf8n_to_uvchr($bytes, $length, $allow_flags);
9d2d0ecd
KW		 1311 is($ret_ref->[0], $allowed_uv, "$testname: utf8n_to_uvchr(), allowed: Returns expected uv: " . sprintf("0x%04X", $allowed_uv));
1312 is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), allowed: Returns expected length: $expected_len");
1313 if (!is(scalar @warnings, 0, "$testname: utf8n_to_uvchr(), allowed: no warnings generated"))
eb83ed87 1314 {
7dfd8446 1315 diag "The warnings were: " . join(", ", @warnings);
eb83ed87
KW		 1316 }
1317}
1318
eb83ed87
KW		 1319# Now test the cases where a legal code point is generated, but may or may not
1320# be allowed/warned on.
2f8f112e 1321my @tests = (
7dfd8446
KW		 1322 [ "lowest surrogate",
1323 (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"),
1324 $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
1325 'surrogate', 0xD800,
1326 (isASCII) ? 3 : 4,
1327 qr/surrogate/
1328 ],
1329 [ "a middle surrogate",
1330 (isASCII) ? "\xed\xa4\x8d" : I8_to_native("\xf1\xb6\xa8\xad"),
1331 $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
1332 'surrogate', 0xD90D,
1333 (isASCII) ? 3 : 4,
eb83ed87
KW		 1334 qr/surrogate/
1335 ],
7dfd8446
KW		 1336 [ "highest surrogate",
1337 (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"),
1338 $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
1339 'surrogate', 0xDFFF,
1340 (isASCII) ? 3 : 4,
1341 qr/surrogate/
1342 ],
1343 [ "first non_unicode",
1344 (isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"),
1345 $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
1346 'non_unicode', 0x110000,
1347 (isASCII) ? 4 : 5,
1348 qr/not Unicode.* may not be portable/
1349 ],
d566bd20
KW		 1350 [ "non_unicode whose first byte tells that",
1351 (isASCII) ? "\xf5\x80\x80\x80" : I8_to_native("\xfa\xa0\xa0\xa0\xa0"),
1352 $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
1353 'non_unicode',
1354 (isASCII) ? 0x140000 : 0x200000,
1355 (isASCII) ? 4 : 5,
1356 qr/not Unicode.* may not be portable/
1357 ],
7dfd8446
KW		 1358 [ "first of 32 consecutive non-character code points",
1359 (isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"),
1360 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1361 'nonchar', 0xFDD0,
1362 (isASCII) ? 3 : 4,
1363 qr/Unicode non-character.*is not recommended for open interchange/
1364 ],
1365 [ "a mid non-character code point of the 32 consecutive ones",
1366 (isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"),
1367 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1368 'nonchar', 0xFDE0,
1369 (isASCII) ? 3 : 4,
1370 qr/Unicode non-character.*is not recommended for open interchange/
1371 ],
1372 [ "final of 32 consecutive non-character code points",
1373 (isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"),
1374 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1375 'nonchar', 0xFDEF,
1376 (isASCII) ? 3 : 4,
1377 qr/Unicode non-character.*is not recommended for open interchange/
1378 ],
1379 [ "non-character code point U+FFFE",
1380 (isASCII) ? "\xef\xbf\xbe" : I8_to_native("\xf1\xbf\xbf\xbe"),
1381 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1382 'nonchar', 0xFFFE,
1383 (isASCII) ? 3 : 4,
1384 qr/Unicode non-character.*is not recommended for open interchange/
1385 ],
1386 [ "non-character code point U+FFFF",
1387 (isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"),
1388 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1389 'nonchar', 0xFFFF,
1390 (isASCII) ? 3 : 4,
1391 qr/Unicode non-character.*is not recommended for open interchange/
1392 ],
1393 [ "non-character code point U+1FFFE",
1394 (isASCII) ? "\xf0\x9f\xbf\xbe" : I8_to_native("\xf3\xbf\xbf\xbe"),
1395 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1396 'nonchar', 0x1FFFE, 4,
1397 qr/Unicode non-character.*is not recommended for open interchange/
1398 ],
1399 [ "non-character code point U+1FFFF",
1400 (isASCII) ? "\xf0\x9f\xbf\xbf" : I8_to_native("\xf3\xbf\xbf\xbf"),
1401 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1402 'nonchar', 0x1FFFF, 4,
1403 qr/Unicode non-character.*is not recommended for open interchange/
1404 ],
1405 [ "non-character code point U+2FFFE",
1406 (isASCII) ? "\xf0\xaf\xbf\xbe" : I8_to_native("\xf5\xbf\xbf\xbe"),
1407 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1408 'nonchar', 0x2FFFE, 4,
1409 qr/Unicode non-character.*is not recommended for open interchange/
1410 ],
1411 [ "non-character code point U+2FFFF",
1412 (isASCII) ? "\xf0\xaf\xbf\xbf" : I8_to_native("\xf5\xbf\xbf\xbf"),
1413 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1414 'nonchar', 0x2FFFF, 4,
1415 qr/Unicode non-character.*is not recommended for open interchange/
1416 ],
1417 [ "non-character code point U+3FFFE",
1418 (isASCII) ? "\xf0\xbf\xbf\xbe" : I8_to_native("\xf7\xbf\xbf\xbe"),
1419 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1420 'nonchar', 0x3FFFE, 4,
1421 qr/Unicode non-character.*is not recommended for open interchange/
1422 ],
1423 [ "non-character code point U+3FFFF",
1424 (isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"),
1425 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1426 'nonchar', 0x3FFFF, 4,
1427 qr/Unicode non-character.*is not recommended for open interchange/
1428 ],
1429 [ "non-character code point U+4FFFE",
1430 (isASCII) ? "\xf1\x8f\xbf\xbe" : I8_to_native("\xf8\xa9\xbf\xbf\xbe"),
1431 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1432 'nonchar', 0x4FFFE,
1433 (isASCII) ? 4 : 5,
1434 qr/Unicode non-character.*is not recommended for open interchange/
1435 ],
1436 [ "non-character code point U+4FFFF",
1437 (isASCII) ? "\xf1\x8f\xbf\xbf" : I8_to_native("\xf8\xa9\xbf\xbf\xbf"),
1438 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1439 'nonchar', 0x4FFFF,
1440 (isASCII) ? 4 : 5,
1441 qr/Unicode non-character.*is not recommended for open interchange/
1442 ],
1443 [ "non-character code point U+5FFFE",
1444 (isASCII) ? "\xf1\x9f\xbf\xbe" : I8_to_native("\xf8\xab\xbf\xbf\xbe"),
1445 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1446 'nonchar', 0x5FFFE,
1447 (isASCII) ? 4 : 5,
1448 qr/Unicode non-character.*is not recommended for open interchange/
1449 ],
1450 [ "non-character code point U+5FFFF",
1451 (isASCII) ? "\xf1\x9f\xbf\xbf" : I8_to_native("\xf8\xab\xbf\xbf\xbf"),
1452 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1453 'nonchar', 0x5FFFF,
1454 (isASCII) ? 4 : 5,
1455 qr/Unicode non-character.*is not recommended for open interchange/
1456 ],
1457 [ "non-character code point U+6FFFE",
1458 (isASCII) ? "\xf1\xaf\xbf\xbe" : I8_to_native("\xf8\xad\xbf\xbf\xbe"),
1459 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1460 'nonchar', 0x6FFFE,
1461 (isASCII) ? 4 : 5,
1462 qr/Unicode non-character.*is not recommended for open interchange/
1463 ],
1464 [ "non-character code point U+6FFFF",
1465 (isASCII) ? "\xf1\xaf\xbf\xbf" : I8_to_native("\xf8\xad\xbf\xbf\xbf"),
1466 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1467 'nonchar', 0x6FFFF,
1468 (isASCII) ? 4 : 5,
1469 qr/Unicode non-character.*is not recommended for open interchange/
1470 ],
1471 [ "non-character code point U+7FFFE",
1472 (isASCII) ? "\xf1\xbf\xbf\xbe" : I8_to_native("\xf8\xaf\xbf\xbf\xbe"),
1473 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1474 'nonchar', 0x7FFFE,
1475 (isASCII) ? 4 : 5,
1476 qr/Unicode non-character.*is not recommended for open interchange/
1477 ],
1478 [ "non-character code point U+7FFFF",
1479 (isASCII) ? "\xf1\xbf\xbf\xbf" : I8_to_native("\xf8\xaf\xbf\xbf\xbf"),
1480 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1481 'nonchar', 0x7FFFF,
1482 (isASCII) ? 4 : 5,
1483 qr/Unicode non-character.*is not recommended for open interchange/
1484 ],
1485 [ "non-character code point U+8FFFE",
1486 (isASCII) ? "\xf2\x8f\xbf\xbe" : I8_to_native("\xf8\xb1\xbf\xbf\xbe"),
1487 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1488 'nonchar', 0x8FFFE,
1489 (isASCII) ? 4 : 5,
1490 qr/Unicode non-character.*is not recommended for open interchange/
1491 ],
1492 [ "non-character code point U+8FFFF",
1493 (isASCII) ? "\xf2\x8f\xbf\xbf" : I8_to_native("\xf8\xb1\xbf\xbf\xbf"),
1494 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1495 'nonchar', 0x8FFFF,
1496 (isASCII) ? 4 : 5,
1497 qr/Unicode non-character.*is not recommended for open interchange/
1498 ],
1499 [ "non-character code point U+9FFFE",
1500 (isASCII) ? "\xf2\x9f\xbf\xbe" : I8_to_native("\xf8\xb3\xbf\xbf\xbe"),
1501 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1502 'nonchar', 0x9FFFE,
1503 (isASCII) ? 4 : 5,
1504 qr/Unicode non-character.*is not recommended for open interchange/
1505 ],
1506 [ "non-character code point U+9FFFF",
1507 (isASCII) ? "\xf2\x9f\xbf\xbf" : I8_to_native("\xf8\xb3\xbf\xbf\xbf"),
1508 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1509 'nonchar', 0x9FFFF,
1510 (isASCII) ? 4 : 5,
1511 qr/Unicode non-character.*is not recommended for open interchange/
1512 ],
1513 [ "non-character code point U+AFFFE",
1514 (isASCII) ? "\xf2\xaf\xbf\xbe" : I8_to_native("\xf8\xb5\xbf\xbf\xbe"),
1515 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1516 'nonchar', 0xAFFFE,
1517 (isASCII) ? 4 : 5,
1518 qr/Unicode non-character.*is not recommended for open interchange/
1519 ],
1520 [ "non-character code point U+AFFFF",
1521 (isASCII) ? "\xf2\xaf\xbf\xbf" : I8_to_native("\xf8\xb5\xbf\xbf\xbf"),
1522 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1523 'nonchar', 0xAFFFF,
1524 (isASCII) ? 4 : 5,
1525 qr/Unicode non-character.*is not recommended for open interchange/
1526 ],
1527 [ "non-character code point U+BFFFE",
1528 (isASCII) ? "\xf2\xbf\xbf\xbe" : I8_to_native("\xf8\xb7\xbf\xbf\xbe"),
1529 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1530 'nonchar', 0xBFFFE,
1531 (isASCII) ? 4 : 5,
1532 qr/Unicode non-character.*is not recommended for open interchange/
1533 ],
1534 [ "non-character code point U+BFFFF",
1535 (isASCII) ? "\xf2\xbf\xbf\xbf" : I8_to_native("\xf8\xb7\xbf\xbf\xbf"),
1536 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1537 'nonchar', 0xBFFFF,
1538 (isASCII) ? 4 : 5,
1539 qr/Unicode non-character.*is not recommended for open interchange/
1540 ],
1541 [ "non-character code point U+CFFFE",
1542 (isASCII) ? "\xf3\x8f\xbf\xbe" : I8_to_native("\xf8\xb9\xbf\xbf\xbe"),
1543 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1544 'nonchar', 0xCFFFE,
1545 (isASCII) ? 4 : 5,
1546 qr/Unicode non-character.*is not recommended for open interchange/
1547 ],
1548 [ "non-character code point U+CFFFF",
1549 (isASCII) ? "\xf3\x8f\xbf\xbf" : I8_to_native("\xf8\xb9\xbf\xbf\xbf"),
1550 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1551 'nonchar', 0xCFFFF,
1552 (isASCII) ? 4 : 5,
1553 qr/Unicode non-character.*is not recommended for open interchange/
1554 ],
1555 [ "non-character code point U+DFFFE",
1556 (isASCII) ? "\xf3\x9f\xbf\xbe" : I8_to_native("\xf8\xbb\xbf\xbf\xbe"),
1557 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1558 'nonchar', 0xDFFFE,
1559 (isASCII) ? 4 : 5,
1560 qr/Unicode non-character.*is not recommended for open interchange/
1561 ],
1562 [ "non-character code point U+DFFFF",
1563 (isASCII) ? "\xf3\x9f\xbf\xbf" : I8_to_native("\xf8\xbb\xbf\xbf\xbf"),
1564 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1565 'nonchar', 0xDFFFF,
1566 (isASCII) ? 4 : 5,
1567 qr/Unicode non-character.*is not recommended for open interchange/
1568 ],
1569 [ "non-character code point U+EFFFE",
1570 (isASCII) ? "\xf3\xaf\xbf\xbe" : I8_to_native("\xf8\xbd\xbf\xbf\xbe"),
1571 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1572 'nonchar', 0xEFFFE,
1573 (isASCII) ? 4 : 5,
1574 qr/Unicode non-character.*is not recommended for open interchange/
1575 ],
1576 [ "non-character code point U+EFFFF",
1577 (isASCII) ? "\xf3\xaf\xbf\xbf" : I8_to_native("\xf8\xbd\xbf\xbf\xbf"),
1578 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1579 'nonchar', 0xEFFFF,
1580 (isASCII) ? 4 : 5,
1581 qr/Unicode non-character.*is not recommended for open interchange/
1582 ],
1583 [ "non-character code point U+FFFFE",
1584 (isASCII) ? "\xf3\xbf\xbf\xbe" : I8_to_native("\xf8\xbf\xbf\xbf\xbe"),
1585 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1586 'nonchar', 0xFFFFE,
1587 (isASCII) ? 4 : 5,
1588 qr/Unicode non-character.*is not recommended for open interchange/
1589 ],
1590 [ "non-character code point U+FFFFF",
1591 (isASCII) ? "\xf3\xbf\xbf\xbf" : I8_to_native("\xf8\xbf\xbf\xbf\xbf"),
1592 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1593 'nonchar', 0xFFFFF,
1594 (isASCII) ? 4 : 5,
1595 qr/Unicode non-character.*is not recommended for open interchange/
1596 ],
1597 [ "non-character code point U+10FFFE",
1598 (isASCII) ? "\xf4\x8f\xbf\xbe" : I8_to_native("\xf9\xa1\xbf\xbf\xbe"),
1599 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1600 'nonchar', 0x10FFFE,
1601 (isASCII) ? 4 : 5,
1602 qr/Unicode non-character.*is not recommended for open interchange/
eb83ed87 1603 ],
7dfd8446
KW		 1604 [ "non-character code point U+10FFFF",
1605 (isASCII) ? "\xf4\x8f\xbf\xbf" : I8_to_native("\xf9\xa1\xbf\xbf\xbf"),
1606 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1607 'nonchar', 0x10FFFF,
1608 (isASCII) ? 4 : 5,
ba707cdc 1609 qr/Unicode non-character.*is not recommended for open interchange/
eb83ed87 1610 ],
1d1c12d9 1611 [ "requires at least 32 bits",
c0236afe
KW		 1612 (isASCII)
1613 ? "\xfe\x82\x80\x80\x80\x80\x80"
1614 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
eb83ed87 1615 # This code point is chosen so that it is representable in a UV on
2f8f112e 1616 # 32-bit machines
1d1c12d9 1617 $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
c0236afe 1618 'utf8', 0x80000000, (isASCII) ? 7 :14,
7dfd8446
KW		 1619 qr/Code point 0x80000000 is not Unicode, and not portable/
1620 ],
1d1c12d9 1621 [ "requires at least 32 bits, and use SUPER-type flags, instead of ABOVE_31_BIT",
c0236afe
KW		 1622 (isASCII)
1623 ? "\xfe\x82\x80\x80\x80\x80\x80"
1624 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
7dfd8446 1625 $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
c0236afe 1626 'utf8', 0x80000000, (isASCII) ? 7 :14,
ea5ced44 1627 qr/Code point 0x80000000 is not Unicode, and not portable/
eb83ed87 1628 ],
1d1c12d9
KW		 1629 [ "overflow with warnings/disallow for more than 31 bits",
1630 # This tests the interaction of WARN_ABOVE_31_BIT/DISALLOW_ABOVE_31_BIT
1631 # with overflow. The overflow malformation is never allowed, so
1632 # preventing it takes precedence if the ABOVE_31_BIT options would
c0236afe 1633 # otherwise allow in an overflowing value. The ASCII code points (1
1d1c12d9
KW		 1634 # for 32-bits; 1 for 64) were chosen because the old overflow
1635 # detection algorithm did not catch them; this means this test also
c0236afe
KW		 1636 # checks for that fix. The EBCDIC are arbitrary overflowing ones
1637 # since we have no reports of failures with it.
1638 (($is64bit)
1639 ? ((isASCII)
9d2d0ecd 1640 ? "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
c0236afe
KW		 1641 : I8_to_native("\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"))
1642 : ((isASCII)
9d2d0ecd 1643 ? "\xfe\x86\x80\x80\x80\x80\x80"
c0236afe 1644 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"))),
ea5ced44 1645
1d1c12d9
KW		 1646 # We include both warning categories to make sure the ABOVE_31_BIT one
1647 # has precedence
1648 "$UTF8_WARN_ABOVE_31_BIT|$UTF8_WARN_SUPER",
1649 "$UTF8_DISALLOW_ABOVE_31_BIT",
7dfd8446 1650 'utf8', 0,
c0236afe 1651 (! isASCII) ? 14 : ($is64bit) ? 13 : 7,
ea5ced44 1652 qr/overflow at byte .*, after start byte 0xf/
eb83ed87 1653 ],
c0236afe 1654);
2f8f112e 1655
c0236afe
KW		 1656if ($is64bit) {
1657 no warnings qw{portable overflow};
2f8f112e 1658 push @tests,
c0236afe
KW		 1659 [ "More than 32 bits",
1660 (isASCII)
9d2d0ecd 1661 ? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
c0236afe 1662 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1d1c12d9 1663 $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
c0236afe 1664 'utf8', 0x1000000000, (isASCII) ? 13 : 14,
ea5ced44 1665 qr/Code point 0x.* is not Unicode, and not portable/
2f8f112e 1666 ];
83dc0f42
KW		 1667 if (! isASCII) {
1668 push @tests, # These could falsely show wrongly in a naive implementation
1669 [ "requires at least 32 bits",
1670 I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1671 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1672 'utf8', 0x800000000, 14,
1673 qr/Code point 0x800000000 is not Unicode, and not portable/
1674 ],
1675 [ "requires at least 32 bits",
1676 I8_to_native("\xff\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1677 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1678 'utf8', 0x10000000000, 14,
1679 qr/Code point 0x10000000000 is not Unicode, and not portable/
1680 ],
1681 [ "requires at least 32 bits",
1682 I8_to_native("\xff\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1683 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1684 'utf8', 0x200000000000, 14,
1685 qr/Code point 0x200000000000 is not Unicode, and not portable/
1686 ],
1687 [ "requires at least 32 bits",
1688 I8_to_native("\xff\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1689 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1690 'utf8', 0x4000000000000, 14,
1691 qr/Code point 0x4000000000000 is not Unicode, and not portable/
1692 ],
1693 [ "requires at least 32 bits",
1694 I8_to_native("\xff\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1695 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1696 'utf8', 0x80000000000000, 14,
1697 qr/Code point 0x80000000000000 is not Unicode, and not portable/
1698 ],
1699 [ "requires at least 32 bits",
1700 I8_to_native("\xff\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1701 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1702 'utf8', 0x1000000000000000, 14,
1703 qr/Code point 0x1000000000000000 is not Unicode, and not portable/
1704 ];
1705 }
2f8f112e
KW		 1706}
1707
1708foreach my $test (@tests) {
eb83ed87
KW		 1709 my ($testname, $bytes, $warn_flags, $disallow_flags, $category, $allowed_uv, $expected_len, $message ) = @$test;
1710
1711 my $length = length $bytes;
2f8f112e 1712 my $will_overflow = $testname =~ /overflow/;
eb83ed87 1713
d7874298
KW		 1714 {
1715 use warnings;
1716 undef @warnings;
1717 my $ret = test_isUTF8_CHAR($bytes, $length);
25e3a4e0 1718 my $ret_flags = test_isUTF8_CHAR_flags($bytes, $length, 0);
d7874298
KW		 1719 if ($will_overflow) {
1720 is($ret, 0, "isUTF8_CHAR() $testname: returns 0");
25e3a4e0 1721 is($ret_flags, 0, "isUTF8_CHAR_flags() $testname: returns 0");
d7874298
KW		 1722 }
1723 else {
1724 is($ret, $length,
1725 "isUTF8_CHAR() $testname: returns expected length: $length");
25e3a4e0
KW		 1726 is($ret_flags, $length,
1727 "isUTF8_CHAR_flags(...,0) $testname: returns expected length: $length");
d7874298
KW		 1728 }
1729 unless (is(scalar @warnings, 0,
25e3a4e0 1730 "isUTF8_CHAR() and isUTF8_CHAR()_flags $testname: generated no warnings"))
d7874298
KW		 1731 {
1732 diag "The warnings were: " . join(", ", @warnings);
1733 }
3d56ecbe 1734
e23e8bc1
KW		 1735 undef @warnings;
1736 $ret = test_isSTRICT_UTF8_CHAR($bytes, $length);
1737 if ($will_overflow) {
1738 is($ret, 0, "isSTRICT_UTF8_CHAR() $testname: returns 0");
1739 }
1740 else {
1741 my $expected_ret = ( $testname =~ /surrogate|non-character/
1742 || $allowed_uv > 0x10FFFF)
1743 ? 0
1744 : $length;
1745 is($ret, $expected_ret,
1746 "isSTRICT_UTF8_CHAR() $testname: returns expected length: $expected_ret");
25e3a4e0
KW		 1747 $ret = test_isUTF8_CHAR_flags($bytes, $length,
1748 $UTF8_DISALLOW_ILLEGAL_INTERCHANGE);
1749 is($ret, $expected_ret,
1750 "isUTF8_CHAR_flags('DISALLOW_ILLEGAL_INTERCHANGE') acts like isSTRICT_UTF8_CHAR");
e23e8bc1
KW		 1751 }
1752 unless (is(scalar @warnings, 0,
25e3a4e0 1753 "isSTRICT_UTF8_CHAR() and isUTF8_CHAR_flags $testname: generated no warnings"))
e23e8bc1
KW		 1754 {
1755 diag "The warnings were: " . join(", ", @warnings);
1756 }
1757
a82be82b
KW		 1758 undef @warnings;
1759 $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $length);
1760 if ($will_overflow) {
1761 is($ret, 0, "isC9_STRICT_UTF8_CHAR() $testname: returns 0");
1762 }
1763 else {
1764 my $expected_ret = ( $testname =~ /surrogate/
1765 || $allowed_uv > 0x10FFFF)
1766 ? 0
1767 : $length;
1768 is($ret, $expected_ret,
1769 "isC9_STRICT_UTF8_CHAR() $testname: returns expected length: $expected_ret");
25e3a4e0
KW		 1770 $ret = test_isUTF8_CHAR_flags($bytes, $length,
1771 $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE);
1772 is($ret, $expected_ret,
1773 "isUTF8_CHAR_flags('DISALLOW_ILLEGAL_C9_INTERCHANGE') acts like isC9_STRICT_UTF8_CHAR");
a82be82b
KW		 1774 }
1775 unless (is(scalar @warnings, 0,
25e3a4e0 1776 "isC9_STRICT_UTF8_CHAR() and isUTF8_CHAR_flags $testname: generated no warnings"))
a82be82b
KW		 1777 {
1778 diag "The warnings were: " . join(", ", @warnings);
1779 }
1780
3d56ecbe
KW		 1781 # Test partial character handling, for each byte not a full character
1782 for my $j (1.. $length - 1) {
1783
1784 # Skip the test for the interaction between overflow and above-31
1785 # bit. It is really testing other things than the partial
1786 # character tests, for which other tests in this file are
1787 # sufficient
1788 last if $testname =~ /overflow/;
1789
1790 foreach my $disallow_flag (0, $disallow_flags) {
1791 my $partial = substr($bytes, 0, $j);
1792 my $ret_should_be;
1793 my $comment;
1794 if ($disallow_flag) {
1795 $ret_should_be = 0;
1796 $comment = "disallowed";
1797 }
1798 else {
1799 $ret_should_be = 1;
1800 $comment = "allowed";
1801 }
1802
1803 if ($disallow_flag) {
1804 if ($testname =~ /non-character/) {
1805 $ret_should_be = 1;
1806 $comment .= ", but but need full char to discern";
1807 }
1808 elsif ($testname =~ /surrogate/) {
1809 if ($j < 2) {
1810 $ret_should_be = 1;
1811 $comment .= ", but need 2 bytes to discern";
1812 }
1813 }
1814 elsif ($testname =~ /first non_unicode/ && $j < 2) {
1815 $ret_should_be = 1;
1816 $comment .= ", but need 2 bytes to discern";
1817 }
418080dc
KW		 1818 elsif ( ! isASCII
1819 && $testname =~ /requires at least 32 bits/)
1820 {
1821 # On EBCDIC, the boundary between 31 and 32 bits is
1822 # more complicated.
1823 $ret_should_be = 1 if native_to_I8($partial) le
1824 "\xFF\xA0\xA0\xA0\xA0\xA0\xA0\xA1\xBF\xBF\xBF\xBF\xBF\xBF";
1825 }
3d56ecbe
KW		 1826 }
1827
1828 undef @warnings;
1829
1830 $ret = test_is_utf8_valid_partial_char_flags($partial, $j, $disallow_flag);
1831 is($ret, $ret_should_be, "$testname: is_utf8_valid_partial_char_flags("
1832 . display_bytes($partial)
1833 . "), $comment: returns $ret_should_be");
1834 unless (is(scalar @warnings, 0,
1835 "$testname: is_utf8_valid_partial_char_flags() generated no warnings"))
1836 {
1837 diag "The warnings were: " . join(", ", @warnings);
1838 }
1839 }
1840 }
d7874298
KW		 1841 }
1842
eb83ed87
KW		 1843 # This is more complicated than the malformations tested earlier, as there
1844 # are several orthogonal variables involved. We test all the subclasses
1845 # of utf8 warnings to verify they work with and without the utf8 class,
1846 # and don't have effects on other sublass warnings
54f4afef 1847 foreach my $warning ('utf8', 'surrogate', 'nonchar', 'non_unicode') {
eb83ed87
KW		 1848 foreach my $warn_flag (0, $warn_flags) {
1849 foreach my $disallow_flag (0, $disallow_flags) {
54f4afef 1850 foreach my $do_warning (0, 1) {
eb83ed87 1851
13d7a909
KW		 1852 my $eval_warn = $do_warning
1853 ? "use warnings '$warning'"
1854 : $warning eq "utf8"
7dfd8446
KW		 1855 ? "no warnings 'utf8'"
1856 : "use warnings 'utf8'; no warnings '$warning'";
2f8f112e 1857
13d7a909
KW		 1858 # is effectively disallowed if will overflow, even if the
1859 # flag indicates it is allowed, fix up test name to
1860 # indicate this as well
1861 my $disallowed = $disallow_flag || $will_overflow;
2f8f112e 1862
046d01eb 1863 my $this_name = "utf8n_to_uvchr() $testname: " . (($disallow_flag)
13d7a909
KW		 1864 ? 'disallowed'
1865 : ($disallowed)
1d1c12d9 1866 ? 'ABOVE_31_BIT allowed'
13d7a909
KW		 1867 : 'allowed');
1868 $this_name .= ", $eval_warn";
1869 $this_name .= ", " . (($warn_flag)
1870 ? 'with warning flag'
1871 : 'no warning flag');
eb83ed87 1872
13d7a909
KW		 1873 undef @warnings;
1874 my $ret_ref;
7dfd8446
KW		 1875 my $display_bytes = display_bytes($bytes);
1876 my $call = "Call was: $eval_warn; \$ret_ref = test_utf8n_to_uvchr('$display_bytes', $length, $warn_flag|$disallow_flag)";
1877 my $eval_text = "$eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)";
13d7a909
KW		 1878 eval "$eval_text";
1879 if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
7dfd8446 1880 diag "\$!='$!'; eval'd=\"$call\"";
13d7a909 1881 next;
54f4afef 1882 }
13d7a909 1883 if ($disallowed) {
7dfd8446
KW		 1884 unless (is($ret_ref->[0], 0, "$this_name: Returns 0"))
1885 {
1886 diag $call;
1887 }
2f8f112e
KW		 1888 }
1889 else {
7dfd8446 1890 unless (is($ret_ref->[0], $allowed_uv,
9d2d0ecd
KW		 1891 "$this_name: Returns expected uv: "
1892 . sprintf("0x%04X", $allowed_uv)))
7dfd8446
KW		 1893 {
1894 diag $call;
1895 }
1896 }
1897 unless (is($ret_ref->[1], $expected_len,
9d2d0ecd 1898 "$this_name: Returns expected length: $expected_len"))
7dfd8446
KW		 1899 {
1900 diag $call;
13d7a909 1901 }
13d7a909
KW		 1902
1903 if (! $do_warning
1904 && ($warning eq 'utf8' || $warning eq $category))
1905 {
1906 if (!is(scalar @warnings, 0,
1907 "$this_name: No warnings generated"))
1908 {
7dfd8446
KW		 1909 diag $call;
1910 diag "The warnings were: " . join(", ", @warnings);
2f8f112e
KW		 1911 }
1912 }
13d7a909
KW		 1913 elsif ($will_overflow
1914 && ! $disallow_flag
1915 && $warning eq 'utf8')
1916 {
1917
1918 # Will get the overflow message instead of the expected
1919 # message under these circumstances, as they would
1920 # otherwise accept an overflowed value, which the code
1921 # should not allow, so falls back to overflow.
1922 if (is(scalar @warnings, 1,
1923 "$this_name: Got a single warning "))
1924 {
7dfd8446
KW		 1925 unless (like($warnings[0], qr/overflow/,
1926 "$this_name: Got overflow warning"))
1927 {
1928 diag $call;
1929 }
13d7a909
KW		 1930 }
1931 else {
7dfd8446 1932 diag $call;
13d7a909 1933 if (scalar @warnings) {
7dfd8446 1934 diag "The warnings were: "
13d7a909
KW		 1935 . join(", ", @warnings);
1936 }
1937 }
eb83ed87 1938 }
13d7a909
KW		 1939 elsif ($warn_flag
1940 && ($warning eq 'utf8' || $warning eq $category))
1941 {
1942 if (is(scalar @warnings, 1,
1943 "$this_name: Got a single warning "))
1944 {
7dfd8446
KW		 1945 unless (like($warnings[0], $message,
1946 "$this_name: Got expected warning"))
1947 {
1948 diag $call;
1949 }
13d7a909
KW		 1950 }
1951 else {
7dfd8446 1952 diag $call;
13d7a909 1953 if (scalar @warnings) {
7dfd8446 1954 diag "The warnings were: "
13d7a909
KW		 1955 . join(", ", @warnings);
1956 }
eb83ed87
KW		 1957 }
1958 }
eb83ed87 1959
13d7a909
KW		 1960 # Check CHECK_ONLY results when the input is disallowed. Do
1961 # this when actually disallowed, not just when the
1962 # $disallow_flag is set
1963 if ($disallowed) {
1964 undef @warnings;
1965 $ret_ref = test_utf8n_to_uvchr($bytes, $length,
1966 $disallow_flag|$UTF8_CHECK_ONLY);
7dfd8446
KW		 1967 unless (is($ret_ref->[0], 0, "$this_name, CHECK_ONLY: Returns 0")) {
1968 diag $call;
1969 }
1970 unless (is($ret_ref->[1], -1,
9d2d0ecd 1971 "$this_name: CHECK_ONLY: returns -1 for length"))
7dfd8446
KW		 1972 {
1973 diag $call;
1974 }
13d7a909
KW		 1975 if (! is(scalar @warnings, 0,
1976 "$this_name, CHECK_ONLY: no warnings generated"))
1977 {
7dfd8446
KW		 1978 diag $call;
1979 diag "The warnings were: " . join(", ", @warnings);
13d7a909 1980 }
eb83ed87 1981 }
046d01eb
KW		 1982
1983 # Now repeat some of the above, but for
1984 # uvchr_to_utf8_flags(). Since this comes from an
1985 # existing code point, it hasn't overflowed.
1986 next if $will_overflow;
1987
1988 # The warning and disallow flags passed in are for
1989 # utf8n_to_uvchr(). Convert them for
1990 # uvchr_to_utf8_flags().
1991 my $uvchr_warn_flag = 0;
1992 my $uvchr_disallow_flag = 0;
1993 if ($warn_flag) {
1994 if ($warn_flag == $UTF8_WARN_SURROGATE) {
1995 $uvchr_warn_flag = $UNICODE_WARN_SURROGATE
1996 }
1997 elsif ($warn_flag == $UTF8_WARN_NONCHAR) {
1998 $uvchr_warn_flag = $UNICODE_WARN_NONCHAR
1999 }
2000 elsif ($warn_flag == $UTF8_WARN_SUPER) {
2001 $uvchr_warn_flag = $UNICODE_WARN_SUPER
2002 }
1d1c12d9 2003 elsif ($warn_flag == $UTF8_WARN_ABOVE_31_BIT) {
046d01eb
KW		 2004 $uvchr_warn_flag = $UNICODE_WARN_ABOVE_31_BIT;
2005 }
2006 else {
2007 fail(sprintf "Unexpected warn flag: %x",
2008 $warn_flag);
2009 next;
2010 }
2011 }
2012 if ($disallow_flag) {
2013 if ($disallow_flag == $UTF8_DISALLOW_SURROGATE) {
2014 $uvchr_disallow_flag = $UNICODE_DISALLOW_SURROGATE
2015 }
2016 elsif ($disallow_flag == $UTF8_DISALLOW_NONCHAR) {
2017 $uvchr_disallow_flag = $UNICODE_DISALLOW_NONCHAR
2018 }
2019 elsif ($disallow_flag == $UTF8_DISALLOW_SUPER) {
2020 $uvchr_disallow_flag = $UNICODE_DISALLOW_SUPER
2021 }
1d1c12d9 2022 elsif ($disallow_flag == $UTF8_DISALLOW_ABOVE_31_BIT) {
046d01eb
KW		 2023 $uvchr_disallow_flag =
2024 $UNICODE_DISALLOW_ABOVE_31_BIT;
2025 }
2026 else {
2027 fail(sprintf "Unexpected disallow flag: %x",
2028 $disallow_flag);
2029 next;
2030 }
2031 }
2032
2033 $disallowed = $uvchr_disallow_flag;
2034
2035 $this_name = "uvchr_to_utf8_flags() $testname: "
2036 . (($uvchr_disallow_flag)
2037 ? 'disallowed'
2038 : ($disallowed)
2039 ? 'ABOVE_31_BIT allowed'
2040 : 'allowed');
2041 $this_name .= ", $eval_warn";
2042 $this_name .= ", " . (($uvchr_warn_flag)
2043 ? 'with warning flag'
2044 : 'no warning flag');
2045
2046 undef @warnings;
2047 my $ret;
2048 my $warn_flag = sprintf "0x%x", $uvchr_warn_flag;
2049 my $disallow_flag = sprintf "0x%x", $uvchr_disallow_flag;
2050 $call = sprintf "call was: $eval_warn; \$ret = test_uvchr_to_utf8_flags(0x%x, $warn_flag|$disallow_flag)", $allowed_uv;
2051 $eval_text = "$eval_warn; \$ret = test_uvchr_to_utf8_flags($allowed_uv, $warn_flag|$disallow_flag)";
2052 eval "$eval_text";
2053 if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
2054 diag "\$!='$!'; eval'd=\"$eval_text\"";
2055 next;
2056 }
2057 if ($disallowed) {
2058 unless (is($ret, undef, "$this_name: Returns undef")) {
2059 diag $call;
2060 }
2061 }
2062 else {
2063 unless (is($ret, $bytes, "$this_name: Returns expected string")) {
2064 diag $call;
2065 }
2066 }
2067 if (! $do_warning
2068 && ($warning eq 'utf8' || $warning eq $category))
2069 {
2070 if (!is(scalar @warnings, 0,
2071 "$this_name: No warnings generated"))
2072 {
2073 diag $call;
2074 diag "The warnings were: " . join(", ", @warnings);
2075 }
2076 }
2077 elsif ($uvchr_warn_flag
2078 && ($warning eq 'utf8' || $warning eq $category))
2079 {
2080 if (is(scalar @warnings, 1,
2081 "$this_name: Got a single warning "))
2082 {
046d01eb
KW		 2083 unless (like($warnings[0], $message,
2084 "$this_name: Got expected warning"))
2085 {
2086 diag $call;
2087 }
046d01eb
KW		 2088 }
2089 else {
2090 diag $call;
2091 if (scalar @warnings) {
2092 diag "The warnings were: "
2093 . join(", ", @warnings);
2094 }
2095 }
2096 }
eb83ed87
KW		 2097 }
2098 }
2099 }
2100 }
2101}
6e3d6c02 2102
fed3ba5d 2103done_testing;
Unnamed repository; edit this file 'description' to name the repository.