This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
APItest/utf8.t: Some clean up
[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
49*I8_to_native = (isASCII)
50 ? sub { return shift }
51 : sub { return join "", map { chr $i8_to_native[ord $_] }
52 split "", shift };
53
54my $is64bit = length sprintf("%x", ~0) > 8;
55
56
57# Test utf8n_to_uvchr(). These provide essentially complete code coverage.
58# Copied from utf8.h
59my $UTF8_ALLOW_EMPTY = 0x0001;
60my $UTF8_ALLOW_CONTINUATION = 0x0002;
61my $UTF8_ALLOW_NON_CONTINUATION = 0x0004;
62my $UTF8_ALLOW_SHORT = 0x0008;
63my $UTF8_ALLOW_LONG = 0x0010;
64my $UTF8_DISALLOW_SURROGATE = 0x0020;
65my $UTF8_WARN_SURROGATE = 0x0040;
66my $UTF8_DISALLOW_NONCHAR = 0x0080;
67my $UTF8_WARN_NONCHAR = 0x0100;
68my $UTF8_DISALLOW_SUPER = 0x0200;
69my $UTF8_WARN_SUPER = 0x0400;
1d1c12d9
KW
70my $UTF8_DISALLOW_ABOVE_31_BIT = 0x0800;
71my $UTF8_WARN_ABOVE_31_BIT = 0x1000;
7dfd8446
KW
72my $UTF8_CHECK_ONLY = 0x2000;
73
046d01eb
KW
74# Test uvchr_to_utf8().
75my $UNICODE_WARN_SURROGATE = 0x0001;
76my $UNICODE_WARN_NONCHAR = 0x0002;
77my $UNICODE_WARN_SUPER = 0x0004;
78my $UNICODE_WARN_ABOVE_31_BIT = 0x0008;
79my $UNICODE_DISALLOW_SURROGATE = 0x0010;
80my $UNICODE_DISALLOW_NONCHAR = 0x0020;
81my $UNICODE_DISALLOW_SUPER = 0x0040;
82my $UNICODE_DISALLOW_ABOVE_31_BIT = 0x0080;
83
84my $look_for_everything_utf8n_to
85 = $UTF8_DISALLOW_SURROGATE
7dfd8446
KW
86 | $UTF8_WARN_SURROGATE
87 | $UTF8_DISALLOW_NONCHAR
88 | $UTF8_WARN_NONCHAR
89 | $UTF8_DISALLOW_SUPER
90 | $UTF8_WARN_SUPER
1d1c12d9
KW
91 | $UTF8_DISALLOW_ABOVE_31_BIT
92 | $UTF8_WARN_ABOVE_31_BIT;
046d01eb
KW
93my $look_for_everything_uvchr_to
94 = $UNICODE_DISALLOW_SURROGATE
95 | $UNICODE_WARN_SURROGATE
96 | $UNICODE_DISALLOW_NONCHAR
97 | $UNICODE_WARN_NONCHAR
98 | $UNICODE_DISALLOW_SUPER
99 | $UNICODE_WARN_SUPER
100 | $UNICODE_DISALLOW_ABOVE_31_BIT
101 | $UNICODE_WARN_ABOVE_31_BIT;
7dfd8446 102
fed3ba5d
NC
103foreach ([0, '', '', 'empty'],
104 [0, 'N', 'N', '1 char'],
105 [1, 'NN', 'N', '1 char substring'],
106 [-2, 'Perl', 'Rules', 'different'],
4deba822
KW
107 [0, $pound_sign, $pound_sign, 'pound sign'],
108 [1, $pound_sign . 10, $pound_sign . 1, '10 pounds is more than 1 pound'],
109 [1, $pound_sign . $pound_sign, $pound_sign, '2 pound signs are more than 1'],
fed3ba5d
NC
110 [-2, ' $!', " \x{1F42B}!", 'Camels are worth more than 1 dollar'],
111 [-1, '!', "!\x{1F42A}", 'Initial substrings match'],
112 ) {
113 my ($expect, $left, $right, $desc) = @$_;
114 my $copy = $right;
115 utf8::encode($copy);
116 is(bytes_cmp_utf8($left, $copy), $expect, $desc);
117 next if $right =~ tr/\0-\377//c;
118 utf8::encode($left);
119 is(bytes_cmp_utf8($right, $left), -$expect, "$desc reversed");
120}
121
7dfd8446
KW
122# The keys to this hash are Unicode code points, their values are the native
123# UTF-8 representations of them. The code points are chosen because they are
124# "interesting" on either or both ASCII and EBCDIC platforms. First we add
125# boundaries where the number of bytes required to represent them increase, or
126# are adjacent to problematic code points, so we want to make sure they aren't
127# considered problematic.
128my %code_points = (
129 0x0100 => (isASCII) ? "\xc4\x80" : I8_to_native("\xc8\xa0"),
130 0x0400 - 1 => (isASCII) ? "\xcf\xbf" : I8_to_native("\xdf\xbf"),
131 0x0400 => (isASCII) ? "\xd0\x80" : I8_to_native("\xe1\xa0\xa0"),
132 0x0800 - 1 => (isASCII) ? "\xdf\xbf" : I8_to_native("\xe1\xbf\xbf"),
133 0x0800 => (isASCII) ? "\xe0\xa0\x80" : I8_to_native("\xe2\xa0\xa0"),
134 0x4000 - 1 => (isASCII) ? "\xe3\xbf\xbf" : I8_to_native("\xef\xbf\xbf"),
135 0x4000 => (isASCII) ? "\xe4\x80\x80" : I8_to_native("\xf0\xb0\xa0\xa0"),
136 0x8000 - 1 => (isASCII) ? "\xe7\xbf\xbf" : I8_to_native("\xf0\xbf\xbf\xbf"),
137
138 # First code point that the implementation of isUTF8_POSSIBLY_PROBLEMATIC,
139 # as of this writing, considers potentially problematic on EBCDIC
140 0x8000 => (isASCII) ? "\xe8\x80\x80" : I8_to_native("\xf1\xa0\xa0\xa0"),
141
142 0xD000 - 1 => (isASCII) ? "\xec\xbf\xbf" : I8_to_native("\xf1\xb3\xbf\xbf"),
143
144 # First code point that the implementation of isUTF8_POSSIBLY_PROBLEMATIC,
145 # as of this writing, considers potentially problematic on ASCII
146 0xD000 => (isASCII) ? "\xed\x80\x80" : I8_to_native("\xf1\xb4\xa0\xa0"),
147
148 # Bracket the surrogates
149 0xD7FF => (isASCII) ? "\xed\x9f\xbf" : I8_to_native("\xf1\xb5\xbf\xbf"),
150 0xE000 => (isASCII) ? "\xee\x80\x80" : I8_to_native("\xf1\xb8\xa0\xa0"),
151
152 # Bracket the 32 contiguous non characters
153 0xFDCF => (isASCII) ? "\xef\xb7\x8f" : I8_to_native("\xf1\xbf\xae\xaf"),
154 0xFDF0 => (isASCII) ? "\xef\xb7\xb0" : I8_to_native("\xf1\xbf\xaf\xb0"),
155
156 # Mostly bracket non-characters, but some are transitions to longer
157 # strings
158 0xFFFD => (isASCII) ? "\xef\xbf\xbd" : I8_to_native("\xf1\xbf\xbf\xbd"),
159 0x10000 - 1 => (isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"),
160 0x10000 => (isASCII) ? "\xf0\x90\x80\x80" : I8_to_native("\xf2\xa0\xa0\xa0"),
161 0x1FFFD => (isASCII) ? "\xf0\x9f\xbf\xbd" : I8_to_native("\xf3\xbf\xbf\xbd"),
162 0x20000 => (isASCII) ? "\xf0\xa0\x80\x80" : I8_to_native("\xf4\xa0\xa0\xa0"),
163 0x2FFFD => (isASCII) ? "\xf0\xaf\xbf\xbd" : I8_to_native("\xf5\xbf\xbf\xbd"),
164 0x30000 => (isASCII) ? "\xf0\xb0\x80\x80" : I8_to_native("\xf6\xa0\xa0\xa0"),
165 0x3FFFD => (isASCII) ? "\xf0\xbf\xbf\xbd" : I8_to_native("\xf7\xbf\xbf\xbd"),
166 0x40000 - 1 => (isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"),
167 0x40000 => (isASCII) ? "\xf1\x80\x80\x80" : I8_to_native("\xf8\xa8\xa0\xa0\xa0"),
168 0x4FFFD => (isASCII) ? "\xf1\x8f\xbf\xbd" : I8_to_native("\xf8\xa9\xbf\xbf\xbd"),
169 0x50000 => (isASCII) ? "\xf1\x90\x80\x80" : I8_to_native("\xf8\xaa\xa0\xa0\xa0"),
170 0x5FFFD => (isASCII) ? "\xf1\x9f\xbf\xbd" : I8_to_native("\xf8\xab\xbf\xbf\xbd"),
171 0x60000 => (isASCII) ? "\xf1\xa0\x80\x80" : I8_to_native("\xf8\xac\xa0\xa0\xa0"),
172 0x6FFFD => (isASCII) ? "\xf1\xaf\xbf\xbd" : I8_to_native("\xf8\xad\xbf\xbf\xbd"),
173 0x70000 => (isASCII) ? "\xf1\xb0\x80\x80" : I8_to_native("\xf8\xae\xa0\xa0\xa0"),
174 0x7FFFD => (isASCII) ? "\xf1\xbf\xbf\xbd" : I8_to_native("\xf8\xaf\xbf\xbf\xbd"),
175 0x80000 => (isASCII) ? "\xf2\x80\x80\x80" : I8_to_native("\xf8\xb0\xa0\xa0\xa0"),
176 0x8FFFD => (isASCII) ? "\xf2\x8f\xbf\xbd" : I8_to_native("\xf8\xb1\xbf\xbf\xbd"),
177 0x90000 => (isASCII) ? "\xf2\x90\x80\x80" : I8_to_native("\xf8\xb2\xa0\xa0\xa0"),
178 0x9FFFD => (isASCII) ? "\xf2\x9f\xbf\xbd" : I8_to_native("\xf8\xb3\xbf\xbf\xbd"),
179 0xA0000 => (isASCII) ? "\xf2\xa0\x80\x80" : I8_to_native("\xf8\xb4\xa0\xa0\xa0"),
180 0xAFFFD => (isASCII) ? "\xf2\xaf\xbf\xbd" : I8_to_native("\xf8\xb5\xbf\xbf\xbd"),
181 0xB0000 => (isASCII) ? "\xf2\xb0\x80\x80" : I8_to_native("\xf8\xb6\xa0\xa0\xa0"),
182 0xBFFFD => (isASCII) ? "\xf2\xbf\xbf\xbd" : I8_to_native("\xf8\xb7\xbf\xbf\xbd"),
183 0xC0000 => (isASCII) ? "\xf3\x80\x80\x80" : I8_to_native("\xf8\xb8\xa0\xa0\xa0"),
184 0xCFFFD => (isASCII) ? "\xf3\x8f\xbf\xbd" : I8_to_native("\xf8\xb9\xbf\xbf\xbd"),
185 0xD0000 => (isASCII) ? "\xf3\x90\x80\x80" : I8_to_native("\xf8\xba\xa0\xa0\xa0"),
186 0xDFFFD => (isASCII) ? "\xf3\x9f\xbf\xbd" : I8_to_native("\xf8\xbb\xbf\xbf\xbd"),
187 0xE0000 => (isASCII) ? "\xf3\xa0\x80\x80" : I8_to_native("\xf8\xbc\xa0\xa0\xa0"),
188 0xEFFFD => (isASCII) ? "\xf3\xaf\xbf\xbd" : I8_to_native("\xf8\xbd\xbf\xbf\xbd"),
189 0xF0000 => (isASCII) ? "\xf3\xb0\x80\x80" : I8_to_native("\xf8\xbe\xa0\xa0\xa0"),
190 0xFFFFD => (isASCII) ? "\xf3\xbf\xbf\xbd" : I8_to_native("\xf8\xbf\xbf\xbf\xbd"),
191 0x100000 => (isASCII) ? "\xf4\x80\x80\x80" : I8_to_native("\xf9\xa0\xa0\xa0\xa0"),
192 0x10FFFD => (isASCII) ? "\xf4\x8f\xbf\xbd" : I8_to_native("\xf9\xa1\xbf\xbf\xbd"),
193 0x110000 => (isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"),
194
195 # Things that would be noncharacters if they were in Unicode, and might be
196 # mistaken, if the C code is bad, to be nonchars
197 0x11FFFE => (isASCII) ? "\xf4\x9f\xbf\xbe" : I8_to_native("\xf9\xa3\xbf\xbf\xbe"),
198 0x11FFFF => (isASCII) ? "\xf4\x9f\xbf\xbf" : I8_to_native("\xf9\xa3\xbf\xbf\xbf"),
199 0x20FFFE => (isASCII) ? "\xf8\x88\x8f\xbf\xbe" : I8_to_native("\xfa\xa1\xbf\xbf\xbe"),
200 0x20FFFF => (isASCII) ? "\xf8\x88\x8f\xbf\xbf" : I8_to_native("\xfa\xa1\xbf\xbf\xbf"),
201
202 0x200000 - 1 => (isASCII) ? "\xf7\xbf\xbf\xbf" : I8_to_native("\xf9\xbf\xbf\xbf\xbf"),
203 0x200000 => (isASCII) ? "\xf8\x88\x80\x80\x80" : I8_to_native("\xfa\xa0\xa0\xa0\xa0"),
204 0x400000 - 1 => (isASCII) ? "\xf8\x8f\xbf\xbf\xbf" : I8_to_native("\xfb\xbf\xbf\xbf\xbf"),
205 0x400000 => (isASCII) ? "\xf8\x90\x80\x80\x80" : I8_to_native("\xfc\xa4\xa0\xa0\xa0\xa0"),
206 0x4000000 - 1 => (isASCII) ? "\xfb\xbf\xbf\xbf\xbf" : I8_to_native("\xfd\xbf\xbf\xbf\xbf\xbf"),
207 0x4000000 => (isASCII) ? "\xfc\x84\x80\x80\x80\x80" : I8_to_native("\xfe\xa2\xa0\xa0\xa0\xa0\xa0"),
208 0x4000000 - 1 => (isASCII) ? "\xfb\xbf\xbf\xbf\xbf" : I8_to_native("\xfd\xbf\xbf\xbf\xbf\xbf"),
209 0x4000000 => (isASCII) ? "\xfc\x84\x80\x80\x80\x80" : I8_to_native("\xfe\xa2\xa0\xa0\xa0\xa0\xa0"),
210 0x40000000 - 1 => (isASCII) ? "\xfc\xbf\xbf\xbf\xbf\xbf" : I8_to_native("\xfe\xbf\xbf\xbf\xbf\xbf\xbf"),
211 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"),
212 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
213 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"),
214 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 215);
4deba822 216
7dfd8446
KW
217if ($is64bit) {
218 no warnings qw(overflow portable);
9d2d0ecd
KW
219 $code_points{0x100000000} = (isASCII)
220 ? "\xfe\x84\x80\x80\x80\x80\x80"
221 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0");
222 $code_points{0x1000000000 - 1} = (isASCII)
223 ? "\xfe\xbf\xbf\xbf\xbf\xbf\xbf"
224 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa1\xbf\xbf\xbf\xbf\xbf\xbf\xbf");
225 $code_points{0x1000000000} = (isASCII)
226 ? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
227 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0");
228 $code_points{0xFFFFFFFFFFFFFFFF} = (isASCII)
229 ? "\xff\x80\x8f\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
230 : I8_to_native("\xff\xaf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf");
7dfd8446 231}
eb83ed87 232
7dfd8446
KW
233# Now add in entries for each of code points 0-255, which require special
234# handling on EBCDIC. Remember the keys are Unicode values, and the values
235# are the native UTF-8. For invariants, the bytes are just the native chr.
236
237my $cp = 0;
238while ($cp < ((isASCII) ? 128 : 160)) { # This is from the definition of
239 # invariant
240 $code_points{$cp} = chr utf8::unicode_to_native($cp);
241 $cp++;
242}
243
244# Done with the invariants. Now do the variants. All in this range are 2
245# byte. Again, we can't use the internal functions to generate UTF-8, as
246# those are what we are trying to test. In the loop, we know what range the
247# continuation bytes can be in, and what the lowest start byte can be. So we
248# cycle through them.
249
250my $first_continuation = (isASCII) ? 0x80 : 0xA0;
251my $final_continuation = 0xBF;
252my $start = (isASCII) ? 0xC2 : 0xC5;
253
254my $continuation = $first_continuation - 1;
255
256while ($cp < 255) {
257 if (++$continuation > $final_continuation) {
258
259 # Wrap to the next start byte when we reach the final continuation
260 # byte possible
261 $continuation = $first_continuation;
262 $start++;
263 }
264 $code_points{$cp} = I8_to_native(chr($start) . chr($continuation));
265
266 $cp++;
267}
eb83ed87
KW
268
269my @warnings;
270
271use warnings 'utf8';
272local $SIG{__WARN__} = sub { push @warnings, @_ };
273
7dfd8446
KW
274# This set of tests looks for basic sanity, and lastly tests the bottom level
275# decode routine for the given code point. If the earlier tests for that code
276# point fail, that one probably will too. Malformations are tested in later
277# segments of code.
278for my $u (sort { utf8::unicode_to_native($a) <=> utf8::unicode_to_native($b) }
279 keys %code_points)
280{
281 my $hex_u = sprintf("0x%02X", $u);
282 my $n = utf8::unicode_to_native($u);
283 my $hex_n = sprintf("0x%02X", $n);
284 my $bytes = $code_points{$u};
285
286 my $offskip_should_be;
287 {
288 no warnings qw(overflow portable);
289 $offskip_should_be = (isASCII)
290 ? ( $u < 0x80 ? 1 :
291 $u < 0x800 ? 2 :
292 $u < 0x10000 ? 3 :
293 $u < 0x200000 ? 4 :
294 $u < 0x4000000 ? 5 :
295 $u < 0x80000000 ? 6 : (($is64bit)
296 ? ($u < 0x1000000000 ? 7 : 13)
297 : 7)
298 )
299 : ($u < 0xA0 ? 1 :
300 $u < 0x400 ? 2 :
301 $u < 0x4000 ? 3 :
302 $u < 0x40000 ? 4 :
303 $u < 0x400000 ? 5 :
c0236afe
KW
304 $u < 0x4000000 ? 6 :
305 $u < 0x40000000 ? 7 : 14 );
7dfd8446
KW
306 }
307
308 # If this test fails, subsequent ones are meaningless.
309 next unless is(test_OFFUNISKIP($u), $offskip_should_be,
310 "Verify OFFUNISKIP($hex_u) is $offskip_should_be");
311 my $invariant = $offskip_should_be == 1;
312 my $display_invariant = $invariant || 0;
313 is(test_OFFUNI_IS_INVARIANT($u), $invariant,
314 "Verify OFFUNI_IS_INVARIANT($hex_u) is $display_invariant");
315
316 my $uvchr_skip_should_be = $offskip_should_be;
317 next unless is(test_UVCHR_SKIP($n), $uvchr_skip_should_be,
318 "Verify UVCHR_SKIP($hex_n) is $uvchr_skip_should_be");
319 is(test_UVCHR_IS_INVARIANT($n), $offskip_should_be == 1,
320 "Verify UVCHR_IS_INVARIANT($hex_n) is $display_invariant");
321
322 my $n_chr = chr $n;
323 utf8::upgrade $n_chr;
324
325 is(test_UTF8_SKIP($n_chr), $uvchr_skip_should_be,
326 "Verify UTF8_SKIP(chr $hex_n) is $uvchr_skip_should_be");
327
328 use bytes;
329 for (my $j = 0; $j < length $n_chr; $j++) {
330 my $b = substr($n_chr, $j, 1);
331 my $hex_b = sprintf("\"\\x%02x\"", ord $b);
332
333 my $byte_invariant = $j == 0 && $uvchr_skip_should_be == 1;
334 my $display_byte_invariant = $byte_invariant || 0;
335 next unless is(test_UTF8_IS_INVARIANT($b), $byte_invariant,
336 " Verify UTF8_IS_INVARIANT($hex_b) for byte $j "
337 . "is $display_byte_invariant");
338
339 my $is_start = $j == 0 && $uvchr_skip_should_be > 1;
340 my $display_is_start = $is_start || 0;
341 next unless is(test_UTF8_IS_START($b), $is_start,
342 " Verify UTF8_IS_START($hex_b) is $display_is_start");
343
344 my $is_continuation = $j != 0 && $uvchr_skip_should_be > 1;
345 my $display_is_continuation = $is_continuation || 0;
346 next unless is(test_UTF8_IS_CONTINUATION($b), $is_continuation,
347 " Verify UTF8_IS_CONTINUATION($hex_b) is "
348 . "$display_is_continuation");
349
350 my $is_continued = $uvchr_skip_should_be > 1;
351 my $display_is_continued = $is_continued || 0;
352 next unless is(test_UTF8_IS_CONTINUED($b), $is_continued,
353 " Verify UTF8_IS_CONTINUED($hex_b) is "
354 . "$display_is_continued");
355
356 my $is_downgradeable_start = $n < 256
357 && $uvchr_skip_should_be > 1
358 && $j == 0;
359 my $display_is_downgradeable_start = $is_downgradeable_start || 0;
360 next unless is(test_UTF8_IS_DOWNGRADEABLE_START($b),
361 $is_downgradeable_start,
362 " Verify UTF8_IS_DOWNGRADEABLE_START($hex_b) is "
363 . "$display_is_downgradeable_start");
364
365 my $is_above_latin1 = $n > 255 && $j == 0;
366 my $display_is_above_latin1 = $is_above_latin1 || 0;
367 next unless is(test_UTF8_IS_ABOVE_LATIN1($b),
368 $is_above_latin1,
369 " Verify UTF8_IS_ABOVE_LATIN1($hex_b) is "
370 . "$display_is_above_latin1");
371
372 my $is_possibly_problematic = $j == 0
373 && $n >= ((isASCII)
374 ? 0xD000
375 : 0x8000);
376 my $display_is_possibly_problematic = $is_possibly_problematic || 0;
377 next unless is(test_isUTF8_POSSIBLY_PROBLEMATIC($b),
378 $is_possibly_problematic,
379 " Verify isUTF8_POSSIBLY_PROBLEMATIC($hex_b) is "
380 . "$display_is_above_latin1");
381 }
382
383 # We are not trying to look for warnings, etc, so if they should occur, it
384 # is an error. But some of the code points here do cause warnings, so we
385 # check here and turn off the ones that apply to such code points. A
386 # later section of the code tests for these kinds of things.
046d01eb 387 my $this_utf8_flags = $look_for_everything_utf8n_to;
7dfd8446
KW
388 my $len = length $bytes;
389 if ($n > 2 ** 31 - 1) {
1d1c12d9
KW
390 $this_utf8_flags &=
391 ~($UTF8_DISALLOW_ABOVE_31_BIT|$UTF8_WARN_ABOVE_31_BIT);
7dfd8446
KW
392 }
393 if ($n > 0x10FFFF) {
394 $this_utf8_flags &= ~($UTF8_DISALLOW_SUPER|$UTF8_WARN_SUPER);
395 }
396 elsif (($n & 0xFFFE) == 0xFFFE) {
397 $this_utf8_flags &= ~($UTF8_DISALLOW_NONCHAR|$UTF8_WARN_NONCHAR);
398 }
399
400 undef @warnings;
401
402 my $display_flags = sprintf "0x%x", $this_utf8_flags;
7dfd8446 403 my $display_bytes = display_bytes($bytes);
d7874298 404 my $ret_ref = test_utf8n_to_uvchr($bytes, $len, $this_utf8_flags);
7dfd8446 405 is($ret_ref->[0], $n, "Verify utf8n_to_uvchr($display_bytes, $display_flags) returns $hex_n");
9d2d0ecd 406 is($ret_ref->[1], $len, "Verify utf8n_to_uvchr() for $hex_n returns expected length: $len");
7dfd8446
KW
407
408 unless (is(scalar @warnings, 0,
409 "Verify utf8n_to_uvchr() for $hex_n generated no warnings"))
410 {
411 diag "The warnings were: " . join(", ", @warnings);
412 }
046d01eb 413
75ffa578
KW
414 undef @warnings;
415
d7874298 416 my $ret = test_isUTF8_CHAR($bytes, $len);
9d2d0ecd 417 is($ret, $len, "Verify isUTF8_CHAR($display_bytes) returns expected length: $len");
d7874298
KW
418
419 unless (is(scalar @warnings, 0,
420 "Verify isUTF8_CHAR() for $hex_n generated no warnings"))
421 {
422 diag "The warnings were: " . join(", ", @warnings);
423 }
424
425 undef @warnings;
426
427 $ret = test_isUTF8_CHAR($bytes, $len - 1);
428 is($ret, 0, "Verify isUTF8_CHAR() with too short length parameter returns 0");
429
430 unless (is(scalar @warnings, 0,
431 "Verify isUTF8_CHAR() generated no warnings"))
432 {
433 diag "The warnings were: " . join(", ", @warnings);
434 }
435
436 undef @warnings;
437
75ffa578
KW
438 $ret_ref = test_valid_utf8_to_uvchr($bytes);
439 is($ret_ref->[0], $n, "Verify valid_utf8_to_uvchr($display_bytes) returns $hex_n");
9d2d0ecd 440 is($ret_ref->[1], $len, "Verify valid_utf8_to_uvchr() for $hex_n returns expected length: $len");
75ffa578
KW
441
442 unless (is(scalar @warnings, 0,
443 "Verify valid_utf8_to_uvchr() for $hex_n generated no warnings"))
444 {
445 diag "The warnings were: " . join(", ", @warnings);
446 }
447
046d01eb
KW
448 # Similarly for uvchr_to_utf8
449 my $this_uvchr_flags = $look_for_everything_uvchr_to;
450 if ($n > 2 ** 31 - 1) {
451 $this_uvchr_flags &=
452 ~($UNICODE_DISALLOW_ABOVE_31_BIT|$UNICODE_WARN_ABOVE_31_BIT);
453 }
454 if ($n > 0x10FFFF) {
455 $this_uvchr_flags &= ~($UNICODE_DISALLOW_SUPER|$UNICODE_WARN_SUPER);
456 }
457 elsif (($n & 0xFFFE) == 0xFFFE) {
458 $this_uvchr_flags &= ~($UNICODE_DISALLOW_NONCHAR|$UNICODE_WARN_NONCHAR);
459 }
460 $display_flags = sprintf "0x%x", $this_uvchr_flags;
461
462 undef @warnings;
463
d7874298 464 $ret = test_uvchr_to_utf8_flags($n, $this_uvchr_flags);
046d01eb
KW
465 ok(defined $ret, "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returned success");
466 is($ret, $bytes, "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returns correct bytes");
467
468 unless (is(scalar @warnings, 0,
469 "Verify uvchr_to_utf8_flags($hex_n, $display_flags) for $hex_n generated no warnings"))
470 {
471 diag "The warnings were: " . join(", ", @warnings);
472 }
7dfd8446
KW
473}
474
475my $REPLACEMENT = 0xFFFD;
476
477# Now test the malformations. All these raise category utf8 warnings.
478my $c = (isASCII) ? "\x80" : "\xa0"; # A continuation byte
479my @malformations = (
eb83ed87
KW
480 [ "zero length string malformation", "", 0,
481 $UTF8_ALLOW_EMPTY, 0, 0,
482 qr/empty string/
483 ],
7dfd8446
KW
484 [ "orphan continuation byte malformation", I8_to_native("${c}a"),
485 2,
eb83ed87
KW
486 $UTF8_ALLOW_CONTINUATION, $REPLACEMENT, 1,
487 qr/unexpected continuation byte/
488 ],
7dfd8446 489 [ "premature next character malformation (immediate)",
9d2d0ecd
KW
490 (isASCII) ? "\xc2\xc2\x80" : I8_to_native("\xc5\xc5\xa0"),
491 3,
eb83ed87
KW
492 $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 1,
493 qr/unexpected non-continuation byte.*immediately after start byte/
494 ],
7dfd8446
KW
495 [ "premature next character malformation (non-immediate)",
496 I8_to_native("\xf0${c}a"),
497 3,
eb83ed87
KW
498 $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 2,
499 qr/unexpected non-continuation byte .* 2 bytes after start byte/
500 ],
7dfd8446 501 [ "too short malformation", I8_to_native("\xf0${c}a"), 2,
eb83ed87
KW
502 # Having the 'a' after this, but saying there are only 2 bytes also
503 # tests that we pay attention to the passed in length
504 $UTF8_ALLOW_SHORT, $REPLACEMENT, 2,
505 qr/2 bytes, need 4/
506 ],
7dfd8446
KW
507 [ "overlong malformation", I8_to_native("\xc0$c"), 2,
508 $UTF8_ALLOW_LONG,
509 0, # NUL
510 2,
eb83ed87 511 qr/2 bytes, need 1/
c0236afe 512 ],
7dfd8446
KW
513 [ "overflow malformation",
514 # These are the smallest overflowing on 64 byte machines:
515 # 2**64
c0236afe
KW
516 (isASCII) ? "\xff\x80\x90\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"
517 : I8_to_native("\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
518 (isASCII) ? 13 : 14,
eb83ed87 519 0, # There is no way to allow this malformation
7dfd8446 520 $REPLACEMENT,
c0236afe 521 (isASCII) ? 13 : 14,
eb83ed87 522 qr/overflow/
c0236afe
KW
523 ],
524);
7dfd8446
KW
525
526foreach my $test (@malformations) {
eb83ed87
KW
527 my ($testname, $bytes, $length, $allow_flags, $allowed_uv, $expected_len, $message ) = @$test;
528
529 next if ! ok(length($bytes) >= $length, "$testname: Make sure won't read beyond buffer: " . length($bytes) . " >= $length");
530
d7874298
KW
531 undef @warnings;
532
533 my $ret = test_isUTF8_CHAR($bytes, $length);
534 is($ret, 0, "$testname: isUTF8_CHAR returns 0");
535 unless (is(scalar @warnings, 0,
536 "$testname: isUTF8_CHAR() generated no warnings"))
537 {
538 diag "The warnings were: " . join(", ", @warnings);
539 }
540
541
eb83ed87
KW
542 # Test what happens when this malformation is not allowed
543 undef @warnings;
bd70aaaf 544 my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
eb83ed87 545 is($ret_ref->[0], 0, "$testname: disallowed: Returns 0");
9d2d0ecd 546 is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), disallowed: Returns expected length: $expected_len");
eb83ed87
KW
547 if (is(scalar @warnings, 1, "$testname: disallowed: Got a single warning ")) {
548 like($warnings[0], $message, "$testname: disallowed: Got expected warning");
549 }
550 else {
551 if (scalar @warnings) {
7dfd8446 552 diag "The warnings were: " . join(", ", @warnings);
eb83ed87
KW
553 }
554 }
555
556 { # Next test when disallowed, and warnings are off.
557 undef @warnings;
558 no warnings 'utf8';
bd70aaaf 559 my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
9d2d0ecd
KW
560 is($ret_ref->[0], 0, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': Returns 0");
561 is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': Returns expected length: $expected_len");
562 if (!is(scalar @warnings, 0, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': no warnings generated")) {
7dfd8446 563 diag "The warnings were: " . join(", ", @warnings);
eb83ed87
KW
564 }
565 }
566
567 # Test with CHECK_ONLY
568 undef @warnings;
bd70aaaf 569 $ret_ref = test_utf8n_to_uvchr($bytes, $length, $UTF8_CHECK_ONLY);
eb83ed87 570 is($ret_ref->[0], 0, "$testname: CHECK_ONLY: Returns 0");
9d2d0ecd 571 is($ret_ref->[1], -1, "$testname: CHECK_ONLY: returns -1 for length");
eb83ed87 572 if (! is(scalar @warnings, 0, "$testname: CHECK_ONLY: no warnings generated")) {
7dfd8446 573 diag "The warnings were: " . join(", ", @warnings);
eb83ed87
KW
574 }
575
576 next if $allow_flags == 0; # Skip if can't allow this malformation
577
578 # Test when the malformation is allowed
579 undef @warnings;
bd70aaaf 580 $ret_ref = test_utf8n_to_uvchr($bytes, $length, $allow_flags);
9d2d0ecd
KW
581 is($ret_ref->[0], $allowed_uv, "$testname: utf8n_to_uvchr(), allowed: Returns expected uv: " . sprintf("0x%04X", $allowed_uv));
582 is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), allowed: Returns expected length: $expected_len");
583 if (!is(scalar @warnings, 0, "$testname: utf8n_to_uvchr(), allowed: no warnings generated"))
eb83ed87 584 {
7dfd8446 585 diag "The warnings were: " . join(", ", @warnings);
eb83ed87
KW
586 }
587}
588
eb83ed87
KW
589# Now test the cases where a legal code point is generated, but may or may not
590# be allowed/warned on.
2f8f112e 591my @tests = (
7dfd8446
KW
592 [ "lowest surrogate",
593 (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"),
594 $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
595 'surrogate', 0xD800,
596 (isASCII) ? 3 : 4,
597 qr/surrogate/
598 ],
599 [ "a middle surrogate",
600 (isASCII) ? "\xed\xa4\x8d" : I8_to_native("\xf1\xb6\xa8\xad"),
601 $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
602 'surrogate', 0xD90D,
603 (isASCII) ? 3 : 4,
eb83ed87
KW
604 qr/surrogate/
605 ],
7dfd8446
KW
606 [ "highest surrogate",
607 (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"),
608 $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
609 'surrogate', 0xDFFF,
610 (isASCII) ? 3 : 4,
611 qr/surrogate/
612 ],
613 [ "first non_unicode",
614 (isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"),
615 $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
616 'non_unicode', 0x110000,
617 (isASCII) ? 4 : 5,
618 qr/not Unicode.* may not be portable/
619 ],
620 [ "first of 32 consecutive non-character code points",
621 (isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"),
622 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
623 'nonchar', 0xFDD0,
624 (isASCII) ? 3 : 4,
625 qr/Unicode non-character.*is not recommended for open interchange/
626 ],
627 [ "a mid non-character code point of the 32 consecutive ones",
628 (isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"),
629 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
630 'nonchar', 0xFDE0,
631 (isASCII) ? 3 : 4,
632 qr/Unicode non-character.*is not recommended for open interchange/
633 ],
634 [ "final of 32 consecutive non-character code points",
635 (isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"),
636 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
637 'nonchar', 0xFDEF,
638 (isASCII) ? 3 : 4,
639 qr/Unicode non-character.*is not recommended for open interchange/
640 ],
641 [ "non-character code point U+FFFE",
642 (isASCII) ? "\xef\xbf\xbe" : I8_to_native("\xf1\xbf\xbf\xbe"),
643 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
644 'nonchar', 0xFFFE,
645 (isASCII) ? 3 : 4,
646 qr/Unicode non-character.*is not recommended for open interchange/
647 ],
648 [ "non-character code point U+FFFF",
649 (isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"),
650 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
651 'nonchar', 0xFFFF,
652 (isASCII) ? 3 : 4,
653 qr/Unicode non-character.*is not recommended for open interchange/
654 ],
655 [ "non-character code point U+1FFFE",
656 (isASCII) ? "\xf0\x9f\xbf\xbe" : I8_to_native("\xf3\xbf\xbf\xbe"),
657 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
658 'nonchar', 0x1FFFE, 4,
659 qr/Unicode non-character.*is not recommended for open interchange/
660 ],
661 [ "non-character code point U+1FFFF",
662 (isASCII) ? "\xf0\x9f\xbf\xbf" : I8_to_native("\xf3\xbf\xbf\xbf"),
663 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
664 'nonchar', 0x1FFFF, 4,
665 qr/Unicode non-character.*is not recommended for open interchange/
666 ],
667 [ "non-character code point U+2FFFE",
668 (isASCII) ? "\xf0\xaf\xbf\xbe" : I8_to_native("\xf5\xbf\xbf\xbe"),
669 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
670 'nonchar', 0x2FFFE, 4,
671 qr/Unicode non-character.*is not recommended for open interchange/
672 ],
673 [ "non-character code point U+2FFFF",
674 (isASCII) ? "\xf0\xaf\xbf\xbf" : I8_to_native("\xf5\xbf\xbf\xbf"),
675 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
676 'nonchar', 0x2FFFF, 4,
677 qr/Unicode non-character.*is not recommended for open interchange/
678 ],
679 [ "non-character code point U+3FFFE",
680 (isASCII) ? "\xf0\xbf\xbf\xbe" : I8_to_native("\xf7\xbf\xbf\xbe"),
681 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
682 'nonchar', 0x3FFFE, 4,
683 qr/Unicode non-character.*is not recommended for open interchange/
684 ],
685 [ "non-character code point U+3FFFF",
686 (isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"),
687 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
688 'nonchar', 0x3FFFF, 4,
689 qr/Unicode non-character.*is not recommended for open interchange/
690 ],
691 [ "non-character code point U+4FFFE",
692 (isASCII) ? "\xf1\x8f\xbf\xbe" : I8_to_native("\xf8\xa9\xbf\xbf\xbe"),
693 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
694 'nonchar', 0x4FFFE,
695 (isASCII) ? 4 : 5,
696 qr/Unicode non-character.*is not recommended for open interchange/
697 ],
698 [ "non-character code point U+4FFFF",
699 (isASCII) ? "\xf1\x8f\xbf\xbf" : I8_to_native("\xf8\xa9\xbf\xbf\xbf"),
700 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
701 'nonchar', 0x4FFFF,
702 (isASCII) ? 4 : 5,
703 qr/Unicode non-character.*is not recommended for open interchange/
704 ],
705 [ "non-character code point U+5FFFE",
706 (isASCII) ? "\xf1\x9f\xbf\xbe" : I8_to_native("\xf8\xab\xbf\xbf\xbe"),
707 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
708 'nonchar', 0x5FFFE,
709 (isASCII) ? 4 : 5,
710 qr/Unicode non-character.*is not recommended for open interchange/
711 ],
712 [ "non-character code point U+5FFFF",
713 (isASCII) ? "\xf1\x9f\xbf\xbf" : I8_to_native("\xf8\xab\xbf\xbf\xbf"),
714 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
715 'nonchar', 0x5FFFF,
716 (isASCII) ? 4 : 5,
717 qr/Unicode non-character.*is not recommended for open interchange/
718 ],
719 [ "non-character code point U+6FFFE",
720 (isASCII) ? "\xf1\xaf\xbf\xbe" : I8_to_native("\xf8\xad\xbf\xbf\xbe"),
721 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
722 'nonchar', 0x6FFFE,
723 (isASCII) ? 4 : 5,
724 qr/Unicode non-character.*is not recommended for open interchange/
725 ],
726 [ "non-character code point U+6FFFF",
727 (isASCII) ? "\xf1\xaf\xbf\xbf" : I8_to_native("\xf8\xad\xbf\xbf\xbf"),
728 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
729 'nonchar', 0x6FFFF,
730 (isASCII) ? 4 : 5,
731 qr/Unicode non-character.*is not recommended for open interchange/
732 ],
733 [ "non-character code point U+7FFFE",
734 (isASCII) ? "\xf1\xbf\xbf\xbe" : I8_to_native("\xf8\xaf\xbf\xbf\xbe"),
735 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
736 'nonchar', 0x7FFFE,
737 (isASCII) ? 4 : 5,
738 qr/Unicode non-character.*is not recommended for open interchange/
739 ],
740 [ "non-character code point U+7FFFF",
741 (isASCII) ? "\xf1\xbf\xbf\xbf" : I8_to_native("\xf8\xaf\xbf\xbf\xbf"),
742 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
743 'nonchar', 0x7FFFF,
744 (isASCII) ? 4 : 5,
745 qr/Unicode non-character.*is not recommended for open interchange/
746 ],
747 [ "non-character code point U+8FFFE",
748 (isASCII) ? "\xf2\x8f\xbf\xbe" : I8_to_native("\xf8\xb1\xbf\xbf\xbe"),
749 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
750 'nonchar', 0x8FFFE,
751 (isASCII) ? 4 : 5,
752 qr/Unicode non-character.*is not recommended for open interchange/
753 ],
754 [ "non-character code point U+8FFFF",
755 (isASCII) ? "\xf2\x8f\xbf\xbf" : I8_to_native("\xf8\xb1\xbf\xbf\xbf"),
756 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
757 'nonchar', 0x8FFFF,
758 (isASCII) ? 4 : 5,
759 qr/Unicode non-character.*is not recommended for open interchange/
760 ],
761 [ "non-character code point U+9FFFE",
762 (isASCII) ? "\xf2\x9f\xbf\xbe" : I8_to_native("\xf8\xb3\xbf\xbf\xbe"),
763 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
764 'nonchar', 0x9FFFE,
765 (isASCII) ? 4 : 5,
766 qr/Unicode non-character.*is not recommended for open interchange/
767 ],
768 [ "non-character code point U+9FFFF",
769 (isASCII) ? "\xf2\x9f\xbf\xbf" : I8_to_native("\xf8\xb3\xbf\xbf\xbf"),
770 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
771 'nonchar', 0x9FFFF,
772 (isASCII) ? 4 : 5,
773 qr/Unicode non-character.*is not recommended for open interchange/
774 ],
775 [ "non-character code point U+AFFFE",
776 (isASCII) ? "\xf2\xaf\xbf\xbe" : I8_to_native("\xf8\xb5\xbf\xbf\xbe"),
777 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
778 'nonchar', 0xAFFFE,
779 (isASCII) ? 4 : 5,
780 qr/Unicode non-character.*is not recommended for open interchange/
781 ],
782 [ "non-character code point U+AFFFF",
783 (isASCII) ? "\xf2\xaf\xbf\xbf" : I8_to_native("\xf8\xb5\xbf\xbf\xbf"),
784 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
785 'nonchar', 0xAFFFF,
786 (isASCII) ? 4 : 5,
787 qr/Unicode non-character.*is not recommended for open interchange/
788 ],
789 [ "non-character code point U+BFFFE",
790 (isASCII) ? "\xf2\xbf\xbf\xbe" : I8_to_native("\xf8\xb7\xbf\xbf\xbe"),
791 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
792 'nonchar', 0xBFFFE,
793 (isASCII) ? 4 : 5,
794 qr/Unicode non-character.*is not recommended for open interchange/
795 ],
796 [ "non-character code point U+BFFFF",
797 (isASCII) ? "\xf2\xbf\xbf\xbf" : I8_to_native("\xf8\xb7\xbf\xbf\xbf"),
798 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
799 'nonchar', 0xBFFFF,
800 (isASCII) ? 4 : 5,
801 qr/Unicode non-character.*is not recommended for open interchange/
802 ],
803 [ "non-character code point U+CFFFE",
804 (isASCII) ? "\xf3\x8f\xbf\xbe" : I8_to_native("\xf8\xb9\xbf\xbf\xbe"),
805 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
806 'nonchar', 0xCFFFE,
807 (isASCII) ? 4 : 5,
808 qr/Unicode non-character.*is not recommended for open interchange/
809 ],
810 [ "non-character code point U+CFFFF",
811 (isASCII) ? "\xf3\x8f\xbf\xbf" : I8_to_native("\xf8\xb9\xbf\xbf\xbf"),
812 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
813 'nonchar', 0xCFFFF,
814 (isASCII) ? 4 : 5,
815 qr/Unicode non-character.*is not recommended for open interchange/
816 ],
817 [ "non-character code point U+DFFFE",
818 (isASCII) ? "\xf3\x9f\xbf\xbe" : I8_to_native("\xf8\xbb\xbf\xbf\xbe"),
819 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
820 'nonchar', 0xDFFFE,
821 (isASCII) ? 4 : 5,
822 qr/Unicode non-character.*is not recommended for open interchange/
823 ],
824 [ "non-character code point U+DFFFF",
825 (isASCII) ? "\xf3\x9f\xbf\xbf" : I8_to_native("\xf8\xbb\xbf\xbf\xbf"),
826 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
827 'nonchar', 0xDFFFF,
828 (isASCII) ? 4 : 5,
829 qr/Unicode non-character.*is not recommended for open interchange/
830 ],
831 [ "non-character code point U+EFFFE",
832 (isASCII) ? "\xf3\xaf\xbf\xbe" : I8_to_native("\xf8\xbd\xbf\xbf\xbe"),
833 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
834 'nonchar', 0xEFFFE,
835 (isASCII) ? 4 : 5,
836 qr/Unicode non-character.*is not recommended for open interchange/
837 ],
838 [ "non-character code point U+EFFFF",
839 (isASCII) ? "\xf3\xaf\xbf\xbf" : I8_to_native("\xf8\xbd\xbf\xbf\xbf"),
840 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
841 'nonchar', 0xEFFFF,
842 (isASCII) ? 4 : 5,
843 qr/Unicode non-character.*is not recommended for open interchange/
844 ],
845 [ "non-character code point U+FFFFE",
846 (isASCII) ? "\xf3\xbf\xbf\xbe" : I8_to_native("\xf8\xbf\xbf\xbf\xbe"),
847 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
848 'nonchar', 0xFFFFE,
849 (isASCII) ? 4 : 5,
850 qr/Unicode non-character.*is not recommended for open interchange/
851 ],
852 [ "non-character code point U+FFFFF",
853 (isASCII) ? "\xf3\xbf\xbf\xbf" : I8_to_native("\xf8\xbf\xbf\xbf\xbf"),
854 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
855 'nonchar', 0xFFFFF,
856 (isASCII) ? 4 : 5,
857 qr/Unicode non-character.*is not recommended for open interchange/
858 ],
859 [ "non-character code point U+10FFFE",
860 (isASCII) ? "\xf4\x8f\xbf\xbe" : I8_to_native("\xf9\xa1\xbf\xbf\xbe"),
861 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
862 'nonchar', 0x10FFFE,
863 (isASCII) ? 4 : 5,
864 qr/Unicode non-character.*is not recommended for open interchange/
eb83ed87 865 ],
7dfd8446
KW
866 [ "non-character code point U+10FFFF",
867 (isASCII) ? "\xf4\x8f\xbf\xbf" : I8_to_native("\xf9\xa1\xbf\xbf\xbf"),
868 $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
869 'nonchar', 0x10FFFF,
870 (isASCII) ? 4 : 5,
ba707cdc 871 qr/Unicode non-character.*is not recommended for open interchange/
eb83ed87 872 ],
1d1c12d9 873 [ "requires at least 32 bits",
c0236afe
KW
874 (isASCII)
875 ? "\xfe\x82\x80\x80\x80\x80\x80"
876 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
eb83ed87 877 # This code point is chosen so that it is representable in a UV on
2f8f112e 878 # 32-bit machines
1d1c12d9 879 $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
c0236afe 880 'utf8', 0x80000000, (isASCII) ? 7 :14,
7dfd8446
KW
881 qr/Code point 0x80000000 is not Unicode, and not portable/
882 ],
1d1c12d9 883 [ "requires at least 32 bits, and use SUPER-type flags, instead of ABOVE_31_BIT",
c0236afe
KW
884 (isASCII)
885 ? "\xfe\x82\x80\x80\x80\x80\x80"
886 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
7dfd8446 887 $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
c0236afe 888 'utf8', 0x80000000, (isASCII) ? 7 :14,
ea5ced44 889 qr/Code point 0x80000000 is not Unicode, and not portable/
eb83ed87 890 ],
1d1c12d9
KW
891 [ "overflow with warnings/disallow for more than 31 bits",
892 # This tests the interaction of WARN_ABOVE_31_BIT/DISALLOW_ABOVE_31_BIT
893 # with overflow. The overflow malformation is never allowed, so
894 # preventing it takes precedence if the ABOVE_31_BIT options would
c0236afe 895 # otherwise allow in an overflowing value. The ASCII code points (1
1d1c12d9
KW
896 # for 32-bits; 1 for 64) were chosen because the old overflow
897 # detection algorithm did not catch them; this means this test also
c0236afe
KW
898 # checks for that fix. The EBCDIC are arbitrary overflowing ones
899 # since we have no reports of failures with it.
900 (($is64bit)
901 ? ((isASCII)
9d2d0ecd 902 ? "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
c0236afe
KW
903 : I8_to_native("\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"))
904 : ((isASCII)
9d2d0ecd 905 ? "\xfe\x86\x80\x80\x80\x80\x80"
c0236afe 906 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"))),
ea5ced44 907
1d1c12d9
KW
908 # We include both warning categories to make sure the ABOVE_31_BIT one
909 # has precedence
910 "$UTF8_WARN_ABOVE_31_BIT|$UTF8_WARN_SUPER",
911 "$UTF8_DISALLOW_ABOVE_31_BIT",
7dfd8446 912 'utf8', 0,
c0236afe 913 (! isASCII) ? 14 : ($is64bit) ? 13 : 7,
ea5ced44 914 qr/overflow at byte .*, after start byte 0xf/
eb83ed87 915 ],
c0236afe 916);
2f8f112e 917
c0236afe
KW
918if ($is64bit) {
919 no warnings qw{portable overflow};
2f8f112e 920 push @tests,
c0236afe
KW
921 [ "More than 32 bits",
922 (isASCII)
9d2d0ecd 923 ? "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
c0236afe 924 : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1d1c12d9 925 $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
c0236afe 926 'utf8', 0x1000000000, (isASCII) ? 13 : 14,
ea5ced44 927 qr/Code point 0x.* is not Unicode, and not portable/
2f8f112e 928 ];
83dc0f42
KW
929 if (! isASCII) {
930 push @tests, # These could falsely show wrongly in a naive implementation
931 [ "requires at least 32 bits",
932 I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
933 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
934 'utf8', 0x800000000, 14,
935 qr/Code point 0x800000000 is not Unicode, and not portable/
936 ],
937 [ "requires at least 32 bits",
938 I8_to_native("\xff\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
939 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
940 'utf8', 0x10000000000, 14,
941 qr/Code point 0x10000000000 is not Unicode, and not portable/
942 ],
943 [ "requires at least 32 bits",
944 I8_to_native("\xff\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
945 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
946 'utf8', 0x200000000000, 14,
947 qr/Code point 0x200000000000 is not Unicode, and not portable/
948 ],
949 [ "requires at least 32 bits",
950 I8_to_native("\xff\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
951 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
952 'utf8', 0x4000000000000, 14,
953 qr/Code point 0x4000000000000 is not Unicode, and not portable/
954 ],
955 [ "requires at least 32 bits",
956 I8_to_native("\xff\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
957 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
958 'utf8', 0x80000000000000, 14,
959 qr/Code point 0x80000000000000 is not Unicode, and not portable/
960 ],
961 [ "requires at least 32 bits",
962 I8_to_native("\xff\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
963 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
964 'utf8', 0x1000000000000000, 14,
965 qr/Code point 0x1000000000000000 is not Unicode, and not portable/
966 ];
967 }
2f8f112e
KW
968}
969
970foreach my $test (@tests) {
eb83ed87
KW
971 my ($testname, $bytes, $warn_flags, $disallow_flags, $category, $allowed_uv, $expected_len, $message ) = @$test;
972
973 my $length = length $bytes;
2f8f112e 974 my $will_overflow = $testname =~ /overflow/;
eb83ed87 975
d7874298
KW
976 {
977 use warnings;
978 undef @warnings;
979 my $ret = test_isUTF8_CHAR($bytes, $length);
980 if ($will_overflow) {
981 is($ret, 0, "isUTF8_CHAR() $testname: returns 0");
982 }
983 else {
984 is($ret, $length,
985 "isUTF8_CHAR() $testname: returns expected length: $length");
986 }
987 unless (is(scalar @warnings, 0,
988 "isUTF8_CHAR() $testname: generated no warnings"))
989 {
990 diag "The warnings were: " . join(", ", @warnings);
991 }
992 }
993
eb83ed87
KW
994 # This is more complicated than the malformations tested earlier, as there
995 # are several orthogonal variables involved. We test all the subclasses
996 # of utf8 warnings to verify they work with and without the utf8 class,
997 # and don't have effects on other sublass warnings
54f4afef 998 foreach my $warning ('utf8', 'surrogate', 'nonchar', 'non_unicode') {
eb83ed87
KW
999 foreach my $warn_flag (0, $warn_flags) {
1000 foreach my $disallow_flag (0, $disallow_flags) {
54f4afef 1001 foreach my $do_warning (0, 1) {
eb83ed87 1002
13d7a909
KW
1003 my $eval_warn = $do_warning
1004 ? "use warnings '$warning'"
1005 : $warning eq "utf8"
7dfd8446
KW
1006 ? "no warnings 'utf8'"
1007 : "use warnings 'utf8'; no warnings '$warning'";
2f8f112e 1008
13d7a909
KW
1009 # is effectively disallowed if will overflow, even if the
1010 # flag indicates it is allowed, fix up test name to
1011 # indicate this as well
1012 my $disallowed = $disallow_flag || $will_overflow;
2f8f112e 1013
046d01eb 1014 my $this_name = "utf8n_to_uvchr() $testname: " . (($disallow_flag)
13d7a909
KW
1015 ? 'disallowed'
1016 : ($disallowed)
1d1c12d9 1017 ? 'ABOVE_31_BIT allowed'
13d7a909
KW
1018 : 'allowed');
1019 $this_name .= ", $eval_warn";
1020 $this_name .= ", " . (($warn_flag)
1021 ? 'with warning flag'
1022 : 'no warning flag');
eb83ed87 1023
13d7a909
KW
1024 undef @warnings;
1025 my $ret_ref;
7dfd8446
KW
1026 my $display_bytes = display_bytes($bytes);
1027 my $call = "Call was: $eval_warn; \$ret_ref = test_utf8n_to_uvchr('$display_bytes', $length, $warn_flag|$disallow_flag)";
1028 my $eval_text = "$eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)";
13d7a909
KW
1029 eval "$eval_text";
1030 if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
7dfd8446 1031 diag "\$!='$!'; eval'd=\"$call\"";
13d7a909 1032 next;
54f4afef 1033 }
13d7a909 1034 if ($disallowed) {
7dfd8446
KW
1035 unless (is($ret_ref->[0], 0, "$this_name: Returns 0"))
1036 {
1037 diag $call;
1038 }
2f8f112e
KW
1039 }
1040 else {
7dfd8446 1041 unless (is($ret_ref->[0], $allowed_uv,
9d2d0ecd
KW
1042 "$this_name: Returns expected uv: "
1043 . sprintf("0x%04X", $allowed_uv)))
7dfd8446
KW
1044 {
1045 diag $call;
1046 }
1047 }
1048 unless (is($ret_ref->[1], $expected_len,
9d2d0ecd 1049 "$this_name: Returns expected length: $expected_len"))
7dfd8446
KW
1050 {
1051 diag $call;
13d7a909 1052 }
13d7a909
KW
1053
1054 if (! $do_warning
1055 && ($warning eq 'utf8' || $warning eq $category))
1056 {
1057 if (!is(scalar @warnings, 0,
1058 "$this_name: No warnings generated"))
1059 {
7dfd8446
KW
1060 diag $call;
1061 diag "The warnings were: " . join(", ", @warnings);
2f8f112e
KW
1062 }
1063 }
13d7a909
KW
1064 elsif ($will_overflow
1065 && ! $disallow_flag
1066 && $warning eq 'utf8')
1067 {
1068
1069 # Will get the overflow message instead of the expected
1070 # message under these circumstances, as they would
1071 # otherwise accept an overflowed value, which the code
1072 # should not allow, so falls back to overflow.
1073 if (is(scalar @warnings, 1,
1074 "$this_name: Got a single warning "))
1075 {
7dfd8446
KW
1076 unless (like($warnings[0], qr/overflow/,
1077 "$this_name: Got overflow warning"))
1078 {
1079 diag $call;
1080 }
13d7a909
KW
1081 }
1082 else {
7dfd8446 1083 diag $call;
13d7a909 1084 if (scalar @warnings) {
7dfd8446 1085 diag "The warnings were: "
13d7a909
KW
1086 . join(", ", @warnings);
1087 }
1088 }
eb83ed87 1089 }
13d7a909
KW
1090 elsif ($warn_flag
1091 && ($warning eq 'utf8' || $warning eq $category))
1092 {
1093 if (is(scalar @warnings, 1,
1094 "$this_name: Got a single warning "))
1095 {
7dfd8446
KW
1096 unless (like($warnings[0], $message,
1097 "$this_name: Got expected warning"))
1098 {
1099 diag $call;
1100 }
13d7a909
KW
1101 }
1102 else {
7dfd8446 1103 diag $call;
13d7a909 1104 if (scalar @warnings) {
7dfd8446 1105 diag "The warnings were: "
13d7a909
KW
1106 . join(", ", @warnings);
1107 }
eb83ed87
KW
1108 }
1109 }
eb83ed87 1110
13d7a909
KW
1111 # Check CHECK_ONLY results when the input is disallowed. Do
1112 # this when actually disallowed, not just when the
1113 # $disallow_flag is set
1114 if ($disallowed) {
1115 undef @warnings;
1116 $ret_ref = test_utf8n_to_uvchr($bytes, $length,
1117 $disallow_flag|$UTF8_CHECK_ONLY);
7dfd8446
KW
1118 unless (is($ret_ref->[0], 0, "$this_name, CHECK_ONLY: Returns 0")) {
1119 diag $call;
1120 }
1121 unless (is($ret_ref->[1], -1,
9d2d0ecd 1122 "$this_name: CHECK_ONLY: returns -1 for length"))
7dfd8446
KW
1123 {
1124 diag $call;
1125 }
13d7a909
KW
1126 if (! is(scalar @warnings, 0,
1127 "$this_name, CHECK_ONLY: no warnings generated"))
1128 {
7dfd8446
KW
1129 diag $call;
1130 diag "The warnings were: " . join(", ", @warnings);
13d7a909 1131 }
eb83ed87 1132 }
046d01eb
KW
1133
1134 # Now repeat some of the above, but for
1135 # uvchr_to_utf8_flags(). Since this comes from an
1136 # existing code point, it hasn't overflowed.
1137 next if $will_overflow;
1138
1139 # The warning and disallow flags passed in are for
1140 # utf8n_to_uvchr(). Convert them for
1141 # uvchr_to_utf8_flags().
1142 my $uvchr_warn_flag = 0;
1143 my $uvchr_disallow_flag = 0;
1144 if ($warn_flag) {
1145 if ($warn_flag == $UTF8_WARN_SURROGATE) {
1146 $uvchr_warn_flag = $UNICODE_WARN_SURROGATE
1147 }
1148 elsif ($warn_flag == $UTF8_WARN_NONCHAR) {
1149 $uvchr_warn_flag = $UNICODE_WARN_NONCHAR
1150 }
1151 elsif ($warn_flag == $UTF8_WARN_SUPER) {
1152 $uvchr_warn_flag = $UNICODE_WARN_SUPER
1153 }
1d1c12d9 1154 elsif ($warn_flag == $UTF8_WARN_ABOVE_31_BIT) {
046d01eb
KW
1155 $uvchr_warn_flag = $UNICODE_WARN_ABOVE_31_BIT;
1156 }
1157 else {
1158 fail(sprintf "Unexpected warn flag: %x",
1159 $warn_flag);
1160 next;
1161 }
1162 }
1163 if ($disallow_flag) {
1164 if ($disallow_flag == $UTF8_DISALLOW_SURROGATE) {
1165 $uvchr_disallow_flag = $UNICODE_DISALLOW_SURROGATE
1166 }
1167 elsif ($disallow_flag == $UTF8_DISALLOW_NONCHAR) {
1168 $uvchr_disallow_flag = $UNICODE_DISALLOW_NONCHAR
1169 }
1170 elsif ($disallow_flag == $UTF8_DISALLOW_SUPER) {
1171 $uvchr_disallow_flag = $UNICODE_DISALLOW_SUPER
1172 }
1d1c12d9 1173 elsif ($disallow_flag == $UTF8_DISALLOW_ABOVE_31_BIT) {
046d01eb
KW
1174 $uvchr_disallow_flag =
1175 $UNICODE_DISALLOW_ABOVE_31_BIT;
1176 }
1177 else {
1178 fail(sprintf "Unexpected disallow flag: %x",
1179 $disallow_flag);
1180 next;
1181 }
1182 }
1183
1184 $disallowed = $uvchr_disallow_flag;
1185
1186 $this_name = "uvchr_to_utf8_flags() $testname: "
1187 . (($uvchr_disallow_flag)
1188 ? 'disallowed'
1189 : ($disallowed)
1190 ? 'ABOVE_31_BIT allowed'
1191 : 'allowed');
1192 $this_name .= ", $eval_warn";
1193 $this_name .= ", " . (($uvchr_warn_flag)
1194 ? 'with warning flag'
1195 : 'no warning flag');
1196
1197 undef @warnings;
1198 my $ret;
1199 my $warn_flag = sprintf "0x%x", $uvchr_warn_flag;
1200 my $disallow_flag = sprintf "0x%x", $uvchr_disallow_flag;
1201 $call = sprintf "call was: $eval_warn; \$ret = test_uvchr_to_utf8_flags(0x%x, $warn_flag|$disallow_flag)", $allowed_uv;
1202 $eval_text = "$eval_warn; \$ret = test_uvchr_to_utf8_flags($allowed_uv, $warn_flag|$disallow_flag)";
1203 eval "$eval_text";
1204 if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
1205 diag "\$!='$!'; eval'd=\"$eval_text\"";
1206 next;
1207 }
1208 if ($disallowed) {
1209 unless (is($ret, undef, "$this_name: Returns undef")) {
1210 diag $call;
1211 }
1212 }
1213 else {
1214 unless (is($ret, $bytes, "$this_name: Returns expected string")) {
1215 diag $call;
1216 }
1217 }
1218 if (! $do_warning
1219 && ($warning eq 'utf8' || $warning eq $category))
1220 {
1221 if (!is(scalar @warnings, 0,
1222 "$this_name: No warnings generated"))
1223 {
1224 diag $call;
1225 diag "The warnings were: " . join(", ", @warnings);
1226 }
1227 }
1228 elsif ($uvchr_warn_flag
1229 && ($warning eq 'utf8' || $warning eq $category))
1230 {
1231 if (is(scalar @warnings, 1,
1232 "$this_name: Got a single warning "))
1233 {
046d01eb
KW
1234 unless (like($warnings[0], $message,
1235 "$this_name: Got expected warning"))
1236 {
1237 diag $call;
1238 }
046d01eb
KW
1239 }
1240 else {
1241 diag $call;
1242 if (scalar @warnings) {
1243 diag "The warnings were: "
1244 . join(", ", @warnings);
1245 }
1246 }
1247 }
eb83ed87
KW
1248 }
1249 }
1250 }
1251 }
1252}
6e3d6c02 1253
fed3ba5d 1254done_testing;