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