This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
APItest/t/utf8.t: Add tests
[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     if (isASCII) {  # These could falsely show as overlongs in a naive implementation
232         $code_points{0x40000000000}  = "\xff\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80";
233         $code_points{0x1000000000000} = "\xff\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80";
234         $code_points{0x40000000000000} = "\xff\x80\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80";
235         $code_points{0x1000000000000000} = "\xff\x80\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80";
236         # overflows
237         #$code_points{0xfoo}     = "\xff\x81\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80";
238     }
239 }
240 elsif (! isASCII) { # 32-bit EBCDIC.  64-bit is clearer to handle, so doesn't need this test case
241     no warnings qw(overflow portable);
242     $code_points{0x40000000} = I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0");
243 }
244
245 # Now add in entries for each of code points 0-255, which require special
246 # handling on EBCDIC.  Remember the keys are Unicode values, and the values
247 # are the native UTF-8.  For invariants, the bytes are just the native chr.
248
249 my $cp = 0;
250 while ($cp < ((isASCII) ? 128 : 160)) {   # This is from the definition of
251                                         # invariant
252     $code_points{$cp} = chr utf8::unicode_to_native($cp);
253     $cp++;
254 }
255
256 # Done with the invariants.  Now do the variants.  All in this range are 2
257 # byte.  Again, we can't use the internal functions to generate UTF-8, as
258 # those are what we are trying to test.  In the loop, we know what range the
259 # continuation bytes can be in, and what the lowest start byte can be.  So we
260 # cycle through them.
261
262 my $first_continuation = (isASCII) ? 0x80 : 0xA0;
263 my $final_continuation = 0xBF;
264 my $start = (isASCII) ? 0xC2 : 0xC5;
265
266 my $continuation = $first_continuation - 1;
267
268 while ($cp < 255) {
269     if (++$continuation > $final_continuation) {
270
271         # Wrap to the next start byte when we reach the final continuation
272         # byte possible
273         $continuation = $first_continuation;
274         $start++;
275     }
276     $code_points{$cp} = I8_to_native(chr($start) . chr($continuation));
277
278     $cp++;
279 }
280
281 my @warnings;
282
283 use warnings 'utf8';
284 local $SIG{__WARN__} = sub { push @warnings, @_ };
285
286 # This set of tests looks for basic sanity, and lastly tests the bottom level
287 # decode routine for the given code point.  If the earlier tests for that code
288 # point fail, that one probably will too.  Malformations are tested in later
289 # segments of code.
290 for my $u (sort { utf8::unicode_to_native($a) <=> utf8::unicode_to_native($b) }
291           keys %code_points)
292 {
293     my $hex_u = sprintf("0x%02X", $u);
294     my $n = utf8::unicode_to_native($u);
295     my $hex_n = sprintf("0x%02X", $n);
296     my $bytes = $code_points{$u};
297
298     my $offskip_should_be;
299     {
300         no warnings qw(overflow portable);
301         $offskip_should_be = (isASCII)
302             ? ( $u < 0x80           ? 1 :
303                 $u < 0x800          ? 2 :
304                 $u < 0x10000        ? 3 :
305                 $u < 0x200000       ? 4 :
306                 $u < 0x4000000      ? 5 :
307                 $u < 0x80000000     ? 6 : (($is64bit)
308                                         ? ($u < 0x1000000000 ? 7 : 13)
309                                         : 7)
310               )
311             : ($u < 0xA0        ? 1 :
312                $u < 0x400       ? 2 :
313                $u < 0x4000      ? 3 :
314                $u < 0x40000     ? 4 :
315                $u < 0x400000    ? 5 :
316                $u < 0x4000000   ? 6 :
317                $u < 0x40000000  ? 7 : 14 );
318     }
319
320     # If this test fails, subsequent ones are meaningless.
321     next unless is(test_OFFUNISKIP($u), $offskip_should_be,
322                    "Verify OFFUNISKIP($hex_u) is $offskip_should_be");
323     my $invariant = $offskip_should_be == 1;
324     my $display_invariant = $invariant || 0;
325     is(test_OFFUNI_IS_INVARIANT($u), $invariant,
326        "Verify OFFUNI_IS_INVARIANT($hex_u) is $display_invariant");
327
328     my $uvchr_skip_should_be = $offskip_should_be;
329     next unless is(test_UVCHR_SKIP($n), $uvchr_skip_should_be,
330                    "Verify UVCHR_SKIP($hex_n) is $uvchr_skip_should_be");
331     is(test_UVCHR_IS_INVARIANT($n), $offskip_should_be == 1,
332        "Verify UVCHR_IS_INVARIANT($hex_n) is $display_invariant");
333
334     my $n_chr = chr $n;
335     utf8::upgrade $n_chr;
336
337     is(test_UTF8_SKIP($n_chr), $uvchr_skip_should_be,
338         "Verify UTF8_SKIP(chr $hex_n) is $uvchr_skip_should_be");
339
340     use bytes;
341     for (my $j = 0; $j < length $n_chr; $j++) {
342         my $b = substr($n_chr, $j, 1);
343         my $hex_b = sprintf("\"\\x%02x\"", ord $b);
344
345         my $byte_invariant = $j == 0 && $uvchr_skip_should_be == 1;
346         my $display_byte_invariant = $byte_invariant || 0;
347         next unless is(test_UTF8_IS_INVARIANT($b), $byte_invariant,
348                        "   Verify UTF8_IS_INVARIANT($hex_b) for byte $j "
349                      . "is $display_byte_invariant");
350
351         my $is_start = $j == 0 && $uvchr_skip_should_be > 1;
352         my $display_is_start = $is_start || 0;
353         next unless is(test_UTF8_IS_START($b), $is_start,
354                     "      Verify UTF8_IS_START($hex_b) is $display_is_start");
355
356         my $is_continuation = $j != 0 && $uvchr_skip_should_be > 1;
357         my $display_is_continuation = $is_continuation || 0;
358         next unless is(test_UTF8_IS_CONTINUATION($b), $is_continuation,
359                        "      Verify UTF8_IS_CONTINUATION($hex_b) is "
360                      . "$display_is_continuation");
361
362         my $is_continued = $uvchr_skip_should_be > 1;
363         my $display_is_continued = $is_continued || 0;
364         next unless is(test_UTF8_IS_CONTINUED($b), $is_continued,
365                        "      Verify UTF8_IS_CONTINUED($hex_b) is "
366                      . "$display_is_continued");
367
368         my $is_downgradeable_start =    $n < 256
369                                      && $uvchr_skip_should_be > 1
370                                      && $j == 0;
371         my $display_is_downgradeable_start = $is_downgradeable_start || 0;
372         next unless is(test_UTF8_IS_DOWNGRADEABLE_START($b),
373                        $is_downgradeable_start,
374                        "      Verify UTF8_IS_DOWNGRADEABLE_START($hex_b) is "
375                      . "$display_is_downgradeable_start");
376
377         my $is_above_latin1 =  $n > 255 && $j == 0;
378         my $display_is_above_latin1 = $is_above_latin1 || 0;
379         next unless is(test_UTF8_IS_ABOVE_LATIN1($b),
380                        $is_above_latin1,
381                        "      Verify UTF8_IS_ABOVE_LATIN1($hex_b) is "
382                      . "$display_is_above_latin1");
383
384         my $is_possibly_problematic =  $j == 0
385                                     && $n >= ((isASCII)
386                                               ? 0xD000
387                                               : 0x8000);
388         my $display_is_possibly_problematic = $is_possibly_problematic || 0;
389         next unless is(test_isUTF8_POSSIBLY_PROBLEMATIC($b),
390                        $is_possibly_problematic,
391                        "      Verify isUTF8_POSSIBLY_PROBLEMATIC($hex_b) is "
392                      . "$display_is_above_latin1");
393     }
394
395     # We are not trying to look for warnings, etc, so if they should occur, it
396     # is an error.  But some of the code points here do cause warnings, so we
397     # check here and turn off the ones that apply to such code points.  A
398     # later section of the code tests for these kinds of things.
399     my $this_utf8_flags = $look_for_everything_utf8n_to;
400     my $len = length $bytes;
401     if ($n > 2 ** 31 - 1) {
402         $this_utf8_flags &=
403                         ~($UTF8_DISALLOW_ABOVE_31_BIT|$UTF8_WARN_ABOVE_31_BIT);
404     }
405     if ($n > 0x10FFFF) {
406         $this_utf8_flags &= ~($UTF8_DISALLOW_SUPER|$UTF8_WARN_SUPER);
407     }
408     elsif (($n & 0xFFFE) == 0xFFFE) {
409         $this_utf8_flags &= ~($UTF8_DISALLOW_NONCHAR|$UTF8_WARN_NONCHAR);
410     }
411
412     undef @warnings;
413
414     my $display_flags = sprintf "0x%x", $this_utf8_flags;
415     my $display_bytes = display_bytes($bytes);
416     my $ret_ref = test_utf8n_to_uvchr($bytes, $len, $this_utf8_flags);
417     is($ret_ref->[0], $n, "Verify utf8n_to_uvchr($display_bytes, $display_flags) returns $hex_n");
418     is($ret_ref->[1], $len, "Verify utf8n_to_uvchr() for $hex_n returns expected length: $len");
419
420     unless (is(scalar @warnings, 0,
421                "Verify utf8n_to_uvchr() for $hex_n generated no warnings"))
422     {
423         diag "The warnings were: " . join(", ", @warnings);
424     }
425
426     undef @warnings;
427
428     my $ret = test_isUTF8_CHAR($bytes, $len);
429     is($ret, $len, "Verify isUTF8_CHAR($display_bytes) returns expected length: $len");
430
431     unless (is(scalar @warnings, 0,
432                "Verify isUTF8_CHAR() for $hex_n generated no warnings"))
433     {
434         diag "The warnings were: " . join(", ", @warnings);
435     }
436
437     undef @warnings;
438
439     $ret = test_isUTF8_CHAR($bytes, $len - 1);
440     is($ret, 0, "Verify isUTF8_CHAR() with too short length parameter returns 0");
441
442     unless (is(scalar @warnings, 0,
443                "Verify isUTF8_CHAR() generated no warnings"))
444     {
445         diag "The warnings were: " . join(", ", @warnings);
446     }
447
448     undef @warnings;
449
450     $ret_ref = test_valid_utf8_to_uvchr($bytes);
451     is($ret_ref->[0], $n, "Verify valid_utf8_to_uvchr($display_bytes) returns $hex_n");
452     is($ret_ref->[1], $len, "Verify valid_utf8_to_uvchr() for $hex_n returns expected length: $len");
453
454     unless (is(scalar @warnings, 0,
455                "Verify valid_utf8_to_uvchr() for $hex_n generated no warnings"))
456     {
457         diag "The warnings were: " . join(", ", @warnings);
458     }
459
460     # Similarly for uvchr_to_utf8
461     my $this_uvchr_flags = $look_for_everything_uvchr_to;
462     if ($n > 2 ** 31 - 1) {
463         $this_uvchr_flags &=
464                 ~($UNICODE_DISALLOW_ABOVE_31_BIT|$UNICODE_WARN_ABOVE_31_BIT);
465     }
466     if ($n > 0x10FFFF) {
467         $this_uvchr_flags &= ~($UNICODE_DISALLOW_SUPER|$UNICODE_WARN_SUPER);
468     }
469     elsif (($n & 0xFFFE) == 0xFFFE) {
470         $this_uvchr_flags &= ~($UNICODE_DISALLOW_NONCHAR|$UNICODE_WARN_NONCHAR);
471     }
472     $display_flags = sprintf "0x%x", $this_uvchr_flags;
473
474     undef @warnings;
475
476     $ret = test_uvchr_to_utf8_flags($n, $this_uvchr_flags);
477     ok(defined $ret, "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returned success");
478     is($ret, $bytes, "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returns correct bytes");
479
480     unless (is(scalar @warnings, 0,
481         "Verify uvchr_to_utf8_flags($hex_n, $display_flags) for $hex_n generated no warnings"))
482     {
483         diag "The warnings were: " . join(", ", @warnings);
484     }
485 }
486
487 my $REPLACEMENT = 0xFFFD;
488
489 # Now test the malformations.  All these raise category utf8 warnings.
490 my $c = (isASCII) ? "\x80" : "\xa0";    # A continuation byte
491 my @malformations = (
492     [ "zero length string malformation", "", 0,
493         $UTF8_ALLOW_EMPTY, 0, 0,
494         qr/empty string/
495     ],
496     [ "orphan continuation byte malformation", I8_to_native("${c}a"),
497         2,
498         $UTF8_ALLOW_CONTINUATION, $REPLACEMENT, 1,
499         qr/unexpected continuation byte/
500     ],
501     [ "premature next character malformation (immediate)",
502         (isASCII) ? "\xc2\xc2\x80" : I8_to_native("\xc5\xc5\xa0"),
503         3,
504         $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 1,
505         qr/unexpected non-continuation byte.*immediately after start byte/
506     ],
507     [ "premature next character malformation (non-immediate)",
508         I8_to_native("\xf0${c}a"),
509         3,
510         $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 2,
511         qr/unexpected non-continuation byte .* 2 bytes after start byte/
512     ],
513     [ "too short malformation", I8_to_native("\xf0${c}a"), 2,
514         # Having the 'a' after this, but saying there are only 2 bytes also
515         # tests that we pay attention to the passed in length
516         $UTF8_ALLOW_SHORT, $REPLACEMENT, 2,
517         qr/2 bytes, need 4/
518     ],
519     [ "overlong malformation, lowest 2-byte",
520         (isASCII) ? "\xc0\x80" : I8_to_native("\xc0\xa0"),
521         2,
522         $UTF8_ALLOW_LONG,
523         0,   # NUL
524         2,
525         qr/2 bytes, need 1/
526     ],
527     [ "overlong malformation, highest 2-byte",
528         (isASCII) ? "\xc1\xbf" : I8_to_native("\xc4\xbf"),
529         2,
530         $UTF8_ALLOW_LONG,
531         (isASCII) ? 0x7F : utf8::unicode_to_native(0xBF),
532         2,
533         qr/2 bytes, need 1/
534     ],
535     [ "overlong malformation, lowest 3-byte",
536         (isASCII) ? "\xe0\x80\x80" : I8_to_native("\xe0\xa0\xa0"),
537         3,
538         $UTF8_ALLOW_LONG,
539         0,   # NUL
540         3,
541         qr/3 bytes, need 1/
542     ],
543     [ "overlong malformation, highest 3-byte",
544         (isASCII) ? "\xe0\x9f\xbf" : I8_to_native("\xe0\xbf\xbf"),
545         3,
546         $UTF8_ALLOW_LONG,
547         (isASCII) ? 0x7FF : 0x3FF,
548         3,
549         qr/3 bytes, need 2/
550     ],
551     [ "overlong malformation, lowest 4-byte",
552         (isASCII) ? "\xf0\x80\x80\x80" : I8_to_native("\xf0\xa0\xa0\xa0"),
553         4,
554         $UTF8_ALLOW_LONG,
555         0,   # NUL
556         4,
557         qr/4 bytes, need 1/
558     ],
559     [ "overlong malformation, highest 4-byte",
560         (isASCII) ? "\xf0\x8F\xbf\xbf" : I8_to_native("\xf0\xaf\xbf\xbf"),
561         4,
562         $UTF8_ALLOW_LONG,
563         (isASCII) ? 0xFFFF : 0x3FFF,
564         4,
565         qr/4 bytes, need 3/
566     ],
567     [ "overlong malformation, lowest 5-byte",
568         (isASCII)
569          ?              "\xf8\x80\x80\x80\x80"
570          : I8_to_native("\xf8\xa0\xa0\xa0\xa0"),
571         5,
572         $UTF8_ALLOW_LONG,
573         0,   # NUL
574         5,
575         qr/5 bytes, need 1/
576     ],
577     [ "overlong malformation, highest 5-byte",
578         (isASCII)
579          ?              "\xf8\x87\xbf\xbf\xbf"
580          : I8_to_native("\xf8\xa7\xbf\xbf\xbf"),
581         5,
582         $UTF8_ALLOW_LONG,
583         (isASCII) ? 0x1FFFFF : 0x3FFFF,
584         5,
585         qr/5 bytes, need 4/
586     ],
587     [ "overlong malformation, lowest 6-byte",
588         (isASCII)
589          ?              "\xfc\x80\x80\x80\x80\x80"
590          : I8_to_native("\xfc\xa0\xa0\xa0\xa0\xa0"),
591         6,
592         $UTF8_ALLOW_LONG,
593         0,   # NUL
594         6,
595         qr/6 bytes, need 1/
596     ],
597     [ "overlong malformation, highest 6-byte",
598         (isASCII)
599          ?              "\xfc\x83\xbf\xbf\xbf\xbf"
600          : I8_to_native("\xfc\xa3\xbf\xbf\xbf\xbf"),
601         6,
602         $UTF8_ALLOW_LONG,
603         (isASCII) ? 0x3FFFFFF : 0x3FFFFF,
604         6,
605         qr/6 bytes, need 5/
606     ],
607     [ "overlong malformation, lowest 7-byte",
608         (isASCII)
609          ?              "\xfe\x80\x80\x80\x80\x80\x80"
610          : I8_to_native("\xfe\xa0\xa0\xa0\xa0\xa0\xa0"),
611         7,
612         $UTF8_ALLOW_LONG,
613         0,   # NUL
614         7,
615         qr/7 bytes, need 1/
616     ],
617     [ "overlong malformation, highest 7-byte",
618         (isASCII)
619          ?              "\xfe\x81\xbf\xbf\xbf\xbf\xbf"
620          : I8_to_native("\xfe\xa1\xbf\xbf\xbf\xbf\xbf"),
621         7,
622         $UTF8_ALLOW_LONG,
623         (isASCII) ? 0x7FFFFFFF : 0x3FFFFFF,
624         7,
625         qr/7 bytes, need 6/
626     ],
627 );
628
629 if (isASCII && ! $is64bit) {    # 32-bit ASCII platform
630     no warnings 'portable';
631     push @malformations,
632         [ "overflow malformation",
633             "\xfe\x84\x80\x80\x80\x80\x80",  # Represents 2**32
634             7,
635             0,  # There is no way to allow this malformation
636             $REPLACEMENT,
637             7,
638             qr/overflow/
639         ],
640         [ "overflow malformation, can tell on first byte",
641             "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
642             13,
643             0,  # There is no way to allow this malformation
644             $REPLACEMENT,
645             13,
646             qr/overflow/
647         ];
648 }
649 else {
650     # On EBCDIC platforms, another overlong test is needed even on 32-bit
651     # systems, whereas it doesn't happen on ASCII except on 64-bit ones.
652
653     no warnings 'portable';
654     no warnings 'overflow'; # Doesn't run on 32-bit systems, but compiles
655     push @malformations,
656         [ "overlong malformation, lowest max-byte",
657             (isASCII)
658              ?              "\xff\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80"
659              : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
660             (isASCII) ? 13 : 14,
661             $UTF8_ALLOW_LONG,
662             0,   # NUL
663             (isASCII) ? 13 : 14,
664             qr/1[34] bytes, need 1/,    # 1[34] to work on either ASCII or EBCDIC
665         ],
666         [ "overlong malformation, highest max-byte",
667             (isASCII)    # 2**36-1 on ASCII; 2**30-1 on EBCDIC
668              ?              "\xff\x80\x80\x80\x80\x80\x80\xbf\xbf\xbf\xbf\xbf\xbf"
669              : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xbf\xbf\xbf\xbf\xbf\xbf"),
670             (isASCII) ? 13 : 14,
671             $UTF8_ALLOW_LONG,
672             (isASCII) ? 0xFFFFFFFFF : 0x3FFFFFFF,
673             (isASCII) ? 13 : 14,
674             qr/1[34] bytes, need 7/,
675         ];
676
677     if (! $is64bit) {   # 32-bit EBCDIC
678         push @malformations,
679         [ "overflow malformation",
680             I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"),
681             14,
682             0,  # There is no way to allow this malformation
683             $REPLACEMENT,
684             14,
685             qr/overflow/
686         ];
687     }
688     else {  # 64-bit
689         push @malformations,
690             [ "overflow malformation",
691                (isASCII)
692                 ?              "\xff\x80\x90\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"
693                 : I8_to_native("\xff\xb0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
694                 (isASCII) ? 13 : 14,
695                 0,  # There is no way to allow this malformation
696                 $REPLACEMENT,
697                 (isASCII) ? 13 : 14,
698                 qr/overflow/
699             ];
700     }
701 }
702
703 foreach my $test (@malformations) {
704     my ($testname, $bytes, $length, $allow_flags, $allowed_uv, $expected_len, $message ) = @$test;
705
706     next if ! ok(length($bytes) >= $length, "$testname: Make sure won't read beyond buffer: " . length($bytes) . " >= $length");
707
708     undef @warnings;
709
710     my $ret = test_isUTF8_CHAR($bytes, $length);
711     is($ret, 0, "$testname: isUTF8_CHAR returns 0");
712     unless (is(scalar @warnings, 0,
713                "$testname: isUTF8_CHAR() generated no warnings"))
714     {
715         diag "The warnings were: " . join(", ", @warnings);
716     }
717
718
719     # Test what happens when this malformation is not allowed
720     undef @warnings;
721     my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
722     is($ret_ref->[0], 0, "$testname: disallowed: Returns 0");
723     is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), disallowed: Returns expected length: $expected_len");
724     if (is(scalar @warnings, 1, "$testname: disallowed: Got a single warning ")) {
725         like($warnings[0], $message, "$testname: disallowed: Got expected warning");
726     }
727     else {
728         if (scalar @warnings) {
729             diag "The warnings were: " . join(", ", @warnings);
730         }
731     }
732
733     {   # Next test when disallowed, and warnings are off.
734         undef @warnings;
735         no warnings 'utf8';
736         my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
737         is($ret_ref->[0], 0, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': Returns 0");
738         is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': Returns expected length: $expected_len");
739         if (!is(scalar @warnings, 0, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': no warnings generated")) {
740             diag "The warnings were: " . join(", ", @warnings);
741         }
742     }
743
744     # Test with CHECK_ONLY
745     undef @warnings;
746     $ret_ref = test_utf8n_to_uvchr($bytes, $length, $UTF8_CHECK_ONLY);
747     is($ret_ref->[0], 0, "$testname: CHECK_ONLY: Returns 0");
748     is($ret_ref->[1], -1, "$testname: CHECK_ONLY: returns -1 for length");
749     if (! is(scalar @warnings, 0, "$testname: CHECK_ONLY: no warnings generated")) {
750         diag "The warnings were: " . join(", ", @warnings);
751     }
752
753     next if $allow_flags == 0;    # Skip if can't allow this malformation
754
755     # Test when the malformation is allowed
756     undef @warnings;
757     $ret_ref = test_utf8n_to_uvchr($bytes, $length, $allow_flags);
758     is($ret_ref->[0], $allowed_uv, "$testname: utf8n_to_uvchr(), allowed: Returns expected uv: " . sprintf("0x%04X", $allowed_uv));
759     is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), allowed: Returns expected length: $expected_len");
760     if (!is(scalar @warnings, 0, "$testname: utf8n_to_uvchr(), allowed: no warnings generated"))
761     {
762         diag "The warnings were: " . join(", ", @warnings);
763     }
764 }
765
766 # Now test the cases where a legal code point is generated, but may or may not
767 # be allowed/warned on.
768 my @tests = (
769     [ "lowest surrogate",
770         (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"),
771         $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
772         'surrogate', 0xD800,
773         (isASCII) ? 3 : 4,
774         qr/surrogate/
775     ],
776     [ "a middle surrogate",
777         (isASCII) ? "\xed\xa4\x8d" : I8_to_native("\xf1\xb6\xa8\xad"),
778         $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
779         'surrogate', 0xD90D,
780         (isASCII) ? 3 : 4,
781         qr/surrogate/
782     ],
783     [ "highest surrogate",
784         (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"),
785         $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
786         'surrogate', 0xDFFF,
787         (isASCII) ? 3 : 4,
788         qr/surrogate/
789     ],
790     [ "first non_unicode",
791         (isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"),
792         $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
793         'non_unicode', 0x110000,
794         (isASCII) ? 4 : 5,
795         qr/not Unicode.* may not be portable/
796     ],
797     [ "non_unicode whose first byte tells that",
798         (isASCII) ? "\xf5\x80\x80\x80" : I8_to_native("\xfa\xa0\xa0\xa0\xa0"),
799         $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
800         'non_unicode',
801         (isASCII) ? 0x140000 : 0x200000,
802         (isASCII) ? 4 : 5,
803         qr/not Unicode.* may not be portable/
804     ],
805     [ "first of 32 consecutive non-character code points",
806         (isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"),
807         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
808         'nonchar', 0xFDD0,
809         (isASCII) ? 3 : 4,
810         qr/Unicode non-character.*is not recommended for open interchange/
811     ],
812     [ "a mid non-character code point of the 32 consecutive ones",
813         (isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"),
814         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
815         'nonchar', 0xFDE0,
816         (isASCII) ? 3 : 4,
817         qr/Unicode non-character.*is not recommended for open interchange/
818     ],
819     [ "final of 32 consecutive non-character code points",
820         (isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"),
821         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
822         'nonchar', 0xFDEF,
823         (isASCII) ? 3 : 4,
824         qr/Unicode non-character.*is not recommended for open interchange/
825     ],
826     [ "non-character code point U+FFFE",
827         (isASCII) ? "\xef\xbf\xbe" : I8_to_native("\xf1\xbf\xbf\xbe"),
828         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
829         'nonchar', 0xFFFE,
830         (isASCII) ? 3 : 4,
831         qr/Unicode non-character.*is not recommended for open interchange/
832     ],
833     [ "non-character code point U+FFFF",
834         (isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"),
835         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
836         'nonchar', 0xFFFF,
837         (isASCII) ? 3 : 4,
838         qr/Unicode non-character.*is not recommended for open interchange/
839     ],
840     [ "non-character code point U+1FFFE",
841         (isASCII) ? "\xf0\x9f\xbf\xbe" : I8_to_native("\xf3\xbf\xbf\xbe"),
842         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
843         'nonchar', 0x1FFFE, 4,
844         qr/Unicode non-character.*is not recommended for open interchange/
845     ],
846     [ "non-character code point U+1FFFF",
847         (isASCII) ? "\xf0\x9f\xbf\xbf" : I8_to_native("\xf3\xbf\xbf\xbf"),
848         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
849         'nonchar', 0x1FFFF, 4,
850         qr/Unicode non-character.*is not recommended for open interchange/
851     ],
852     [ "non-character code point U+2FFFE",
853         (isASCII) ? "\xf0\xaf\xbf\xbe" : I8_to_native("\xf5\xbf\xbf\xbe"),
854         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
855         'nonchar', 0x2FFFE, 4,
856         qr/Unicode non-character.*is not recommended for open interchange/
857     ],
858     [ "non-character code point U+2FFFF",
859         (isASCII) ? "\xf0\xaf\xbf\xbf" : I8_to_native("\xf5\xbf\xbf\xbf"),
860         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
861         'nonchar', 0x2FFFF, 4,
862         qr/Unicode non-character.*is not recommended for open interchange/
863     ],
864     [ "non-character code point U+3FFFE",
865         (isASCII) ? "\xf0\xbf\xbf\xbe" : I8_to_native("\xf7\xbf\xbf\xbe"),
866         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
867         'nonchar', 0x3FFFE, 4,
868         qr/Unicode non-character.*is not recommended for open interchange/
869     ],
870     [ "non-character code point U+3FFFF",
871         (isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"),
872         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
873         'nonchar', 0x3FFFF, 4,
874         qr/Unicode non-character.*is not recommended for open interchange/
875     ],
876     [ "non-character code point U+4FFFE",
877         (isASCII) ? "\xf1\x8f\xbf\xbe" : I8_to_native("\xf8\xa9\xbf\xbf\xbe"),
878         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
879         'nonchar', 0x4FFFE,
880         (isASCII) ? 4 : 5,
881         qr/Unicode non-character.*is not recommended for open interchange/
882     ],
883     [ "non-character code point U+4FFFF",
884         (isASCII) ? "\xf1\x8f\xbf\xbf" : I8_to_native("\xf8\xa9\xbf\xbf\xbf"),
885         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
886         'nonchar', 0x4FFFF,
887         (isASCII) ? 4 : 5,
888         qr/Unicode non-character.*is not recommended for open interchange/
889     ],
890     [ "non-character code point U+5FFFE",
891         (isASCII) ? "\xf1\x9f\xbf\xbe" : I8_to_native("\xf8\xab\xbf\xbf\xbe"),
892         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
893         'nonchar', 0x5FFFE,
894         (isASCII) ? 4 : 5,
895         qr/Unicode non-character.*is not recommended for open interchange/
896     ],
897     [ "non-character code point U+5FFFF",
898         (isASCII) ? "\xf1\x9f\xbf\xbf" : I8_to_native("\xf8\xab\xbf\xbf\xbf"),
899         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
900         'nonchar', 0x5FFFF,
901         (isASCII) ? 4 : 5,
902         qr/Unicode non-character.*is not recommended for open interchange/
903     ],
904     [ "non-character code point U+6FFFE",
905         (isASCII) ? "\xf1\xaf\xbf\xbe" : I8_to_native("\xf8\xad\xbf\xbf\xbe"),
906         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
907         'nonchar', 0x6FFFE,
908         (isASCII) ? 4 : 5,
909         qr/Unicode non-character.*is not recommended for open interchange/
910     ],
911     [ "non-character code point U+6FFFF",
912         (isASCII) ? "\xf1\xaf\xbf\xbf" : I8_to_native("\xf8\xad\xbf\xbf\xbf"),
913         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
914         'nonchar', 0x6FFFF,
915         (isASCII) ? 4 : 5,
916         qr/Unicode non-character.*is not recommended for open interchange/
917     ],
918     [ "non-character code point U+7FFFE",
919         (isASCII) ? "\xf1\xbf\xbf\xbe" : I8_to_native("\xf8\xaf\xbf\xbf\xbe"),
920         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
921         'nonchar', 0x7FFFE,
922         (isASCII) ? 4 : 5,
923         qr/Unicode non-character.*is not recommended for open interchange/
924     ],
925     [ "non-character code point U+7FFFF",
926         (isASCII) ? "\xf1\xbf\xbf\xbf" : I8_to_native("\xf8\xaf\xbf\xbf\xbf"),
927         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
928         'nonchar', 0x7FFFF,
929         (isASCII) ? 4 : 5,
930         qr/Unicode non-character.*is not recommended for open interchange/
931     ],
932     [ "non-character code point U+8FFFE",
933         (isASCII) ? "\xf2\x8f\xbf\xbe" : I8_to_native("\xf8\xb1\xbf\xbf\xbe"),
934         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
935         'nonchar', 0x8FFFE,
936         (isASCII) ? 4 : 5,
937         qr/Unicode non-character.*is not recommended for open interchange/
938     ],
939     [ "non-character code point U+8FFFF",
940         (isASCII) ? "\xf2\x8f\xbf\xbf" : I8_to_native("\xf8\xb1\xbf\xbf\xbf"),
941         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
942         'nonchar', 0x8FFFF,
943         (isASCII) ? 4 : 5,
944         qr/Unicode non-character.*is not recommended for open interchange/
945     ],
946     [ "non-character code point U+9FFFE",
947         (isASCII) ? "\xf2\x9f\xbf\xbe" : I8_to_native("\xf8\xb3\xbf\xbf\xbe"),
948         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
949         'nonchar', 0x9FFFE,
950         (isASCII) ? 4 : 5,
951         qr/Unicode non-character.*is not recommended for open interchange/
952     ],
953     [ "non-character code point U+9FFFF",
954         (isASCII) ? "\xf2\x9f\xbf\xbf" : I8_to_native("\xf8\xb3\xbf\xbf\xbf"),
955         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
956         'nonchar', 0x9FFFF,
957         (isASCII) ? 4 : 5,
958         qr/Unicode non-character.*is not recommended for open interchange/
959     ],
960     [ "non-character code point U+AFFFE",
961         (isASCII) ? "\xf2\xaf\xbf\xbe" : I8_to_native("\xf8\xb5\xbf\xbf\xbe"),
962         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
963         'nonchar', 0xAFFFE,
964         (isASCII) ? 4 : 5,
965         qr/Unicode non-character.*is not recommended for open interchange/
966     ],
967     [ "non-character code point U+AFFFF",
968         (isASCII) ? "\xf2\xaf\xbf\xbf" : I8_to_native("\xf8\xb5\xbf\xbf\xbf"),
969         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
970         'nonchar', 0xAFFFF,
971         (isASCII) ? 4 : 5,
972         qr/Unicode non-character.*is not recommended for open interchange/
973     ],
974     [ "non-character code point U+BFFFE",
975         (isASCII) ? "\xf2\xbf\xbf\xbe" : I8_to_native("\xf8\xb7\xbf\xbf\xbe"),
976         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
977         'nonchar', 0xBFFFE,
978         (isASCII) ? 4 : 5,
979         qr/Unicode non-character.*is not recommended for open interchange/
980     ],
981     [ "non-character code point U+BFFFF",
982         (isASCII) ? "\xf2\xbf\xbf\xbf" : I8_to_native("\xf8\xb7\xbf\xbf\xbf"),
983         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
984         'nonchar', 0xBFFFF,
985         (isASCII) ? 4 : 5,
986         qr/Unicode non-character.*is not recommended for open interchange/
987     ],
988     [ "non-character code point U+CFFFE",
989         (isASCII) ? "\xf3\x8f\xbf\xbe" : I8_to_native("\xf8\xb9\xbf\xbf\xbe"),
990         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
991         'nonchar', 0xCFFFE,
992         (isASCII) ? 4 : 5,
993         qr/Unicode non-character.*is not recommended for open interchange/
994     ],
995     [ "non-character code point U+CFFFF",
996         (isASCII) ? "\xf3\x8f\xbf\xbf" : I8_to_native("\xf8\xb9\xbf\xbf\xbf"),
997         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
998         'nonchar', 0xCFFFF,
999         (isASCII) ? 4 : 5,
1000         qr/Unicode non-character.*is not recommended for open interchange/
1001     ],
1002     [ "non-character code point U+DFFFE",
1003         (isASCII) ? "\xf3\x9f\xbf\xbe" : I8_to_native("\xf8\xbb\xbf\xbf\xbe"),
1004         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1005         'nonchar', 0xDFFFE,
1006         (isASCII) ? 4 : 5,
1007         qr/Unicode non-character.*is not recommended for open interchange/
1008     ],
1009     [ "non-character code point U+DFFFF",
1010         (isASCII) ? "\xf3\x9f\xbf\xbf" : I8_to_native("\xf8\xbb\xbf\xbf\xbf"),
1011         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1012         'nonchar', 0xDFFFF,
1013         (isASCII) ? 4 : 5,
1014         qr/Unicode non-character.*is not recommended for open interchange/
1015     ],
1016     [ "non-character code point U+EFFFE",
1017         (isASCII) ? "\xf3\xaf\xbf\xbe" : I8_to_native("\xf8\xbd\xbf\xbf\xbe"),
1018         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1019         'nonchar', 0xEFFFE,
1020         (isASCII) ? 4 : 5,
1021         qr/Unicode non-character.*is not recommended for open interchange/
1022     ],
1023     [ "non-character code point U+EFFFF",
1024         (isASCII) ? "\xf3\xaf\xbf\xbf" : I8_to_native("\xf8\xbd\xbf\xbf\xbf"),
1025         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1026         'nonchar', 0xEFFFF,
1027         (isASCII) ? 4 : 5,
1028         qr/Unicode non-character.*is not recommended for open interchange/
1029     ],
1030     [ "non-character code point U+FFFFE",
1031         (isASCII) ? "\xf3\xbf\xbf\xbe" : I8_to_native("\xf8\xbf\xbf\xbf\xbe"),
1032         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1033         'nonchar', 0xFFFFE,
1034         (isASCII) ? 4 : 5,
1035         qr/Unicode non-character.*is not recommended for open interchange/
1036     ],
1037     [ "non-character code point U+FFFFF",
1038         (isASCII) ? "\xf3\xbf\xbf\xbf" : I8_to_native("\xf8\xbf\xbf\xbf\xbf"),
1039         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1040         'nonchar', 0xFFFFF,
1041         (isASCII) ? 4 : 5,
1042         qr/Unicode non-character.*is not recommended for open interchange/
1043     ],
1044     [ "non-character code point U+10FFFE",
1045         (isASCII) ? "\xf4\x8f\xbf\xbe" : I8_to_native("\xf9\xa1\xbf\xbf\xbe"),
1046         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1047         'nonchar', 0x10FFFE,
1048         (isASCII) ? 4 : 5,
1049         qr/Unicode non-character.*is not recommended for open interchange/
1050     ],
1051     [ "non-character code point U+10FFFF",
1052         (isASCII) ? "\xf4\x8f\xbf\xbf" : I8_to_native("\xf9\xa1\xbf\xbf\xbf"),
1053         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1054         'nonchar', 0x10FFFF,
1055         (isASCII) ? 4 : 5,
1056         qr/Unicode non-character.*is not recommended for open interchange/
1057     ],
1058     [ "requires at least 32 bits",
1059         (isASCII)
1060          ? "\xfe\x82\x80\x80\x80\x80\x80"
1061          : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
1062         # This code point is chosen so that it is representable in a UV on
1063         # 32-bit machines
1064         $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
1065         'utf8', 0x80000000, (isASCII) ? 7 :14,
1066         qr/Code point 0x80000000 is not Unicode, and not portable/
1067     ],
1068     [ "requires at least 32 bits, and use SUPER-type flags, instead of ABOVE_31_BIT",
1069         (isASCII)
1070          ? "\xfe\x82\x80\x80\x80\x80\x80"
1071          : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
1072         $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
1073         'utf8', 0x80000000, (isASCII) ? 7 :14,
1074         qr/Code point 0x80000000 is not Unicode, and not portable/
1075     ],
1076     [ "overflow with warnings/disallow for more than 31 bits",
1077         # This tests the interaction of WARN_ABOVE_31_BIT/DISALLOW_ABOVE_31_BIT
1078         # with overflow.  The overflow malformation is never allowed, so
1079         # preventing it takes precedence if the ABOVE_31_BIT options would
1080         # otherwise allow in an overflowing value.  The ASCII code points (1
1081         # for 32-bits; 1 for 64) were chosen because the old overflow
1082         # detection algorithm did not catch them; this means this test also
1083         # checks for that fix.  The EBCDIC are arbitrary overflowing ones
1084         # since we have no reports of failures with it.
1085        (($is64bit)
1086         ? ((isASCII)
1087            ?              "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
1088            : I8_to_native("\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"))
1089         : ((isASCII)
1090            ?              "\xfe\x86\x80\x80\x80\x80\x80"
1091            : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"))),
1092
1093         # We include both warning categories to make sure the ABOVE_31_BIT one
1094         # has precedence
1095         "$UTF8_WARN_ABOVE_31_BIT|$UTF8_WARN_SUPER",
1096         "$UTF8_DISALLOW_ABOVE_31_BIT",
1097         'utf8', 0,
1098         (! isASCII) ? 14 : ($is64bit) ? 13 : 7,
1099         qr/overflow at byte .*, after start byte 0xf/
1100     ],
1101 );
1102
1103 if ($is64bit) {
1104     no warnings qw{portable overflow};
1105     push @tests,
1106         [ "More than 32 bits",
1107             (isASCII)
1108             ?              "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
1109             : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1110             $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
1111             'utf8', 0x1000000000, (isASCII) ? 13 : 14,
1112             qr/Code point 0x.* is not Unicode, and not portable/
1113         ];
1114     if (! isASCII) {
1115         push @tests,   # These could falsely show wrongly in a naive implementation
1116             [ "requires at least 32 bits",
1117                 I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1118                 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1119                 'utf8', 0x800000000, 14,
1120                 qr/Code point 0x800000000 is not Unicode, and not portable/
1121             ],
1122             [ "requires at least 32 bits",
1123                 I8_to_native("\xff\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1124                 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1125                 'utf8', 0x10000000000, 14,
1126                 qr/Code point 0x10000000000 is not Unicode, and not portable/
1127             ],
1128             [ "requires at least 32 bits",
1129                 I8_to_native("\xff\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1130                 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1131                 'utf8', 0x200000000000, 14,
1132                 qr/Code point 0x200000000000 is not Unicode, and not portable/
1133             ],
1134             [ "requires at least 32 bits",
1135                 I8_to_native("\xff\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1136                 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1137                 'utf8', 0x4000000000000, 14,
1138                 qr/Code point 0x4000000000000 is not Unicode, and not portable/
1139             ],
1140             [ "requires at least 32 bits",
1141                 I8_to_native("\xff\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1142                 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1143                 'utf8', 0x80000000000000, 14,
1144                 qr/Code point 0x80000000000000 is not Unicode, and not portable/
1145             ],
1146             [ "requires at least 32 bits",
1147                 I8_to_native("\xff\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1148                 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1149                 'utf8', 0x1000000000000000, 14,
1150                 qr/Code point 0x1000000000000000 is not Unicode, and not portable/
1151             ];
1152     }
1153 }
1154
1155 foreach my $test (@tests) {
1156     my ($testname, $bytes, $warn_flags, $disallow_flags, $category, $allowed_uv, $expected_len, $message ) = @$test;
1157
1158     my $length = length $bytes;
1159     my $will_overflow = $testname =~ /overflow/;
1160
1161     {
1162         use warnings;
1163         undef @warnings;
1164         my $ret = test_isUTF8_CHAR($bytes, $length);
1165         if ($will_overflow) {
1166             is($ret, 0, "isUTF8_CHAR() $testname: returns 0");
1167         }
1168         else {
1169             is($ret, $length,
1170                "isUTF8_CHAR() $testname: returns expected length: $length");
1171         }
1172         unless (is(scalar @warnings, 0,
1173                 "isUTF8_CHAR() $testname: generated no warnings"))
1174         {
1175             diag "The warnings were: " . join(", ", @warnings);
1176         }
1177     }
1178
1179     # This is more complicated than the malformations tested earlier, as there
1180     # are several orthogonal variables involved.  We test all the subclasses
1181     # of utf8 warnings to verify they work with and without the utf8 class,
1182     # and don't have effects on other sublass warnings
1183     foreach my $warning ('utf8', 'surrogate', 'nonchar', 'non_unicode') {
1184         foreach my $warn_flag (0, $warn_flags) {
1185             foreach my $disallow_flag (0, $disallow_flags) {
1186                 foreach my $do_warning (0, 1) {
1187
1188                     my $eval_warn = $do_warning
1189                                   ? "use warnings '$warning'"
1190                                   : $warning eq "utf8"
1191                                     ? "no warnings 'utf8'"
1192                                     : "use warnings 'utf8'; no warnings '$warning'";
1193
1194                     # is effectively disallowed if will overflow, even if the
1195                     # flag indicates it is allowed, fix up test name to
1196                     # indicate this as well
1197                     my $disallowed = $disallow_flag || $will_overflow;
1198
1199                     my $this_name = "utf8n_to_uvchr() $testname: " . (($disallow_flag)
1200                                                     ? 'disallowed'
1201                                                     : ($disallowed)
1202                                                         ? 'ABOVE_31_BIT allowed'
1203                                                         : 'allowed');
1204                     $this_name .= ", $eval_warn";
1205                     $this_name .= ", " . (($warn_flag)
1206                                           ? 'with warning flag'
1207                                           : 'no warning flag');
1208
1209                     undef @warnings;
1210                     my $ret_ref;
1211                     my $display_bytes = display_bytes($bytes);
1212                     my $call = "Call was: $eval_warn; \$ret_ref = test_utf8n_to_uvchr('$display_bytes', $length, $warn_flag|$disallow_flag)";
1213                     my $eval_text =      "$eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)";
1214                     eval "$eval_text";
1215                     if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
1216                         diag "\$!='$!'; eval'd=\"$call\"";
1217                         next;
1218                     }
1219                     if ($disallowed) {
1220                         unless (is($ret_ref->[0], 0, "$this_name: Returns 0"))
1221                         {
1222                             diag $call;
1223                         }
1224                     }
1225                     else {
1226                         unless (is($ret_ref->[0], $allowed_uv,
1227                                    "$this_name: Returns expected uv: "
1228                                  . sprintf("0x%04X", $allowed_uv)))
1229                         {
1230                             diag $call;
1231                         }
1232                     }
1233                     unless (is($ret_ref->[1], $expected_len,
1234                         "$this_name: Returns expected length: $expected_len"))
1235                     {
1236                         diag $call;
1237                     }
1238
1239                     if (! $do_warning
1240                         && ($warning eq 'utf8' || $warning eq $category))
1241                     {
1242                         if (!is(scalar @warnings, 0,
1243                                             "$this_name: No warnings generated"))
1244                         {
1245                             diag $call;
1246                             diag "The warnings were: " . join(", ", @warnings);
1247                         }
1248                     }
1249                     elsif ($will_overflow
1250                            && ! $disallow_flag
1251                            && $warning eq 'utf8')
1252                     {
1253
1254                         # Will get the overflow message instead of the expected
1255                         # message under these circumstances, as they would
1256                         # otherwise accept an overflowed value, which the code
1257                         # should not allow, so falls back to overflow.
1258                         if (is(scalar @warnings, 1,
1259                                "$this_name: Got a single warning "))
1260                         {
1261                             unless (like($warnings[0], qr/overflow/,
1262                                         "$this_name: Got overflow warning"))
1263                             {
1264                                 diag $call;
1265                             }
1266                         }
1267                         else {
1268                             diag $call;
1269                             if (scalar @warnings) {
1270                                 diag "The warnings were: "
1271                                                         . join(", ", @warnings);
1272                             }
1273                         }
1274                     }
1275                     elsif ($warn_flag
1276                            && ($warning eq 'utf8' || $warning eq $category))
1277                     {
1278                         if (is(scalar @warnings, 1,
1279                                "$this_name: Got a single warning "))
1280                         {
1281                             unless (like($warnings[0], $message,
1282                                         "$this_name: Got expected warning"))
1283                             {
1284                                 diag $call;
1285                             }
1286                         }
1287                         else {
1288                             diag $call;
1289                             if (scalar @warnings) {
1290                                 diag "The warnings were: "
1291                                                         . join(", ", @warnings);
1292                             }
1293                         }
1294                     }
1295
1296                     # Check CHECK_ONLY results when the input is disallowed.  Do
1297                     # this when actually disallowed, not just when the
1298                     # $disallow_flag is set
1299                     if ($disallowed) {
1300                         undef @warnings;
1301                         $ret_ref = test_utf8n_to_uvchr($bytes, $length,
1302                                                 $disallow_flag|$UTF8_CHECK_ONLY);
1303                         unless (is($ret_ref->[0], 0, "$this_name, CHECK_ONLY: Returns 0")) {
1304                             diag $call;
1305                         }
1306                         unless (is($ret_ref->[1], -1,
1307                             "$this_name: CHECK_ONLY: returns -1 for length"))
1308                         {
1309                             diag $call;
1310                         }
1311                         if (! is(scalar @warnings, 0,
1312                             "$this_name, CHECK_ONLY: no warnings generated"))
1313                         {
1314                             diag $call;
1315                             diag "The warnings were: " . join(", ", @warnings);
1316                         }
1317                     }
1318
1319                     # Now repeat some of the above, but for
1320                     # uvchr_to_utf8_flags().  Since this comes from an
1321                     # existing code point, it hasn't overflowed.
1322                     next if $will_overflow;
1323
1324                     # The warning and disallow flags passed in are for
1325                     # utf8n_to_uvchr().  Convert them for
1326                     # uvchr_to_utf8_flags().
1327                     my $uvchr_warn_flag = 0;
1328                     my $uvchr_disallow_flag = 0;
1329                     if ($warn_flag) {
1330                         if ($warn_flag == $UTF8_WARN_SURROGATE) {
1331                             $uvchr_warn_flag = $UNICODE_WARN_SURROGATE
1332                         }
1333                         elsif ($warn_flag == $UTF8_WARN_NONCHAR) {
1334                             $uvchr_warn_flag = $UNICODE_WARN_NONCHAR
1335                         }
1336                         elsif ($warn_flag == $UTF8_WARN_SUPER) {
1337                             $uvchr_warn_flag = $UNICODE_WARN_SUPER
1338                         }
1339                         elsif ($warn_flag == $UTF8_WARN_ABOVE_31_BIT) {
1340                             $uvchr_warn_flag = $UNICODE_WARN_ABOVE_31_BIT;
1341                         }
1342                         else {
1343                             fail(sprintf "Unexpected warn flag: %x",
1344                                  $warn_flag);
1345                             next;
1346                         }
1347                     }
1348                     if ($disallow_flag) {
1349                         if ($disallow_flag == $UTF8_DISALLOW_SURROGATE) {
1350                             $uvchr_disallow_flag = $UNICODE_DISALLOW_SURROGATE
1351                         }
1352                         elsif ($disallow_flag == $UTF8_DISALLOW_NONCHAR) {
1353                             $uvchr_disallow_flag = $UNICODE_DISALLOW_NONCHAR
1354                         }
1355                         elsif ($disallow_flag == $UTF8_DISALLOW_SUPER) {
1356                             $uvchr_disallow_flag = $UNICODE_DISALLOW_SUPER
1357                         }
1358                         elsif ($disallow_flag == $UTF8_DISALLOW_ABOVE_31_BIT) {
1359                             $uvchr_disallow_flag =
1360                             $UNICODE_DISALLOW_ABOVE_31_BIT;
1361                         }
1362                         else {
1363                             fail(sprintf "Unexpected disallow flag: %x",
1364                                  $disallow_flag);
1365                             next;
1366                         }
1367                     }
1368
1369                     $disallowed = $uvchr_disallow_flag;
1370
1371                     $this_name = "uvchr_to_utf8_flags() $testname: "
1372                                                   . (($uvchr_disallow_flag)
1373                                                     ? 'disallowed'
1374                                                     : ($disallowed)
1375                                                       ? 'ABOVE_31_BIT allowed'
1376                                                       : 'allowed');
1377                     $this_name .= ", $eval_warn";
1378                     $this_name .= ", " . (($uvchr_warn_flag)
1379                                           ? 'with warning flag'
1380                                           : 'no warning flag');
1381
1382                     undef @warnings;
1383                     my $ret;
1384                     my $warn_flag = sprintf "0x%x", $uvchr_warn_flag;
1385                     my $disallow_flag = sprintf "0x%x", $uvchr_disallow_flag;
1386                     $call = sprintf "call was: $eval_warn; \$ret = test_uvchr_to_utf8_flags(0x%x, $warn_flag|$disallow_flag)", $allowed_uv;
1387                     $eval_text = "$eval_warn; \$ret = test_uvchr_to_utf8_flags($allowed_uv, $warn_flag|$disallow_flag)";
1388                     eval "$eval_text";
1389                     if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
1390                         diag "\$!='$!'; eval'd=\"$eval_text\"";
1391                         next;
1392                     }
1393                     if ($disallowed) {
1394                         unless (is($ret, undef, "$this_name: Returns undef")) {
1395                             diag $call;
1396                         }
1397                     }
1398                     else {
1399                         unless (is($ret, $bytes, "$this_name: Returns expected string")) {
1400                             diag $call;
1401                         }
1402                     }
1403                     if (! $do_warning
1404                         && ($warning eq 'utf8' || $warning eq $category))
1405                     {
1406                         if (!is(scalar @warnings, 0,
1407                                             "$this_name: No warnings generated"))
1408                         {
1409                             diag $call;
1410                             diag "The warnings were: " . join(", ", @warnings);
1411                         }
1412                     }
1413                     elsif ($uvchr_warn_flag
1414                            && ($warning eq 'utf8' || $warning eq $category))
1415                     {
1416                         if (is(scalar @warnings, 1,
1417                                "$this_name: Got a single warning "))
1418                         {
1419                             unless (like($warnings[0], $message,
1420                                             "$this_name: Got expected warning"))
1421                             {
1422                                 diag $call;
1423                             }
1424                         }
1425                         else {
1426                             diag $call;
1427                             if (scalar @warnings) {
1428                                 diag "The warnings were: "
1429                                                         . join(", ", @warnings);
1430                             }
1431                         }
1432                     }
1433                 }
1434             }
1435         }
1436     }
1437 }
1438
1439 done_testing;