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