This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
a2ea0c4c45169bff58b3163c300d74debd50909f
[perl5.git] / ext / XS-APItest / t / utf8.t
1 #!perl -w
2
3 use strict;
4 use Test::More;
5 $|=1;
6
7 no warnings 'deprecated'; # Some of the below are above IV_MAX on 32 bit
8                           # machines, and that is tested elsewhere
9
10 use XS::APItest;
11
12 my $pound_sign = chr utf8::unicode_to_native(163);
13
14 sub isASCII { ord "A" == 65 }
15
16 sub display_bytes {
17     use bytes;
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
29 my @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
31 0x00,0x01,0x02,0x03,0x37,0x2D,0x2E,0x2F,0x16,0x05,0x15,0x0B,0x0C,0x0D,0x0E,0x0F,
32 0x10,0x11,0x12,0x13,0x3C,0x3D,0x32,0x26,0x18,0x19,0x3F,0x27,0x1C,0x1D,0x1E,0x1F,
33 0x40,0x5A,0x7F,0x7B,0x5B,0x6C,0x50,0x7D,0x4D,0x5D,0x5C,0x4E,0x6B,0x60,0x4B,0x61,
34 0xF0,0xF1,0xF2,0xF3,0xF4,0xF5,0xF6,0xF7,0xF8,0xF9,0x7A,0x5E,0x4C,0x7E,0x6E,0x6F,
35 0x7C,0xC1,0xC2,0xC3,0xC4,0xC5,0xC6,0xC7,0xC8,0xC9,0xD1,0xD2,0xD3,0xD4,0xD5,0xD6,
36 0xD7,0xD8,0xD9,0xE2,0xE3,0xE4,0xE5,0xE6,0xE7,0xE8,0xE9,0xAD,0xE0,0xBD,0x5F,0x6D,
37 0x79,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89,0x91,0x92,0x93,0x94,0x95,0x96,
38 0x97,0x98,0x99,0xA2,0xA3,0xA4,0xA5,0xA6,0xA7,0xA8,0xA9,0xC0,0x4F,0xD0,0xA1,0x07,
39 0x20,0x21,0x22,0x23,0x24,0x25,0x06,0x17,0x28,0x29,0x2A,0x2B,0x2C,0x09,0x0A,0x1B,
40 0x30,0x31,0x1A,0x33,0x34,0x35,0x36,0x08,0x38,0x39,0x3A,0x3B,0x04,0x14,0x3E,0xFF,
41 0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49,0x4A,0x51,0x52,0x53,0x54,0x55,0x56,
42 0x57,0x58,0x59,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69,0x6A,0x70,0x71,0x72,0x73,
43 0x74,0x75,0x76,0x77,0x78,0x80,0x8A,0x8B,0x8C,0x8D,0x8E,0x8F,0x90,0x9A,0x9B,0x9C,
44 0x9D,0x9E,0x9F,0xA0,0xAA,0xAB,0xAC,0xAE,0xAF,0xB0,0xB1,0xB2,0xB3,0xB4,0xB5,0xB6,
45 0xB7,0xB8,0xB9,0xBA,0xBB,0xBC,0xBE,0xBF,0xCA,0xCB,0xCC,0xCD,0xCE,0xCF,0xDA,0xDB,
46 0xDC,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
54 my $is64bit = length sprintf("%x", ~0) > 8;
55
56
57 # Test utf8n_to_uvchr().  These provide essentially complete code coverage.
58 # Copied from utf8.h
59 my $UTF8_ALLOW_EMPTY            = 0x0001;
60 my $UTF8_ALLOW_CONTINUATION     = 0x0002;
61 my $UTF8_ALLOW_NON_CONTINUATION = 0x0004;
62 my $UTF8_ALLOW_SHORT            = 0x0008;
63 my $UTF8_ALLOW_LONG             = 0x0010;
64 my $UTF8_DISALLOW_SURROGATE     = 0x0020;
65 my $UTF8_WARN_SURROGATE         = 0x0040;
66 my $UTF8_DISALLOW_NONCHAR       = 0x0080;
67 my $UTF8_WARN_NONCHAR           = 0x0100;
68 my $UTF8_DISALLOW_SUPER         = 0x0200;
69 my $UTF8_WARN_SUPER             = 0x0400;
70 my $UTF8_DISALLOW_ABOVE_31_BIT  = 0x0800;
71 my $UTF8_WARN_ABOVE_31_BIT      = 0x1000;
72 my $UTF8_CHECK_ONLY             = 0x2000;
73
74 # Test uvchr_to_utf8().
75 my $UNICODE_WARN_SURROGATE        = 0x0001;
76 my $UNICODE_WARN_NONCHAR          = 0x0002;
77 my $UNICODE_WARN_SUPER            = 0x0004;
78 my $UNICODE_WARN_ABOVE_31_BIT     = 0x0008;
79 my $UNICODE_DISALLOW_SURROGATE    = 0x0010;
80 my $UNICODE_DISALLOW_NONCHAR      = 0x0020;
81 my $UNICODE_DISALLOW_SUPER        = 0x0040;
82 my $UNICODE_DISALLOW_ABOVE_31_BIT = 0x0080;
83
84 my $look_for_everything_utf8n_to
85                         = $UTF8_DISALLOW_SURROGATE
86                         | $UTF8_WARN_SURROGATE
87                         | $UTF8_DISALLOW_NONCHAR
88                         | $UTF8_WARN_NONCHAR
89                         | $UTF8_DISALLOW_SUPER
90                         | $UTF8_WARN_SUPER
91                         | $UTF8_DISALLOW_ABOVE_31_BIT
92                         | $UTF8_WARN_ABOVE_31_BIT;
93 my $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;
102
103 foreach ([0, '', '', 'empty'],
104          [0, 'N', 'N', '1 char'],
105          [1, 'NN', 'N', '1 char substring'],
106          [-2, 'Perl', 'Rules', 'different'],
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'],
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
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.
128 my %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"),
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"),
215 );
216
217 if ($is64bit) {
218     no warnings qw(overflow portable);
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");
231 }
232
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
237 my $cp = 0;
238 while ($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
250 my $first_continuation = (isASCII) ? 0x80 : 0xA0;
251 my $final_continuation = 0xBF;
252 my $start = (isASCII) ? 0xC2 : 0xC5;
253
254 my $continuation = $first_continuation - 1;
255
256 while ($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 }
268
269 my @warnings;
270
271 use warnings 'utf8';
272 local $SIG{__WARN__} = sub { push @warnings, @_ };
273
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.
278 for 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 :
304                $u < 0x4000000   ? 6 :
305                $u < 0x40000000  ? 7 : 14 );
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.
387     my $this_utf8_flags = $look_for_everything_utf8n_to;
388     my $len = length $bytes;
389     if ($n > 2 ** 31 - 1) {
390         $this_utf8_flags &=
391                         ~($UTF8_DISALLOW_ABOVE_31_BIT|$UTF8_WARN_ABOVE_31_BIT);
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;
403     my $display_bytes = display_bytes($bytes);
404     my $ret_ref = test_utf8n_to_uvchr($bytes, $len, $this_utf8_flags);
405     is($ret_ref->[0], $n, "Verify utf8n_to_uvchr($display_bytes, $display_flags) returns $hex_n");
406     is($ret_ref->[1], $len, "Verify utf8n_to_uvchr() for $hex_n returns expected length: $len");
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     }
413
414     undef @warnings;
415
416     my $ret = test_isUTF8_CHAR($bytes, $len);
417     is($ret, $len, "Verify isUTF8_CHAR($display_bytes) returns expected length: $len");
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
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");
440     is($ret_ref->[1], $len, "Verify valid_utf8_to_uvchr() for $hex_n returns expected length: $len");
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
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
464     $ret = test_uvchr_to_utf8_flags($n, $this_uvchr_flags);
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     }
473 }
474
475 my $REPLACEMENT = 0xFFFD;
476
477 # Now test the malformations.  All these raise category utf8 warnings.
478 my $c = (isASCII) ? "\x80" : "\xa0";    # A continuation byte
479 my @malformations = (
480     [ "zero length string malformation", "", 0,
481         $UTF8_ALLOW_EMPTY, 0, 0,
482         qr/empty string/
483     ],
484     [ "orphan continuation byte malformation", I8_to_native("${c}a"),
485         2,
486         $UTF8_ALLOW_CONTINUATION, $REPLACEMENT, 1,
487         qr/unexpected continuation byte/
488     ],
489     [ "premature next character malformation (immediate)",
490         (isASCII) ? "\xc2\xc2\x80" : I8_to_native("\xc5\xc5\xa0"),
491         3,
492         $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 1,
493         qr/unexpected non-continuation byte.*immediately after start byte/
494     ],
495     [ "premature next character malformation (non-immediate)",
496         I8_to_native("\xf0${c}a"),
497         3,
498         $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 2,
499         qr/unexpected non-continuation byte .* 2 bytes after start byte/
500     ],
501     [ "too short malformation", I8_to_native("\xf0${c}a"), 2,
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     ],
507     [ "overlong malformation", I8_to_native("\xc0$c"), 2,
508         $UTF8_ALLOW_LONG,
509         0,   # NUL
510         2,
511         qr/2 bytes, need 1/
512     ],
513     [ "overflow malformation",
514                     # These are the smallest overflowing on 64 byte machines:
515                     # 2**64
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,
519         0,  # There is no way to allow this malformation
520         $REPLACEMENT,
521         (isASCII) ? 13 : 14,
522         qr/overflow/
523     ],
524 );
525
526 foreach my $test (@malformations) {
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
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
542     # Test what happens when this malformation is not allowed
543     undef @warnings;
544     my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
545     is($ret_ref->[0], 0, "$testname: disallowed: Returns 0");
546     is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), disallowed: Returns expected length: $expected_len");
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) {
552             diag "The warnings were: " . join(", ", @warnings);
553         }
554     }
555
556     {   # Next test when disallowed, and warnings are off.
557         undef @warnings;
558         no warnings 'utf8';
559         my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
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")) {
563             diag "The warnings were: " . join(", ", @warnings);
564         }
565     }
566
567     # Test with CHECK_ONLY
568     undef @warnings;
569     $ret_ref = test_utf8n_to_uvchr($bytes, $length, $UTF8_CHECK_ONLY);
570     is($ret_ref->[0], 0, "$testname: CHECK_ONLY: Returns 0");
571     is($ret_ref->[1], -1, "$testname: CHECK_ONLY: returns -1 for length");
572     if (! is(scalar @warnings, 0, "$testname: CHECK_ONLY: no warnings generated")) {
573         diag "The warnings were: " . join(", ", @warnings);
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;
580     $ret_ref = test_utf8n_to_uvchr($bytes, $length, $allow_flags);
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"))
584     {
585         diag "The warnings were: " . join(", ", @warnings);
586     }
587 }
588
589 # Now test the cases where a legal code point is generated, but may or may not
590 # be allowed/warned on.
591 my @tests = (
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,
604         qr/surrogate/
605     ],
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/
865     ],
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,
871         qr/Unicode non-character.*is not recommended for open interchange/
872     ],
873     [ "requires at least 32 bits",
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"),
877         # This code point is chosen so that it is representable in a UV on
878         # 32-bit machines
879         $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
880         'utf8', 0x80000000, (isASCII) ? 7 :14,
881         qr/Code point 0x80000000 is not Unicode, and not portable/
882     ],
883     [ "requires at least 32 bits, and use SUPER-type flags, instead of ABOVE_31_BIT",
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"),
887         $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
888         'utf8', 0x80000000, (isASCII) ? 7 :14,
889         qr/Code point 0x80000000 is not Unicode, and not portable/
890     ],
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
895         # otherwise allow in an overflowing value.  The ASCII code points (1
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
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)
902            ?              "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
903            : I8_to_native("\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"))
904         : ((isASCII)
905            ?              "\xfe\x86\x80\x80\x80\x80\x80"
906            : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"))),
907
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",
912         'utf8', 0,
913         (! isASCII) ? 14 : ($is64bit) ? 13 : 7,
914         qr/overflow at byte .*, after start byte 0xf/
915     ],
916 );
917
918 if ($is64bit) {
919     no warnings qw{portable overflow};
920     push @tests,
921         [ "More than 32 bits",
922             (isASCII)
923             ?              "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
924             : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
925             $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
926             'utf8', 0x1000000000, (isASCII) ? 13 : 14,
927             qr/Code point 0x.* is not Unicode, and not portable/
928         ];
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     }
968 }
969
970 foreach my $test (@tests) {
971     my ($testname, $bytes, $warn_flags, $disallow_flags, $category, $allowed_uv, $expected_len, $message ) = @$test;
972
973     my $length = length $bytes;
974     my $will_overflow = $testname =~ /overflow/;
975
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
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
998     foreach my $warning ('utf8', 'surrogate', 'nonchar', 'non_unicode') {
999         foreach my $warn_flag (0, $warn_flags) {
1000             foreach my $disallow_flag (0, $disallow_flags) {
1001                 foreach my $do_warning (0, 1) {
1002
1003                     my $eval_warn = $do_warning
1004                                   ? "use warnings '$warning'"
1005                                   : $warning eq "utf8"
1006                                     ? "no warnings 'utf8'"
1007                                     : "use warnings 'utf8'; no warnings '$warning'";
1008
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;
1013
1014                     my $this_name = "utf8n_to_uvchr() $testname: " . (($disallow_flag)
1015                                                     ? 'disallowed'
1016                                                     : ($disallowed)
1017                                                         ? 'ABOVE_31_BIT allowed'
1018                                                         : 'allowed');
1019                     $this_name .= ", $eval_warn";
1020                     $this_name .= ", " . (($warn_flag)
1021                                           ? 'with warning flag'
1022                                           : 'no warning flag');
1023
1024                     undef @warnings;
1025                     my $ret_ref;
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)";
1029                     eval "$eval_text";
1030                     if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
1031                         diag "\$!='$!'; eval'd=\"$call\"";
1032                         next;
1033                     }
1034                     if ($disallowed) {
1035                         unless (is($ret_ref->[0], 0, "$this_name: Returns 0"))
1036                         {
1037                             diag $call;
1038                         }
1039                     }
1040                     else {
1041                         unless (is($ret_ref->[0], $allowed_uv,
1042                                    "$this_name: Returns expected uv: "
1043                                  . sprintf("0x%04X", $allowed_uv)))
1044                         {
1045                             diag $call;
1046                         }
1047                     }
1048                     unless (is($ret_ref->[1], $expected_len,
1049                         "$this_name: Returns expected length: $expected_len"))
1050                     {
1051                         diag $call;
1052                     }
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                         {
1060                             diag $call;
1061                             diag "The warnings were: " . join(", ", @warnings);
1062                         }
1063                     }
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                         {
1076                             unless (like($warnings[0], qr/overflow/,
1077                                         "$this_name: Got overflow warning"))
1078                             {
1079                                 diag $call;
1080                             }
1081                         }
1082                         else {
1083                             diag $call;
1084                             if (scalar @warnings) {
1085                                 diag "The warnings were: "
1086                                                         . join(", ", @warnings);
1087                             }
1088                         }
1089                     }
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                         {
1096                             unless (like($warnings[0], $message,
1097                                         "$this_name: Got expected warning"))
1098                             {
1099                                 diag $call;
1100                             }
1101                         }
1102                         else {
1103                             diag $call;
1104                             if (scalar @warnings) {
1105                                 diag "The warnings were: "
1106                                                         . join(", ", @warnings);
1107                             }
1108                         }
1109                     }
1110
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);
1118                         unless (is($ret_ref->[0], 0, "$this_name, CHECK_ONLY: Returns 0")) {
1119                             diag $call;
1120                         }
1121                         unless (is($ret_ref->[1], -1,
1122                             "$this_name: CHECK_ONLY: returns -1 for length"))
1123                         {
1124                             diag $call;
1125                         }
1126                         if (! is(scalar @warnings, 0,
1127                             "$this_name, CHECK_ONLY: no warnings generated"))
1128                         {
1129                             diag $call;
1130                             diag "The warnings were: " . join(", ", @warnings);
1131                         }
1132                     }
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                         }
1154                         elsif ($warn_flag == $UTF8_WARN_ABOVE_31_BIT) {
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                         }
1173                         elsif ($disallow_flag == $UTF8_DISALLOW_ABOVE_31_BIT) {
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                         {
1234                             unless (like($warnings[0], $message,
1235                                             "$this_name: Got expected warning"))
1236                             {
1237                                 diag $call;
1238                             }
1239                         }
1240                         else {
1241                             diag $call;
1242                             if (scalar @warnings) {
1243                                 diag "The warnings were: "
1244                                                         . join(", ", @warnings);
1245                             }
1246                         }
1247                     }
1248                 }
1249             }
1250         }
1251     }
1252 }
1253
1254 done_testing;