ext/XS-APItest/t/utf8.t

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