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