This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
utf8.c: Add missing type specifier to declaration
[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\xaf\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
527     # Rest of tests likely meaningless if it gets the wrong code point.
528     next unless is($ret_ref->[0], $n,
529        "Verify utf8n_to_uvchr($display_bytes, $display_flags) returns $hex_n");
530     is($ret_ref->[1], $len,
531        "Verify utf8n_to_uvchr() for $hex_n returns expected length: $len");
532
533     unless (is(scalar @warnings, 0,
534                "Verify utf8n_to_uvchr() for $hex_n generated no warnings"))
535     {
536         diag "The warnings were: " . join(", ", @warnings);
537     }
538
539     undef @warnings;
540
541     my $ret = test_isUTF8_CHAR($bytes, $len);
542     is($ret, $len, "Verify isUTF8_CHAR($display_bytes) returns expected length: $len");
543
544     unless (is(scalar @warnings, 0,
545                "Verify isUTF8_CHAR() for $hex_n generated no warnings"))
546     {
547         diag "The warnings were: " . join(", ", @warnings);
548     }
549
550     undef @warnings;
551
552     $ret = test_isUTF8_CHAR($bytes, $len - 1);
553     is($ret, 0, "Verify isUTF8_CHAR() with too short length parameter returns 0");
554
555     unless (is(scalar @warnings, 0,
556                "Verify isUTF8_CHAR() generated no warnings"))
557     {
558         diag "The warnings were: " . join(", ", @warnings);
559     }
560
561     undef @warnings;
562
563     $ret = test_isUTF8_CHAR_flags($bytes, $len, 0);
564     is($ret, $len, "Verify isUTF8_CHAR_flags($display_bytes, 0) returns expected length: $len");
565
566     unless (is(scalar @warnings, 0,
567                "Verify isUTF8_CHAR_flags() for $hex_n generated no warnings"))
568     {
569         diag "The warnings were: " . join(", ", @warnings);
570     }
571
572     undef @warnings;
573
574     $ret = test_isUTF8_CHAR_flags($bytes, $len - 1, 0);
575     is($ret, 0, "Verify isUTF8_CHAR_flags() with too short length parameter returns 0");
576
577     unless (is(scalar @warnings, 0,
578                "Verify isUTF8_CHAR_flags() generated no warnings"))
579     {
580         diag "The warnings were: " . join(", ", @warnings);
581     }
582
583     undef @warnings;
584
585     $ret = test_isSTRICT_UTF8_CHAR($bytes, $len);
586     my $expected_len = ($valid_under_strict) ? $len : 0;
587     is($ret, $expected_len, "Verify isSTRICT_UTF8_CHAR($display_bytes) returns expected length: $expected_len");
588
589     unless (is(scalar @warnings, 0,
590                "Verify isSTRICT_UTF8_CHAR() for $hex_n generated no warnings"))
591     {
592         diag "The warnings were: " . join(", ", @warnings);
593     }
594
595     undef @warnings;
596
597     $ret = test_isSTRICT_UTF8_CHAR($bytes, $len - 1);
598     is($ret, 0, "Verify isSTRICT_UTF8_CHAR() with too short length parameter returns 0");
599
600     unless (is(scalar @warnings, 0,
601                "Verify isSTRICT_UTF8_CHAR() generated no warnings"))
602     {
603         diag "The warnings were: " . join(", ", @warnings);
604     }
605
606     undef @warnings;
607
608     $ret = test_isUTF8_CHAR_flags($bytes, $len, $UTF8_DISALLOW_ILLEGAL_INTERCHANGE);
609     is($ret, $expected_len, "Verify isUTF8_CHAR_flags('DISALLOW_ILLEGAL_INTERCHANGE') acts like isSTRICT_UTF8_CHAR");
610
611     unless (is(scalar @warnings, 0,
612                "Verify isUTF8_CHAR() for $hex_n generated no warnings"))
613     {
614         diag "The warnings were: " . join(", ", @warnings);
615     }
616
617     undef @warnings;
618
619     $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $len);
620     $expected_len = ($valid_under_c9strict) ? $len : 0;
621     is($ret, $expected_len, "Verify isC9_STRICT_UTF8_CHAR($display_bytes) returns expected length: $len");
622
623     unless (is(scalar @warnings, 0,
624                "Verify isC9_STRICT_UTF8_CHAR() for $hex_n generated no warnings"))
625     {
626         diag "The warnings were: " . join(", ", @warnings);
627     }
628
629     undef @warnings;
630
631     $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $len - 1);
632     is($ret, 0, "Verify isC9_STRICT_UTF8_CHAR() with too short length parameter returns 0");
633
634     unless (is(scalar @warnings, 0,
635                "Verify isC9_STRICT_UTF8_CHAR() generated no warnings"))
636     {
637         diag "The warnings were: " . join(", ", @warnings);
638     }
639
640     undef @warnings;
641
642     $ret = test_isUTF8_CHAR_flags($bytes, $len, $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE);
643     is($ret, $expected_len, "Verify isUTF8_CHAR_flags('DISALLOW_ILLEGAL_C9_INTERCHANGE') acts like isC9_STRICT_UTF8_CHAR");
644
645     unless (is(scalar @warnings, 0,
646                "Verify isUTF8_CHAR() for $hex_n generated no warnings"))
647     {
648         diag "The warnings were: " . join(", ", @warnings);
649     }
650
651     undef @warnings;
652
653     $ret_ref = test_valid_utf8_to_uvchr($bytes);
654     is($ret_ref->[0], $n, "Verify valid_utf8_to_uvchr($display_bytes) returns $hex_n");
655     is($ret_ref->[1], $len, "Verify valid_utf8_to_uvchr() for $hex_n returns expected length: $len");
656
657     unless (is(scalar @warnings, 0,
658                "Verify valid_utf8_to_uvchr() for $hex_n generated no warnings"))
659     {
660         diag "The warnings were: " . join(", ", @warnings);
661     }
662
663     # Similarly for uvchr_to_utf8
664     my $this_uvchr_flags = $look_for_everything_uvchr_to;
665     if ($n > 2 ** 31 - 1) {
666         $this_uvchr_flags &=
667                 ~($UNICODE_DISALLOW_ABOVE_31_BIT|$UNICODE_WARN_ABOVE_31_BIT);
668     }
669     if ($n > 0x10FFFF) {
670         $this_uvchr_flags &= ~($UNICODE_DISALLOW_SUPER|$UNICODE_WARN_SUPER);
671     }
672     elsif (($n >= 0xFDD0 && $n <= 0xFDEF) || ($n & 0xFFFE) == 0xFFFE) {
673         $this_uvchr_flags &= ~($UNICODE_DISALLOW_NONCHAR|$UNICODE_WARN_NONCHAR);
674     }
675     elsif ($n >= 0xD800 && $n <= 0xDFFF) {
676         $this_uvchr_flags &= ~($UNICODE_DISALLOW_SURROGATE|$UNICODE_WARN_SURROGATE);
677     }
678     $display_flags = sprintf "0x%x", $this_uvchr_flags;
679
680     undef @warnings;
681
682     $ret = test_uvchr_to_utf8_flags($n, $this_uvchr_flags);
683     ok(defined $ret, "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returned success");
684     is($ret, $bytes, "Verify uvchr_to_utf8_flags($hex_n, $display_flags) returns correct bytes");
685
686     unless (is(scalar @warnings, 0,
687         "Verify uvchr_to_utf8_flags($hex_n, $display_flags) for $hex_n generated no warnings"))
688     {
689         diag "The warnings were: " . join(", ", @warnings);
690     }
691
692     # Now append this code point to a string that we will test various
693     # versions of is_foo_utf8_string_bar on, and keep a count of how many code
694     # points are in it.  All the code points in this loop are valid in Perl's
695     # extended UTF-8, but some are not valid under various restrictions.  A
696     # string and count is kept separately that is entirely valid for each
697     # restriction.  And, for each restriction, we note the first occurrence in
698     # the unrestricted string where we find something not in the restricted
699     # string.
700     $restriction_types{""}{'valid_strings'} .= $bytes;
701     $restriction_types{""}{'valid_counts'}++;
702
703     if ($valid_under_c9strict) {
704         $restriction_types{"c9strict"}{'valid_strings'} .= $bytes;
705         $restriction_types{"c9strict"}{'valid_counts'}++;
706     }
707     elsif (! exists $restriction_types{"c9strict"}{'first_invalid_offset'}) {
708         $restriction_types{"c9strict"}{'first_invalid_offset'}
709                     = length $restriction_types{"c9strict"}{'valid_strings'};
710         $restriction_types{"c9strict"}{'first_invalid_count'}
711                             = $restriction_types{"c9strict"}{'valid_counts'};
712     }
713
714     if ($valid_under_strict) {
715         $restriction_types{"strict"}{'valid_strings'} .= $bytes;
716         $restriction_types{"strict"}{'valid_counts'}++;
717     }
718     elsif (! exists $restriction_types{"strict"}{'first_invalid_offset'}) {
719         $restriction_types{"strict"}{'first_invalid_offset'}
720                         = length $restriction_types{"strict"}{'valid_strings'};
721         $restriction_types{"strict"}{'first_invalid_count'}
722                                 = $restriction_types{"strict"}{'valid_counts'};
723     }
724
725     if ($valid_for_fits_in_31_bits) {
726         $restriction_types{"fits_in_31_bits"}{'valid_strings'} .= $bytes;
727         $restriction_types{"fits_in_31_bits"}{'valid_counts'}++;
728     }
729     elsif (! exists
730                 $restriction_types{"fits_in_31_bits"}{'first_invalid_offset'})
731     {
732         $restriction_types{"fits_in_31_bits"}{'first_invalid_offset'}
733                 = length $restriction_types{"fits_in_31_bits"}{'valid_strings'};
734         $restriction_types{"fits_in_31_bits"}{'first_invalid_count'}
735                         = $restriction_types{"fits_in_31_bits"}{'valid_counts'};
736     }
737 }
738
739 my $I8c = (isASCII) ? "\x80" : "\xa0";    # A continuation byte
740 my $cont_byte = I8_to_native($I8c);
741 my $p = (isASCII) ? "\xe1\x80" : I8_to_native("\xE4\xA0");  # partial
742
743 # The loop above tested the single or partial character functions/macros,
744 # while building up strings to test the string functions, which we do now.
745
746 for my $restriction (sort keys %restriction_types) {
747     use bytes;
748
749     for my $use_flags ("", "_flags") {
750
751         # For each restriction, we test it in both the is_foo_flags functions
752         # and the specially named foo function.  But not if there isn't such a
753         # specially named function.  Currently, this is the only tested
754         # restriction that doesn't have a specially named function
755         next if $use_flags eq "" && $restriction eq "fits_in_31_bits";
756
757         # Start building up the name of the function we will test.
758         my $base_name = "is_";
759
760         if (! $use_flags  && $restriction ne "") {
761             $base_name .= $restriction . "_";
762         }
763
764         # We test both "is_utf8_string_foo" and "is_fixed_width_buf" functions
765         foreach my $operand ('string', 'fixed_width_buf') {
766
767             # Currently, the only fixed_width_buf functions have the '_flags'
768             # suffix.
769             next if $operand eq 'fixed_width_buf' && $use_flags eq "";
770
771             my $name = "${base_name}utf8_$operand";
772
773             # We test each version of the function
774             for my $function ("_loclen", "_loc", "") {
775
776                 # We test each function against
777                 #   a) valid input
778                 #   b) invalid input created by appending an out-of-place
779                 #      continuation character to the valid string
780                 #   c) input created by appending a partial character.  This
781                 #      is valid in the 'fixed_width' functions, but invalid in
782                 #   the 'string' ones
783                 #   d) invalid input created by calling a function that is
784                 #      expecting a restricted form of the input using the string
785                 #      that's valid when unrestricted
786                 for my $error_type (0, $cont_byte, $p, $restriction) {
787                     #diag "restriction=$restriction, use_flags=$use_flags, function=$function, error_type=" . display_bytes($error_type);
788
789                     # If there is no restriction, the error type will be "",
790                     # which is redundant with 0.
791                     next if $error_type eq "";
792
793                     my $this_name = "$name$function$use_flags";
794                     my $bytes
795                             = $restriction_types{$restriction}{'valid_strings'};
796                     my $expected_offset = length $bytes;
797                     my $expected_count
798                             = $restriction_types{$restriction}{'valid_counts'};
799                     my $test_name_suffix = "";
800
801                     my $this_error_type = $error_type;
802                     if ($this_error_type) {
803
804                         # Appending a bare continuation byte or a partial
805                         # character doesn't change the character count or
806                         # offset.  But in the other cases, we have saved where
807                         # the failures should occur, so use those.  Appending
808                         # a continuation byte makes it invalid; appending a
809                         # partial character makes the 'string' form invalid,
810                         # but not the 'fixed_width_buf' form.
811                         if ($this_error_type eq $cont_byte || $this_error_type eq $p) {
812                             $bytes .= $this_error_type;
813                             if ($this_error_type eq $cont_byte) {
814                                 $test_name_suffix
815                                             = " for an unexpected continuation";
816                             }
817                             else {
818                                 $test_name_suffix
819                                         = " if ends with a partial character";
820                                 $this_error_type
821                                         = 0 if $operand eq "fixed_width_buf";
822                             }
823                         }
824                         else {
825                             $test_name_suffix
826                                         = " if contains forbidden code points";
827                             if ($this_error_type eq "c9strict") {
828                                 $bytes = $restriction_types{""}{'valid_strings'};
829                                 $expected_offset
830                                  = $restriction_types{"c9strict"}
831                                                      {'first_invalid_offset'};
832                                 $expected_count
833                                   = $restriction_types{"c9strict"}
834                                                       {'first_invalid_count'};
835                             }
836                             elsif ($this_error_type eq "strict") {
837                                 $bytes = $restriction_types{""}{'valid_strings'};
838                                 $expected_offset
839                                   = $restriction_types{"strict"}
840                                                       {'first_invalid_offset'};
841                                 $expected_count
842                                   = $restriction_types{"strict"}
843                                                       {'first_invalid_count'};
844
845                             }
846                             elsif ($this_error_type eq "fits_in_31_bits") {
847                                 $bytes = $restriction_types{""}{'valid_strings'};
848                                 $expected_offset
849                                   = $restriction_types{"fits_in_31_bits"}
850                                                       {'first_invalid_offset'};
851                                 $expected_count
852                                     = $restriction_types{"fits_in_31_bits"}
853                                                         {'first_invalid_count'};
854                             }
855                             else {
856                                 fail("Internal test error: Unknown error type "
857                                 . "'$this_error_type'");
858                                 next;
859                             }
860                         }
861                     }
862
863                     my $length = length $bytes;
864                     my $ret_ref;
865
866                     my $test = "\$ret_ref = test_$this_name(\$bytes, $length";
867
868                     # If using the _flags functions, we have to figure out what
869                     # flags to pass.  This is done to match the restriction.
870                     if ($use_flags eq "_flags") {
871                         if (! $restriction) {
872                             $test .= ", 0";     # The flag
873
874                             # Indicate the kind of flag in the test name.
875                             $this_name .= "(0)";
876                         }
877                         else {
878                             $this_name .= "($restriction)";
879                             if ($restriction eq "c9strict") {
880                                 $test
881                                   .= ", $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE";
882                             }
883                             elsif ($restriction eq "strict") {
884                                 $test .= ", $UTF8_DISALLOW_ILLEGAL_INTERCHANGE";
885                             }
886                             elsif ($restriction eq "fits_in_31_bits") {
887                                 $test .= ", $UTF8_DISALLOW_ABOVE_31_BIT";
888                             }
889                             else {
890                                 fail("Internal test error: Unknown restriction "
891                                 . "'$restriction'");
892                                 next;
893                             }
894                         }
895                     }
896                     $test .= ")";
897
898                     # Actually run the test
899                     eval $test;
900                     if ($@) {
901                         fail($test);
902                         diag $@;
903                         next;
904                     }
905
906                     my $ret;
907                     my $error_offset;
908                     my $cp_count;
909
910                     if ($function eq "") {
911                         $ret = $ret_ref;    # For plain function, there's only a
912                                             # single return value
913                     }
914                     else {  # Otherwise, the multiple values come in an array.
915                         $ret = shift @$ret_ref ;
916                         $error_offset = shift @$ret_ref;
917                         $cp_count = shift@$ret_ref if $function eq "_loclen";
918                     }
919
920                     if ($this_error_type) {
921                         is($ret, 0,
922                            "Verify $this_name is FALSE$test_name_suffix");
923                     }
924                     else {
925                         unless(is($ret, 1,
926                                   "Verify $this_name is TRUE for valid input"
927                                 . "$test_name_suffix"))
928                         {
929                             diag("The bytes starting at offset"
930                                . " $error_offset are"
931                                . display_bytes(substr(
932                                           $restriction_types{$restriction}
933                                                             {'valid_strings'},
934                                           $error_offset)));
935                             next;
936                         }
937                     }
938
939                     if ($function ne "") {
940                         unless (is($error_offset, $expected_offset,
941                                    "\tAnd returns the correct offset"))
942                         {
943                             my $min = ($error_offset < $expected_offset)
944                                     ? $error_offset
945                                     : $expected_offset;
946                             diag display_bytes(substr($bytes, $min));
947                         }
948
949                         if ($function eq '_loclen') {
950                             is($cp_count, $expected_count,
951                                "\tAnd returns the correct character count");
952                         }
953                     }
954                 }
955             }
956         }
957     }
958 }
959
960 my $REPLACEMENT = 0xFFFD;
961
962 # Now test the malformations.  All these raise category utf8 warnings.
963 my @malformations = (
964     [ "zero length string malformation", "", 0,
965         $UTF8_ALLOW_EMPTY, 0, 0,
966         qr/empty string/
967     ],
968     [ "orphan continuation byte malformation", I8_to_native("${I8c}a"),
969         2,
970         $UTF8_ALLOW_CONTINUATION, $REPLACEMENT, 1,
971         qr/unexpected continuation byte/
972     ],
973     [ "premature next character malformation (immediate)",
974         (isASCII) ? "\xc2\xc2\x80" : I8_to_native("\xc5\xc5\xa0"),
975         3,
976         $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 1,
977         qr/unexpected non-continuation byte.*immediately after start byte/
978     ],
979     [ "premature next character malformation (non-immediate)",
980         I8_to_native("\xf0${I8c}a"),
981         3,
982         $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 2,
983         qr/unexpected non-continuation byte .* 2 bytes after start byte/
984     ],
985     [ "too short malformation", I8_to_native("\xf0${I8c}a"), 2,
986         # Having the 'a' after this, but saying there are only 2 bytes also
987         # tests that we pay attention to the passed in length
988         $UTF8_ALLOW_SHORT, $REPLACEMENT, 2,
989         qr/2 bytes, need 4/
990     ],
991     [ "overlong malformation, lowest 2-byte",
992         (isASCII) ? "\xc0\x80" : I8_to_native("\xc0\xa0"),
993         2,
994         $UTF8_ALLOW_LONG,
995         0,   # NUL
996         2,
997         qr/2 bytes, need 1/
998     ],
999     [ "overlong malformation, highest 2-byte",
1000         (isASCII) ? "\xc1\xbf" : I8_to_native("\xc4\xbf"),
1001         2,
1002         $UTF8_ALLOW_LONG,
1003         (isASCII) ? 0x7F : utf8::unicode_to_native(0xBF),
1004         2,
1005         qr/2 bytes, need 1/
1006     ],
1007     [ "overlong malformation, lowest 3-byte",
1008         (isASCII) ? "\xe0\x80\x80" : I8_to_native("\xe0\xa0\xa0"),
1009         3,
1010         $UTF8_ALLOW_LONG,
1011         0,   # NUL
1012         3,
1013         qr/3 bytes, need 1/
1014     ],
1015     [ "overlong malformation, highest 3-byte",
1016         (isASCII) ? "\xe0\x9f\xbf" : I8_to_native("\xe0\xbf\xbf"),
1017         3,
1018         $UTF8_ALLOW_LONG,
1019         (isASCII) ? 0x7FF : 0x3FF,
1020         3,
1021         qr/3 bytes, need 2/
1022     ],
1023     [ "overlong malformation, lowest 4-byte",
1024         (isASCII) ? "\xf0\x80\x80\x80" : I8_to_native("\xf0\xa0\xa0\xa0"),
1025         4,
1026         $UTF8_ALLOW_LONG,
1027         0,   # NUL
1028         4,
1029         qr/4 bytes, need 1/
1030     ],
1031     [ "overlong malformation, highest 4-byte",
1032         (isASCII) ? "\xf0\x8F\xbf\xbf" : I8_to_native("\xf0\xaf\xbf\xbf"),
1033         4,
1034         $UTF8_ALLOW_LONG,
1035         (isASCII) ? 0xFFFF : 0x3FFF,
1036         4,
1037         qr/4 bytes, need 3/
1038     ],
1039     [ "overlong malformation, lowest 5-byte",
1040         (isASCII)
1041          ?              "\xf8\x80\x80\x80\x80"
1042          : I8_to_native("\xf8\xa0\xa0\xa0\xa0"),
1043         5,
1044         $UTF8_ALLOW_LONG,
1045         0,   # NUL
1046         5,
1047         qr/5 bytes, need 1/
1048     ],
1049     [ "overlong malformation, highest 5-byte",
1050         (isASCII)
1051          ?              "\xf8\x87\xbf\xbf\xbf"
1052          : I8_to_native("\xf8\xa7\xbf\xbf\xbf"),
1053         5,
1054         $UTF8_ALLOW_LONG,
1055         (isASCII) ? 0x1FFFFF : 0x3FFFF,
1056         5,
1057         qr/5 bytes, need 4/
1058     ],
1059     [ "overlong malformation, lowest 6-byte",
1060         (isASCII)
1061          ?              "\xfc\x80\x80\x80\x80\x80"
1062          : I8_to_native("\xfc\xa0\xa0\xa0\xa0\xa0"),
1063         6,
1064         $UTF8_ALLOW_LONG,
1065         0,   # NUL
1066         6,
1067         qr/6 bytes, need 1/
1068     ],
1069     [ "overlong malformation, highest 6-byte",
1070         (isASCII)
1071          ?              "\xfc\x83\xbf\xbf\xbf\xbf"
1072          : I8_to_native("\xfc\xa3\xbf\xbf\xbf\xbf"),
1073         6,
1074         $UTF8_ALLOW_LONG,
1075         (isASCII) ? 0x3FFFFFF : 0x3FFFFF,
1076         6,
1077         qr/6 bytes, need 5/
1078     ],
1079     [ "overlong malformation, lowest 7-byte",
1080         (isASCII)
1081          ?              "\xfe\x80\x80\x80\x80\x80\x80"
1082          : I8_to_native("\xfe\xa0\xa0\xa0\xa0\xa0\xa0"),
1083         7,
1084         $UTF8_ALLOW_LONG,
1085         0,   # NUL
1086         7,
1087         qr/7 bytes, need 1/
1088     ],
1089     [ "overlong malformation, highest 7-byte",
1090         (isASCII)
1091          ?              "\xfe\x81\xbf\xbf\xbf\xbf\xbf"
1092          : I8_to_native("\xfe\xa1\xbf\xbf\xbf\xbf\xbf"),
1093         7,
1094         $UTF8_ALLOW_LONG,
1095         (isASCII) ? 0x7FFFFFFF : 0x3FFFFFF,
1096         7,
1097         qr/7 bytes, need 6/
1098     ],
1099 );
1100
1101 if (isASCII && ! $is64bit) {    # 32-bit ASCII platform
1102     no warnings 'portable';
1103     push @malformations,
1104         [ "overflow malformation",
1105             "\xfe\x84\x80\x80\x80\x80\x80",  # Represents 2**32
1106             7,
1107             0,  # There is no way to allow this malformation
1108             $REPLACEMENT,
1109             7,
1110             qr/overflow/
1111         ],
1112         [ "overflow malformation, can tell on first byte",
1113             "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
1114             13,
1115             0,  # There is no way to allow this malformation
1116             $REPLACEMENT,
1117             13,
1118             qr/overflow/
1119         ];
1120 }
1121 else {
1122     # On EBCDIC platforms, another overlong test is needed even on 32-bit
1123     # systems, whereas it doesn't happen on ASCII except on 64-bit ones.
1124
1125     no warnings 'portable';
1126     no warnings 'overflow'; # Doesn't run on 32-bit systems, but compiles
1127     push @malformations,
1128         [ "overlong malformation, lowest max-byte",
1129             (isASCII)
1130              ?              "\xff\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80\x80"
1131              : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1132             (isASCII) ? 13 : 14,
1133             $UTF8_ALLOW_LONG,
1134             0,   # NUL
1135             (isASCII) ? 13 : 14,
1136             qr/1[34] bytes, need 1/,    # 1[34] to work on either ASCII or EBCDIC
1137         ],
1138         [ "overlong malformation, highest max-byte",
1139             (isASCII)    # 2**36-1 on ASCII; 2**30-1 on EBCDIC
1140              ?              "\xff\x80\x80\x80\x80\x80\x80\xbf\xbf\xbf\xbf\xbf\xbf"
1141              : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xbf\xbf\xbf\xbf\xbf\xbf"),
1142             (isASCII) ? 13 : 14,
1143             $UTF8_ALLOW_LONG,
1144             (isASCII) ? 0xFFFFFFFFF : 0x3FFFFFFF,
1145             (isASCII) ? 13 : 14,
1146             qr/1[34] bytes, need 7/,
1147         ];
1148
1149     if (! $is64bit) {   # 32-bit EBCDIC
1150         push @malformations,
1151         [ "overflow malformation",
1152             I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"),
1153             14,
1154             0,  # There is no way to allow this malformation
1155             $REPLACEMENT,
1156             14,
1157             qr/overflow/
1158         ];
1159     }
1160     else {  # 64-bit
1161         push @malformations,
1162             [ "overflow malformation",
1163                (isASCII)
1164                 ?              "\xff\x80\x90\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"
1165                 : I8_to_native("\xff\xb0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1166                 (isASCII) ? 13 : 14,
1167                 0,  # There is no way to allow this malformation
1168                 $REPLACEMENT,
1169                 (isASCII) ? 13 : 14,
1170                 qr/overflow/
1171             ];
1172     }
1173 }
1174
1175 foreach my $test (@malformations) {
1176     my ($testname, $bytes, $length, $allow_flags, $allowed_uv, $expected_len, $message ) = @$test;
1177
1178     next if ! ok(length($bytes) >= $length, "$testname: Make sure won't read beyond buffer: " . length($bytes) . " >= $length");
1179
1180     undef @warnings;
1181
1182     my $ret = test_isUTF8_CHAR($bytes, $length);
1183     is($ret, 0, "$testname: isUTF8_CHAR returns 0");
1184     unless (is(scalar @warnings, 0,
1185                "$testname: isUTF8_CHAR() generated no warnings"))
1186     {
1187         diag "The warnings were: " . join(", ", @warnings);
1188     }
1189
1190     undef @warnings;
1191
1192     $ret = test_isUTF8_CHAR_flags($bytes, $length, 0);
1193     is($ret, 0, "$testname: isUTF8_CHAR_flags returns 0");
1194     unless (is(scalar @warnings, 0,
1195                "$testname: isUTF8_CHAR() generated no warnings"))
1196     {
1197         diag "The warnings were: " . join(", ", @warnings);
1198     }
1199
1200     $ret = test_isSTRICT_UTF8_CHAR($bytes, $length);
1201     is($ret, 0, "$testname: isSTRICT_UTF8_CHAR returns 0");
1202     unless (is(scalar @warnings, 0,
1203                "$testname: isSTRICT_UTF8_CHAR() generated no warnings"))
1204     {
1205         diag "The warnings were: " . join(", ", @warnings);
1206     }
1207
1208     $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $length);
1209     is($ret, 0, "$testname: isC9_STRICT_UTF8_CHAR returns 0");
1210     unless (is(scalar @warnings, 0,
1211                "$testname: isC9_STRICT_UTF8_CHAR() generated no warnings"))
1212     {
1213         diag "The warnings were: " . join(", ", @warnings);
1214     }
1215
1216     for my $j (1 .. $length - 1) {
1217         my $partial = substr($bytes, 0, $j);
1218
1219         undef @warnings;
1220
1221         $ret = test_is_utf8_valid_partial_char_flags($bytes, $j, 0);
1222         my $ret_should_be = 0;
1223         my $comment = "";
1224         if ($testname =~ /premature|short/ && $j < 2) {
1225             $ret_should_be = 1;
1226             $comment = ", but need 2 bytes to discern:";
1227         }
1228         elsif ($testname =~ /overlong/ && $length > 2) {
1229             if ($length <= 7 && $j < 2) {
1230                 $ret_should_be = 1;
1231                 $comment = ", but need 2 bytes to discern:";
1232             }
1233             elsif ($length > 7 && $j < 7) {
1234                 $ret_should_be = 1;
1235                 $comment = ", but need 7 bytes to discern:";
1236             }
1237         }
1238         elsif ($testname =~ /overflow/ && $testname !~ /first byte/) {
1239             if (isASCII) {
1240                 if ($j < (($is64bit) ? 3 : 2)) {
1241                     $comment = ", but need $j bytes to discern:";
1242                     $ret_should_be = 1;
1243                 }
1244             }
1245             else {
1246                 if ($j < (($is64bit) ? 2 : 8)) {
1247                     $comment = ", but need $j bytes to discern:";
1248                     $ret_should_be = 1;
1249                 }
1250             }
1251         }
1252         is($ret, $ret_should_be, "$testname: is_utf8_valid_partial_char_flags("
1253                                 . display_bytes($partial)
1254                                 . ")$comment returns $ret_should_be");
1255         unless (is(scalar @warnings, 0,
1256                 "$testname: is_utf8_valid_partial_char_flags() generated no warnings"))
1257         {
1258             diag "The warnings were: " . join(", ", @warnings);
1259         }
1260     }
1261
1262
1263     # Test what happens when this malformation is not allowed
1264     undef @warnings;
1265     my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
1266     is($ret_ref->[0], 0, "$testname: disallowed: Returns 0");
1267     is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), disallowed: Returns expected length: $expected_len");
1268     if (is(scalar @warnings, 1, "$testname: disallowed: Got a single warning ")) {
1269         like($warnings[0], $message, "$testname: disallowed: Got expected warning");
1270     }
1271     else {
1272         if (scalar @warnings) {
1273             diag "The warnings were: " . join(", ", @warnings);
1274         }
1275     }
1276
1277     {   # Next test when disallowed, and warnings are off.
1278         undef @warnings;
1279         no warnings 'utf8';
1280         my $ret_ref = test_utf8n_to_uvchr($bytes, $length, 0);
1281         is($ret_ref->[0], 0, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': Returns 0");
1282         is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': Returns expected length: $expected_len");
1283         if (!is(scalar @warnings, 0, "$testname: utf8n_to_uvchr(), disallowed: no warnings 'utf8': no warnings generated")) {
1284             diag "The warnings were: " . join(", ", @warnings);
1285         }
1286     }
1287
1288     # Test with CHECK_ONLY
1289     undef @warnings;
1290     $ret_ref = test_utf8n_to_uvchr($bytes, $length, $UTF8_CHECK_ONLY);
1291     is($ret_ref->[0], 0, "$testname: CHECK_ONLY: Returns 0");
1292     is($ret_ref->[1], -1, "$testname: CHECK_ONLY: returns -1 for length");
1293     if (! is(scalar @warnings, 0, "$testname: CHECK_ONLY: no warnings generated")) {
1294         diag "The warnings were: " . join(", ", @warnings);
1295     }
1296
1297     next if $allow_flags == 0;    # Skip if can't allow this malformation
1298
1299     # Test when the malformation is allowed
1300     undef @warnings;
1301     $ret_ref = test_utf8n_to_uvchr($bytes, $length, $allow_flags);
1302     is($ret_ref->[0], $allowed_uv, "$testname: utf8n_to_uvchr(), allowed: Returns expected uv: " . sprintf("0x%04X", $allowed_uv));
1303     is($ret_ref->[1], $expected_len, "$testname: utf8n_to_uvchr(), allowed: Returns expected length: $expected_len");
1304     if (!is(scalar @warnings, 0, "$testname: utf8n_to_uvchr(), allowed: no warnings generated"))
1305     {
1306         diag "The warnings were: " . join(", ", @warnings);
1307     }
1308 }
1309
1310 # Now test the cases where a legal code point is generated, but may or may not
1311 # be allowed/warned on.
1312 my @tests = (
1313     [ "lowest surrogate",
1314         (isASCII) ? "\xed\xa0\x80" : I8_to_native("\xf1\xb6\xa0\xa0"),
1315         $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
1316         'surrogate', 0xD800,
1317         (isASCII) ? 3 : 4,
1318         qr/surrogate/
1319     ],
1320     [ "a middle surrogate",
1321         (isASCII) ? "\xed\xa4\x8d" : I8_to_native("\xf1\xb6\xa8\xad"),
1322         $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
1323         'surrogate', 0xD90D,
1324         (isASCII) ? 3 : 4,
1325         qr/surrogate/
1326     ],
1327     [ "highest surrogate",
1328         (isASCII) ? "\xed\xbf\xbf" : I8_to_native("\xf1\xb7\xbf\xbf"),
1329         $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE,
1330         'surrogate', 0xDFFF,
1331         (isASCII) ? 3 : 4,
1332         qr/surrogate/
1333     ],
1334     [ "first non_unicode",
1335         (isASCII) ? "\xf4\x90\x80\x80" : I8_to_native("\xf9\xa2\xa0\xa0\xa0"),
1336         $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
1337         'non_unicode', 0x110000,
1338         (isASCII) ? 4 : 5,
1339         qr/not Unicode.* may not be portable/
1340     ],
1341     [ "non_unicode whose first byte tells that",
1342         (isASCII) ? "\xf5\x80\x80\x80" : I8_to_native("\xfa\xa0\xa0\xa0\xa0"),
1343         $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
1344         'non_unicode',
1345         (isASCII) ? 0x140000 : 0x200000,
1346         (isASCII) ? 4 : 5,
1347         qr/not Unicode.* may not be portable/
1348     ],
1349     [ "first of 32 consecutive non-character code points",
1350         (isASCII) ? "\xef\xb7\x90" : I8_to_native("\xf1\xbf\xae\xb0"),
1351         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1352         'nonchar', 0xFDD0,
1353         (isASCII) ? 3 : 4,
1354         qr/Unicode non-character.*is not recommended for open interchange/
1355     ],
1356     [ "a mid non-character code point of the 32 consecutive ones",
1357         (isASCII) ? "\xef\xb7\xa0" : I8_to_native("\xf1\xbf\xaf\xa0"),
1358         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1359         'nonchar', 0xFDE0,
1360         (isASCII) ? 3 : 4,
1361         qr/Unicode non-character.*is not recommended for open interchange/
1362     ],
1363     [ "final of 32 consecutive non-character code points",
1364         (isASCII) ? "\xef\xb7\xaf" : I8_to_native("\xf1\xbf\xaf\xaf"),
1365         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1366         'nonchar', 0xFDEF,
1367         (isASCII) ? 3 : 4,
1368         qr/Unicode non-character.*is not recommended for open interchange/
1369     ],
1370     [ "non-character code point U+FFFE",
1371         (isASCII) ? "\xef\xbf\xbe" : I8_to_native("\xf1\xbf\xbf\xbe"),
1372         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1373         'nonchar', 0xFFFE,
1374         (isASCII) ? 3 : 4,
1375         qr/Unicode non-character.*is not recommended for open interchange/
1376     ],
1377     [ "non-character code point U+FFFF",
1378         (isASCII) ? "\xef\xbf\xbf" : I8_to_native("\xf1\xbf\xbf\xbf"),
1379         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1380         'nonchar', 0xFFFF,
1381         (isASCII) ? 3 : 4,
1382         qr/Unicode non-character.*is not recommended for open interchange/
1383     ],
1384     [ "non-character code point U+1FFFE",
1385         (isASCII) ? "\xf0\x9f\xbf\xbe" : I8_to_native("\xf3\xbf\xbf\xbe"),
1386         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1387         'nonchar', 0x1FFFE, 4,
1388         qr/Unicode non-character.*is not recommended for open interchange/
1389     ],
1390     [ "non-character code point U+1FFFF",
1391         (isASCII) ? "\xf0\x9f\xbf\xbf" : I8_to_native("\xf3\xbf\xbf\xbf"),
1392         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1393         'nonchar', 0x1FFFF, 4,
1394         qr/Unicode non-character.*is not recommended for open interchange/
1395     ],
1396     [ "non-character code point U+2FFFE",
1397         (isASCII) ? "\xf0\xaf\xbf\xbe" : I8_to_native("\xf5\xbf\xbf\xbe"),
1398         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1399         'nonchar', 0x2FFFE, 4,
1400         qr/Unicode non-character.*is not recommended for open interchange/
1401     ],
1402     [ "non-character code point U+2FFFF",
1403         (isASCII) ? "\xf0\xaf\xbf\xbf" : I8_to_native("\xf5\xbf\xbf\xbf"),
1404         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1405         'nonchar', 0x2FFFF, 4,
1406         qr/Unicode non-character.*is not recommended for open interchange/
1407     ],
1408     [ "non-character code point U+3FFFE",
1409         (isASCII) ? "\xf0\xbf\xbf\xbe" : I8_to_native("\xf7\xbf\xbf\xbe"),
1410         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1411         'nonchar', 0x3FFFE, 4,
1412         qr/Unicode non-character.*is not recommended for open interchange/
1413     ],
1414     [ "non-character code point U+3FFFF",
1415         (isASCII) ? "\xf0\xbf\xbf\xbf" : I8_to_native("\xf7\xbf\xbf\xbf"),
1416         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1417         'nonchar', 0x3FFFF, 4,
1418         qr/Unicode non-character.*is not recommended for open interchange/
1419     ],
1420     [ "non-character code point U+4FFFE",
1421         (isASCII) ? "\xf1\x8f\xbf\xbe" : I8_to_native("\xf8\xa9\xbf\xbf\xbe"),
1422         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1423         'nonchar', 0x4FFFE,
1424         (isASCII) ? 4 : 5,
1425         qr/Unicode non-character.*is not recommended for open interchange/
1426     ],
1427     [ "non-character code point U+4FFFF",
1428         (isASCII) ? "\xf1\x8f\xbf\xbf" : I8_to_native("\xf8\xa9\xbf\xbf\xbf"),
1429         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1430         'nonchar', 0x4FFFF,
1431         (isASCII) ? 4 : 5,
1432         qr/Unicode non-character.*is not recommended for open interchange/
1433     ],
1434     [ "non-character code point U+5FFFE",
1435         (isASCII) ? "\xf1\x9f\xbf\xbe" : I8_to_native("\xf8\xab\xbf\xbf\xbe"),
1436         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1437         'nonchar', 0x5FFFE,
1438         (isASCII) ? 4 : 5,
1439         qr/Unicode non-character.*is not recommended for open interchange/
1440     ],
1441     [ "non-character code point U+5FFFF",
1442         (isASCII) ? "\xf1\x9f\xbf\xbf" : I8_to_native("\xf8\xab\xbf\xbf\xbf"),
1443         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1444         'nonchar', 0x5FFFF,
1445         (isASCII) ? 4 : 5,
1446         qr/Unicode non-character.*is not recommended for open interchange/
1447     ],
1448     [ "non-character code point U+6FFFE",
1449         (isASCII) ? "\xf1\xaf\xbf\xbe" : I8_to_native("\xf8\xad\xbf\xbf\xbe"),
1450         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1451         'nonchar', 0x6FFFE,
1452         (isASCII) ? 4 : 5,
1453         qr/Unicode non-character.*is not recommended for open interchange/
1454     ],
1455     [ "non-character code point U+6FFFF",
1456         (isASCII) ? "\xf1\xaf\xbf\xbf" : I8_to_native("\xf8\xad\xbf\xbf\xbf"),
1457         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1458         'nonchar', 0x6FFFF,
1459         (isASCII) ? 4 : 5,
1460         qr/Unicode non-character.*is not recommended for open interchange/
1461     ],
1462     [ "non-character code point U+7FFFE",
1463         (isASCII) ? "\xf1\xbf\xbf\xbe" : I8_to_native("\xf8\xaf\xbf\xbf\xbe"),
1464         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1465         'nonchar', 0x7FFFE,
1466         (isASCII) ? 4 : 5,
1467         qr/Unicode non-character.*is not recommended for open interchange/
1468     ],
1469     [ "non-character code point U+7FFFF",
1470         (isASCII) ? "\xf1\xbf\xbf\xbf" : I8_to_native("\xf8\xaf\xbf\xbf\xbf"),
1471         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1472         'nonchar', 0x7FFFF,
1473         (isASCII) ? 4 : 5,
1474         qr/Unicode non-character.*is not recommended for open interchange/
1475     ],
1476     [ "non-character code point U+8FFFE",
1477         (isASCII) ? "\xf2\x8f\xbf\xbe" : I8_to_native("\xf8\xb1\xbf\xbf\xbe"),
1478         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1479         'nonchar', 0x8FFFE,
1480         (isASCII) ? 4 : 5,
1481         qr/Unicode non-character.*is not recommended for open interchange/
1482     ],
1483     [ "non-character code point U+8FFFF",
1484         (isASCII) ? "\xf2\x8f\xbf\xbf" : I8_to_native("\xf8\xb1\xbf\xbf\xbf"),
1485         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1486         'nonchar', 0x8FFFF,
1487         (isASCII) ? 4 : 5,
1488         qr/Unicode non-character.*is not recommended for open interchange/
1489     ],
1490     [ "non-character code point U+9FFFE",
1491         (isASCII) ? "\xf2\x9f\xbf\xbe" : I8_to_native("\xf8\xb3\xbf\xbf\xbe"),
1492         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1493         'nonchar', 0x9FFFE,
1494         (isASCII) ? 4 : 5,
1495         qr/Unicode non-character.*is not recommended for open interchange/
1496     ],
1497     [ "non-character code point U+9FFFF",
1498         (isASCII) ? "\xf2\x9f\xbf\xbf" : I8_to_native("\xf8\xb3\xbf\xbf\xbf"),
1499         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1500         'nonchar', 0x9FFFF,
1501         (isASCII) ? 4 : 5,
1502         qr/Unicode non-character.*is not recommended for open interchange/
1503     ],
1504     [ "non-character code point U+AFFFE",
1505         (isASCII) ? "\xf2\xaf\xbf\xbe" : I8_to_native("\xf8\xb5\xbf\xbf\xbe"),
1506         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1507         'nonchar', 0xAFFFE,
1508         (isASCII) ? 4 : 5,
1509         qr/Unicode non-character.*is not recommended for open interchange/
1510     ],
1511     [ "non-character code point U+AFFFF",
1512         (isASCII) ? "\xf2\xaf\xbf\xbf" : I8_to_native("\xf8\xb5\xbf\xbf\xbf"),
1513         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1514         'nonchar', 0xAFFFF,
1515         (isASCII) ? 4 : 5,
1516         qr/Unicode non-character.*is not recommended for open interchange/
1517     ],
1518     [ "non-character code point U+BFFFE",
1519         (isASCII) ? "\xf2\xbf\xbf\xbe" : I8_to_native("\xf8\xb7\xbf\xbf\xbe"),
1520         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1521         'nonchar', 0xBFFFE,
1522         (isASCII) ? 4 : 5,
1523         qr/Unicode non-character.*is not recommended for open interchange/
1524     ],
1525     [ "non-character code point U+BFFFF",
1526         (isASCII) ? "\xf2\xbf\xbf\xbf" : I8_to_native("\xf8\xb7\xbf\xbf\xbf"),
1527         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1528         'nonchar', 0xBFFFF,
1529         (isASCII) ? 4 : 5,
1530         qr/Unicode non-character.*is not recommended for open interchange/
1531     ],
1532     [ "non-character code point U+CFFFE",
1533         (isASCII) ? "\xf3\x8f\xbf\xbe" : I8_to_native("\xf8\xb9\xbf\xbf\xbe"),
1534         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1535         'nonchar', 0xCFFFE,
1536         (isASCII) ? 4 : 5,
1537         qr/Unicode non-character.*is not recommended for open interchange/
1538     ],
1539     [ "non-character code point U+CFFFF",
1540         (isASCII) ? "\xf3\x8f\xbf\xbf" : I8_to_native("\xf8\xb9\xbf\xbf\xbf"),
1541         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1542         'nonchar', 0xCFFFF,
1543         (isASCII) ? 4 : 5,
1544         qr/Unicode non-character.*is not recommended for open interchange/
1545     ],
1546     [ "non-character code point U+DFFFE",
1547         (isASCII) ? "\xf3\x9f\xbf\xbe" : I8_to_native("\xf8\xbb\xbf\xbf\xbe"),
1548         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1549         'nonchar', 0xDFFFE,
1550         (isASCII) ? 4 : 5,
1551         qr/Unicode non-character.*is not recommended for open interchange/
1552     ],
1553     [ "non-character code point U+DFFFF",
1554         (isASCII) ? "\xf3\x9f\xbf\xbf" : I8_to_native("\xf8\xbb\xbf\xbf\xbf"),
1555         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1556         'nonchar', 0xDFFFF,
1557         (isASCII) ? 4 : 5,
1558         qr/Unicode non-character.*is not recommended for open interchange/
1559     ],
1560     [ "non-character code point U+EFFFE",
1561         (isASCII) ? "\xf3\xaf\xbf\xbe" : I8_to_native("\xf8\xbd\xbf\xbf\xbe"),
1562         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1563         'nonchar', 0xEFFFE,
1564         (isASCII) ? 4 : 5,
1565         qr/Unicode non-character.*is not recommended for open interchange/
1566     ],
1567     [ "non-character code point U+EFFFF",
1568         (isASCII) ? "\xf3\xaf\xbf\xbf" : I8_to_native("\xf8\xbd\xbf\xbf\xbf"),
1569         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1570         'nonchar', 0xEFFFF,
1571         (isASCII) ? 4 : 5,
1572         qr/Unicode non-character.*is not recommended for open interchange/
1573     ],
1574     [ "non-character code point U+FFFFE",
1575         (isASCII) ? "\xf3\xbf\xbf\xbe" : I8_to_native("\xf8\xbf\xbf\xbf\xbe"),
1576         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1577         'nonchar', 0xFFFFE,
1578         (isASCII) ? 4 : 5,
1579         qr/Unicode non-character.*is not recommended for open interchange/
1580     ],
1581     [ "non-character code point U+FFFFF",
1582         (isASCII) ? "\xf3\xbf\xbf\xbf" : I8_to_native("\xf8\xbf\xbf\xbf\xbf"),
1583         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1584         'nonchar', 0xFFFFF,
1585         (isASCII) ? 4 : 5,
1586         qr/Unicode non-character.*is not recommended for open interchange/
1587     ],
1588     [ "non-character code point U+10FFFE",
1589         (isASCII) ? "\xf4\x8f\xbf\xbe" : I8_to_native("\xf9\xa1\xbf\xbf\xbe"),
1590         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1591         'nonchar', 0x10FFFE,
1592         (isASCII) ? 4 : 5,
1593         qr/Unicode non-character.*is not recommended for open interchange/
1594     ],
1595     [ "non-character code point U+10FFFF",
1596         (isASCII) ? "\xf4\x8f\xbf\xbf" : I8_to_native("\xf9\xa1\xbf\xbf\xbf"),
1597         $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR,
1598         'nonchar', 0x10FFFF,
1599         (isASCII) ? 4 : 5,
1600         qr/Unicode non-character.*is not recommended for open interchange/
1601     ],
1602     [ "requires at least 32 bits",
1603         (isASCII)
1604          ? "\xfe\x82\x80\x80\x80\x80\x80"
1605          : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
1606         # This code point is chosen so that it is representable in a UV on
1607         # 32-bit machines
1608         $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
1609         'utf8', 0x80000000, (isASCII) ? 7 :14,
1610         qr/Code point 0x80000000 is not Unicode, and not portable/
1611     ],
1612     [ "requires at least 32 bits, and use SUPER-type flags, instead of ABOVE_31_BIT",
1613         (isASCII)
1614          ? "\xfe\x82\x80\x80\x80\x80\x80"
1615          : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0"),
1616         $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER,
1617         'utf8', 0x80000000, (isASCII) ? 7 :14,
1618         qr/Code point 0x80000000 is not Unicode, and not portable/
1619     ],
1620     [ "overflow with warnings/disallow for more than 31 bits",
1621         # This tests the interaction of WARN_ABOVE_31_BIT/DISALLOW_ABOVE_31_BIT
1622         # with overflow.  The overflow malformation is never allowed, so
1623         # preventing it takes precedence if the ABOVE_31_BIT options would
1624         # otherwise allow in an overflowing value.  The ASCII code points (1
1625         # for 32-bits; 1 for 64) were chosen because the old overflow
1626         # detection algorithm did not catch them; this means this test also
1627         # checks for that fix.  The EBCDIC are arbitrary overflowing ones
1628         # since we have no reports of failures with it.
1629        (($is64bit)
1630         ? ((isASCII)
1631            ?              "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf"
1632            : I8_to_native("\xff\xB0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"))
1633         : ((isASCII)
1634            ?              "\xfe\x86\x80\x80\x80\x80\x80"
1635            : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa0\xa4\xa0\xa0\xa0\xa0\xa0\xa0"))),
1636
1637         # We include both warning categories to make sure the ABOVE_31_BIT one
1638         # has precedence
1639         "$UTF8_WARN_ABOVE_31_BIT|$UTF8_WARN_SUPER",
1640         "$UTF8_DISALLOW_ABOVE_31_BIT",
1641         'utf8', 0,
1642         (! isASCII) ? 14 : ($is64bit) ? 13 : 7,
1643         qr/overflow at byte .*, after start byte 0xf/
1644     ],
1645 );
1646
1647 if ($is64bit) {
1648     no warnings qw{portable overflow};
1649     push @tests,
1650         [ "More than 32 bits",
1651             (isASCII)
1652             ?              "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80"
1653             : I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa2\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1654             $UTF8_WARN_ABOVE_31_BIT, $UTF8_DISALLOW_ABOVE_31_BIT,
1655             'utf8', 0x1000000000, (isASCII) ? 13 : 14,
1656             qr/Code point 0x.* is not Unicode, and not portable/
1657         ];
1658     if (! isASCII) {
1659         push @tests,   # These could falsely show wrongly in a naive implementation
1660             [ "requires at least 32 bits",
1661                 I8_to_native("\xff\xa0\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1662                 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1663                 'utf8', 0x800000000, 14,
1664                 qr/Code point 0x800000000 is not Unicode, and not portable/
1665             ],
1666             [ "requires at least 32 bits",
1667                 I8_to_native("\xff\xa0\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1668                 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1669                 'utf8', 0x10000000000, 14,
1670                 qr/Code point 0x10000000000 is not Unicode, and not portable/
1671             ],
1672             [ "requires at least 32 bits",
1673                 I8_to_native("\xff\xa0\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1674                 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1675                 'utf8', 0x200000000000, 14,
1676                 qr/Code point 0x200000000000 is not Unicode, and not portable/
1677             ],
1678             [ "requires at least 32 bits",
1679                 I8_to_native("\xff\xa0\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1680                 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1681                 'utf8', 0x4000000000000, 14,
1682                 qr/Code point 0x4000000000000 is not Unicode, and not portable/
1683             ],
1684             [ "requires at least 32 bits",
1685                 I8_to_native("\xff\xa0\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1686                 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1687                 'utf8', 0x80000000000000, 14,
1688                 qr/Code point 0x80000000000000 is not Unicode, and not portable/
1689             ],
1690             [ "requires at least 32 bits",
1691                 I8_to_native("\xff\xa1\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0"),
1692                 $UTF8_WARN_ABOVE_31_BIT,$UTF8_DISALLOW_ABOVE_31_BIT,
1693                 'utf8', 0x1000000000000000, 14,
1694                 qr/Code point 0x1000000000000000 is not Unicode, and not portable/
1695             ];
1696     }
1697 }
1698
1699 foreach my $test (@tests) {
1700     my ($testname, $bytes, $warn_flags, $disallow_flags, $category, $allowed_uv, $expected_len, $message ) = @$test;
1701
1702     my $length = length $bytes;
1703     my $will_overflow = $testname =~ /overflow/;
1704
1705     {
1706         use warnings;
1707         undef @warnings;
1708         my $ret = test_isUTF8_CHAR($bytes, $length);
1709         my $ret_flags = test_isUTF8_CHAR_flags($bytes, $length, 0);
1710         if ($will_overflow) {
1711             is($ret, 0, "isUTF8_CHAR() $testname: returns 0");
1712             is($ret_flags, 0, "isUTF8_CHAR_flags() $testname: returns 0");
1713         }
1714         else {
1715             is($ret, $length,
1716                "isUTF8_CHAR() $testname: returns expected length: $length");
1717             is($ret_flags, $length,
1718                "isUTF8_CHAR_flags(...,0) $testname: returns expected length: $length");
1719         }
1720         unless (is(scalar @warnings, 0,
1721                 "isUTF8_CHAR() and isUTF8_CHAR()_flags $testname: generated no warnings"))
1722         {
1723             diag "The warnings were: " . join(", ", @warnings);
1724         }
1725
1726         undef @warnings;
1727         $ret = test_isSTRICT_UTF8_CHAR($bytes, $length);
1728         if ($will_overflow) {
1729             is($ret, 0, "isSTRICT_UTF8_CHAR() $testname: returns 0");
1730         }
1731         else {
1732             my $expected_ret = (   $testname =~ /surrogate|non-character/
1733                                 || $allowed_uv > 0x10FFFF)
1734                                ? 0
1735                                : $length;
1736             is($ret, $expected_ret,
1737                "isSTRICT_UTF8_CHAR() $testname: returns expected length: $expected_ret");
1738             $ret = test_isUTF8_CHAR_flags($bytes, $length,
1739                                           $UTF8_DISALLOW_ILLEGAL_INTERCHANGE);
1740             is($ret, $expected_ret,
1741                "isUTF8_CHAR_flags('DISALLOW_ILLEGAL_INTERCHANGE') acts like isSTRICT_UTF8_CHAR");
1742         }
1743         unless (is(scalar @warnings, 0,
1744                 "isSTRICT_UTF8_CHAR() and isUTF8_CHAR_flags $testname: generated no warnings"))
1745         {
1746             diag "The warnings were: " . join(", ", @warnings);
1747         }
1748
1749         undef @warnings;
1750         $ret = test_isC9_STRICT_UTF8_CHAR($bytes, $length);
1751         if ($will_overflow) {
1752             is($ret, 0, "isC9_STRICT_UTF8_CHAR() $testname: returns 0");
1753         }
1754         else {
1755             my $expected_ret = (   $testname =~ /surrogate/
1756                                 || $allowed_uv > 0x10FFFF)
1757                                ? 0
1758                                : $length;
1759             is($ret, $expected_ret,
1760                "isC9_STRICT_UTF8_CHAR() $testname: returns expected length: $expected_ret");
1761             $ret = test_isUTF8_CHAR_flags($bytes, $length,
1762                                           $UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE);
1763             is($ret, $expected_ret,
1764                "isUTF8_CHAR_flags('DISALLOW_ILLEGAL_C9_INTERCHANGE') acts like isC9_STRICT_UTF8_CHAR");
1765         }
1766         unless (is(scalar @warnings, 0,
1767                 "isC9_STRICT_UTF8_CHAR() and isUTF8_CHAR_flags $testname: generated no warnings"))
1768         {
1769             diag "The warnings were: " . join(", ", @warnings);
1770         }
1771
1772         # Test partial character handling, for each byte not a full character
1773         for my $j (1.. $length - 1) {
1774
1775             # Skip the test for the interaction between overflow and above-31
1776             # bit.  It is really testing other things than the partial
1777             # character tests, for which other tests in this file are
1778             # sufficient
1779             last if $testname =~ /overflow/;
1780
1781             foreach my $disallow_flag (0, $disallow_flags) {
1782                 my $partial = substr($bytes, 0, $j);
1783                 my $ret_should_be;
1784                 my $comment;
1785                 if ($disallow_flag) {
1786                     $ret_should_be = 0;
1787                     $comment = "disallowed";
1788                 }
1789                 else {
1790                     $ret_should_be = 1;
1791                     $comment = "allowed";
1792                 }
1793
1794                 if ($disallow_flag) {
1795                     if ($testname =~ /non-character/) {
1796                         $ret_should_be = 1;
1797                         $comment .= ", but but need full char to discern";
1798                     }
1799                     elsif ($testname =~ /surrogate/) {
1800                         if ($j < 2) {
1801                             $ret_should_be = 1;
1802                             $comment .= ", but need 2 bytes to discern";
1803                         }
1804                     }
1805                     elsif ($testname =~ /first non_unicode/ && $j < 2) {
1806                         $ret_should_be = 1;
1807                         $comment .= ", but need 2 bytes to discern";
1808                     }
1809                 }
1810
1811                 undef @warnings;
1812
1813                 $ret = test_is_utf8_valid_partial_char_flags($partial, $j, $disallow_flag);
1814                 is($ret, $ret_should_be, "$testname: is_utf8_valid_partial_char_flags("
1815                                         . display_bytes($partial)
1816                                         . "), $comment: returns $ret_should_be");
1817                 unless (is(scalar @warnings, 0,
1818                         "$testname: is_utf8_valid_partial_char_flags() generated no warnings"))
1819                 {
1820                     diag "The warnings were: " . join(", ", @warnings);
1821                 }
1822             }
1823         }
1824     }
1825
1826     # This is more complicated than the malformations tested earlier, as there
1827     # are several orthogonal variables involved.  We test all the subclasses
1828     # of utf8 warnings to verify they work with and without the utf8 class,
1829     # and don't have effects on other sublass warnings
1830     foreach my $warning ('utf8', 'surrogate', 'nonchar', 'non_unicode') {
1831         foreach my $warn_flag (0, $warn_flags) {
1832             foreach my $disallow_flag (0, $disallow_flags) {
1833                 foreach my $do_warning (0, 1) {
1834
1835                     my $eval_warn = $do_warning
1836                                   ? "use warnings '$warning'"
1837                                   : $warning eq "utf8"
1838                                     ? "no warnings 'utf8'"
1839                                     : "use warnings 'utf8'; no warnings '$warning'";
1840
1841                     # is effectively disallowed if will overflow, even if the
1842                     # flag indicates it is allowed, fix up test name to
1843                     # indicate this as well
1844                     my $disallowed = $disallow_flag || $will_overflow;
1845
1846                     my $this_name = "utf8n_to_uvchr() $testname: " . (($disallow_flag)
1847                                                     ? 'disallowed'
1848                                                     : ($disallowed)
1849                                                         ? 'ABOVE_31_BIT allowed'
1850                                                         : 'allowed');
1851                     $this_name .= ", $eval_warn";
1852                     $this_name .= ", " . (($warn_flag)
1853                                           ? 'with warning flag'
1854                                           : 'no warning flag');
1855
1856                     undef @warnings;
1857                     my $ret_ref;
1858                     my $display_bytes = display_bytes($bytes);
1859                     my $call = "Call was: $eval_warn; \$ret_ref = test_utf8n_to_uvchr('$display_bytes', $length, $warn_flag|$disallow_flag)";
1860                     my $eval_text =      "$eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)";
1861                     eval "$eval_text";
1862                     if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
1863                         diag "\$!='$!'; eval'd=\"$call\"";
1864                         next;
1865                     }
1866                     if ($disallowed) {
1867                         unless (is($ret_ref->[0], 0, "$this_name: Returns 0"))
1868                         {
1869                             diag $call;
1870                         }
1871                     }
1872                     else {
1873                         unless (is($ret_ref->[0], $allowed_uv,
1874                                    "$this_name: Returns expected uv: "
1875                                  . sprintf("0x%04X", $allowed_uv)))
1876                         {
1877                             diag $call;
1878                         }
1879                     }
1880                     unless (is($ret_ref->[1], $expected_len,
1881                         "$this_name: Returns expected length: $expected_len"))
1882                     {
1883                         diag $call;
1884                     }
1885
1886                     if (! $do_warning
1887                         && ($warning eq 'utf8' || $warning eq $category))
1888                     {
1889                         if (!is(scalar @warnings, 0,
1890                                             "$this_name: No warnings generated"))
1891                         {
1892                             diag $call;
1893                             diag "The warnings were: " . join(", ", @warnings);
1894                         }
1895                     }
1896                     elsif ($will_overflow
1897                            && ! $disallow_flag
1898                            && $warning eq 'utf8')
1899                     {
1900
1901                         # Will get the overflow message instead of the expected
1902                         # message under these circumstances, as they would
1903                         # otherwise accept an overflowed value, which the code
1904                         # should not allow, so falls back to overflow.
1905                         if (is(scalar @warnings, 1,
1906                                "$this_name: Got a single warning "))
1907                         {
1908                             unless (like($warnings[0], qr/overflow/,
1909                                         "$this_name: Got overflow warning"))
1910                             {
1911                                 diag $call;
1912                             }
1913                         }
1914                         else {
1915                             diag $call;
1916                             if (scalar @warnings) {
1917                                 diag "The warnings were: "
1918                                                         . join(", ", @warnings);
1919                             }
1920                         }
1921                     }
1922                     elsif ($warn_flag
1923                            && ($warning eq 'utf8' || $warning eq $category))
1924                     {
1925                         if (is(scalar @warnings, 1,
1926                                "$this_name: Got a single warning "))
1927                         {
1928                             unless (like($warnings[0], $message,
1929                                         "$this_name: Got expected warning"))
1930                             {
1931                                 diag $call;
1932                             }
1933                         }
1934                         else {
1935                             diag $call;
1936                             if (scalar @warnings) {
1937                                 diag "The warnings were: "
1938                                                         . join(", ", @warnings);
1939                             }
1940                         }
1941                     }
1942
1943                     # Check CHECK_ONLY results when the input is disallowed.  Do
1944                     # this when actually disallowed, not just when the
1945                     # $disallow_flag is set
1946                     if ($disallowed) {
1947                         undef @warnings;
1948                         $ret_ref = test_utf8n_to_uvchr($bytes, $length,
1949                                                 $disallow_flag|$UTF8_CHECK_ONLY);
1950                         unless (is($ret_ref->[0], 0, "$this_name, CHECK_ONLY: Returns 0")) {
1951                             diag $call;
1952                         }
1953                         unless (is($ret_ref->[1], -1,
1954                             "$this_name: CHECK_ONLY: returns -1 for length"))
1955                         {
1956                             diag $call;
1957                         }
1958                         if (! is(scalar @warnings, 0,
1959                             "$this_name, CHECK_ONLY: no warnings generated"))
1960                         {
1961                             diag $call;
1962                             diag "The warnings were: " . join(", ", @warnings);
1963                         }
1964                     }
1965
1966                     # Now repeat some of the above, but for
1967                     # uvchr_to_utf8_flags().  Since this comes from an
1968                     # existing code point, it hasn't overflowed.
1969                     next if $will_overflow;
1970
1971                     # The warning and disallow flags passed in are for
1972                     # utf8n_to_uvchr().  Convert them for
1973                     # uvchr_to_utf8_flags().
1974                     my $uvchr_warn_flag = 0;
1975                     my $uvchr_disallow_flag = 0;
1976                     if ($warn_flag) {
1977                         if ($warn_flag == $UTF8_WARN_SURROGATE) {
1978                             $uvchr_warn_flag = $UNICODE_WARN_SURROGATE
1979                         }
1980                         elsif ($warn_flag == $UTF8_WARN_NONCHAR) {
1981                             $uvchr_warn_flag = $UNICODE_WARN_NONCHAR
1982                         }
1983                         elsif ($warn_flag == $UTF8_WARN_SUPER) {
1984                             $uvchr_warn_flag = $UNICODE_WARN_SUPER
1985                         }
1986                         elsif ($warn_flag == $UTF8_WARN_ABOVE_31_BIT) {
1987                             $uvchr_warn_flag = $UNICODE_WARN_ABOVE_31_BIT;
1988                         }
1989                         else {
1990                             fail(sprintf "Unexpected warn flag: %x",
1991                                  $warn_flag);
1992                             next;
1993                         }
1994                     }
1995                     if ($disallow_flag) {
1996                         if ($disallow_flag == $UTF8_DISALLOW_SURROGATE) {
1997                             $uvchr_disallow_flag = $UNICODE_DISALLOW_SURROGATE
1998                         }
1999                         elsif ($disallow_flag == $UTF8_DISALLOW_NONCHAR) {
2000                             $uvchr_disallow_flag = $UNICODE_DISALLOW_NONCHAR
2001                         }
2002                         elsif ($disallow_flag == $UTF8_DISALLOW_SUPER) {
2003                             $uvchr_disallow_flag = $UNICODE_DISALLOW_SUPER
2004                         }
2005                         elsif ($disallow_flag == $UTF8_DISALLOW_ABOVE_31_BIT) {
2006                             $uvchr_disallow_flag =
2007                             $UNICODE_DISALLOW_ABOVE_31_BIT;
2008                         }
2009                         else {
2010                             fail(sprintf "Unexpected disallow flag: %x",
2011                                  $disallow_flag);
2012                             next;
2013                         }
2014                     }
2015
2016                     $disallowed = $uvchr_disallow_flag;
2017
2018                     $this_name = "uvchr_to_utf8_flags() $testname: "
2019                                                   . (($uvchr_disallow_flag)
2020                                                     ? 'disallowed'
2021                                                     : ($disallowed)
2022                                                       ? 'ABOVE_31_BIT allowed'
2023                                                       : 'allowed');
2024                     $this_name .= ", $eval_warn";
2025                     $this_name .= ", " . (($uvchr_warn_flag)
2026                                           ? 'with warning flag'
2027                                           : 'no warning flag');
2028
2029                     undef @warnings;
2030                     my $ret;
2031                     my $warn_flag = sprintf "0x%x", $uvchr_warn_flag;
2032                     my $disallow_flag = sprintf "0x%x", $uvchr_disallow_flag;
2033                     $call = sprintf "call was: $eval_warn; \$ret = test_uvchr_to_utf8_flags(0x%x, $warn_flag|$disallow_flag)", $allowed_uv;
2034                     $eval_text = "$eval_warn; \$ret = test_uvchr_to_utf8_flags($allowed_uv, $warn_flag|$disallow_flag)";
2035                     eval "$eval_text";
2036                     if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
2037                         diag "\$!='$!'; eval'd=\"$eval_text\"";
2038                         next;
2039                     }
2040                     if ($disallowed) {
2041                         unless (is($ret, undef, "$this_name: Returns undef")) {
2042                             diag $call;
2043                         }
2044                     }
2045                     else {
2046                         unless (is($ret, $bytes, "$this_name: Returns expected string")) {
2047                             diag $call;
2048                         }
2049                     }
2050                     if (! $do_warning
2051                         && ($warning eq 'utf8' || $warning eq $category))
2052                     {
2053                         if (!is(scalar @warnings, 0,
2054                                             "$this_name: No warnings generated"))
2055                         {
2056                             diag $call;
2057                             diag "The warnings were: " . join(", ", @warnings);
2058                         }
2059                     }
2060                     elsif ($uvchr_warn_flag
2061                            && ($warning eq 'utf8' || $warning eq $category))
2062                     {
2063                         if (is(scalar @warnings, 1,
2064                                "$this_name: Got a single warning "))
2065                         {
2066                             unless (like($warnings[0], $message,
2067                                             "$this_name: Got expected warning"))
2068                             {
2069                                 diag $call;
2070                             }
2071                         }
2072                         else {
2073                             diag $call;
2074                             if (scalar @warnings) {
2075                                 diag "The warnings were: "
2076                                                         . join(", ", @warnings);
2077                             }
2078                         }
2079                     }
2080                 }
2081             }
2082         }
2083     }
2084 }
2085
2086 done_testing;