utf8.c

   1 /*    utf8.c
   2  *
   3  *    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   4  *    by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * 'What a fix!' said Sam.  'That's the one place in all the lands we've ever
  13  *  heard of that we don't want to see any closer; and that's the one place
  14  *  we're trying to get to!  And that's just where we can't get, nohow.'
  15  *
  16  *     [p.603 of _The Lord of the Rings_, IV/I: "The Taming of Sméagol"]
  17  *
  18  * 'Well do I understand your speech,' he answered in the same language;
  19  * 'yet few strangers do so.  Why then do you not speak in the Common Tongue,
  20  *  as is the custom in the West, if you wish to be answered?'
  21  *                           --Gandalf, addressing Théoden's door wardens
  22  *
  23  *     [p.508 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
  24  *
  25  * ...the travellers perceived that the floor was paved with stones of many
  26  * hues; branching runes and strange devices intertwined beneath their feet.
  27  *
  28  *     [p.512 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
  29  */
  30
  31 #include "EXTERN.h"
  32 #define PERL_IN_UTF8_C
  33 #include "perl.h"
  34
  35 #ifndef EBCDIC
  36 /* Separate prototypes needed because in ASCII systems these are
  37  * usually macros but they still are compiled as code, too. */
  38 PERL_CALLCONV UV        Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags);
  39 PERL_CALLCONV U8*       Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv);
  40 #endif
  41
  42 static const char unees[] =
  43     "Malformed UTF-8 character (unexpected end of string)";
  44
  45 /*
  46 =head1 Unicode Support
  47
  48 This file contains various utility functions for manipulating UTF8-encoded
  49 strings. For the uninitiated, this is a method of representing arbitrary
  50 Unicode characters as a variable number of bytes, in such a way that
  51 characters in the ASCII range are unmodified, and a zero byte never appears
  52 within non-zero characters.
  53
  54 =cut
  55 */
  56
  57 /*
  58 =for apidoc is_ascii_string
  59
  60 Returns true if the first C<len> bytes of the given string are the same whether
  61 or not the string is encoded in UTF-8 (or UTF-EBCDIC on EBCDIC machines).  That
  62 is, if they are invariant.  On ASCII-ish machines, only ASCII characters
  63 fit this definition, hence the function's name.
  64
  65 If C<len> is 0, it will be calculated using C<strlen(s)>.
  66
  67 See also is_utf8_string(), is_utf8_string_loclen(), and is_utf8_string_loc().
  68
  69 =cut
  70 */
  71
  72 bool
  73 Perl_is_ascii_string(const U8 *s, STRLEN len)
  74 {
  75     const U8* const send = s + (len ? len : strlen((const char *)s));
  76     const U8* x = s;
  77
  78     PERL_ARGS_ASSERT_IS_ASCII_STRING;
  79
  80     for (; x < send; ++x) {
  81         if (!UTF8_IS_INVARIANT(*x))
  82             break;
  83     }
  84
  85     return x == send;
  86 }
  87
  88 /*
  89 =for apidoc uvuni_to_utf8_flags
  90
  91 Adds the UTF-8 representation of the code point C<uv> to the end
  92 of the string C<d>; C<d> should have at least C<UTF8_MAXBYTES+1> free
  93 bytes available. The return value is the pointer to the byte after the
  94 end of the new character. In other words,
  95
  96     d = uvuni_to_utf8_flags(d, uv, flags);
  97
  98 or, in most cases,
  99
 100     d = uvuni_to_utf8(d, uv);
 101
 102 (which is equivalent to)
 103
 104     d = uvuni_to_utf8_flags(d, uv, 0);
 105
 106 This is the recommended Unicode-aware way of saying
 107
 108     *(d++) = uv;
 109
 110 This function will convert to UTF-8 (and not warn) even code points that aren't
 111 legal Unicode or are problematic, unless C<flags> contains one or more of the
 112 following flags.
 113 If C<uv> is a Unicode surrogate code point and UNICODE_WARN_SURROGATE is set,
 114 the function will raise a warning, provided UTF8 warnings are enabled.  If instead
 115 UNICODE_DISALLOW_SURROGATE is set, the function will fail and return NULL.
 116 If both flags are set, the function will both warn and return NULL.
 117
 118 The UNICODE_WARN_NONCHAR and UNICODE_DISALLOW_NONCHAR flags correspondingly
 119 affect how the function handles a Unicode non-character.  And, likewise for the
 120 UNICODE_WARN_SUPER and UNICODE_DISALLOW_SUPER flags, and code points that are
 121 above the Unicode maximum of 0x10FFFF.  Code points above 0x7FFF_FFFF (which are
 122 even less portable) can be warned and/or disallowed even if other above-Unicode
 123 code points are accepted by the UNICODE_WARN_FE_FF and UNICODE_DISALLOW_FE_FF
 124 flags.
 125
 126 And finally, the flag UNICODE_WARN_ILLEGAL_INTERCHANGE selects all four of the
 127 above WARN flags; and UNICODE_DISALLOW_ILLEGAL_INTERCHANGE selects all four
 128 DISALLOW flags.
 129
 130
 131 =cut
 132 */
 133
 134 U8 *
 135 Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
 136 {
 137     PERL_ARGS_ASSERT_UVUNI_TO_UTF8_FLAGS;
 138
 139     if (ckWARN_d(WARN_UTF8)) {
 140         if (UNICODE_IS_SURROGATE(uv)) {
 141             if (flags & UNICODE_WARN_SURROGATE) {
 142                 Perl_ck_warner_d(aTHX_ packWARN(WARN_SURROGATE),
 143                                             "UTF-16 surrogate U+%04"UVXf, uv);
 144             }
 145             if (flags & UNICODE_DISALLOW_SURROGATE) {
 146                 return NULL;
 147             }
 148         }
 149         else if (UNICODE_IS_SUPER(uv)) {
 150             if (flags & UNICODE_WARN_SUPER
 151                 || (UNICODE_IS_FE_FF(uv) && (flags & UNICODE_WARN_FE_FF)))
 152             {
 153                 Perl_ck_warner_d(aTHX_ packWARN(WARN_NON_UNICODE),
 154                           "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv);
 155             }
 156             if (flags & UNICODE_DISALLOW_SUPER
 157                 || (UNICODE_IS_FE_FF(uv) && (flags & UNICODE_DISALLOW_FE_FF)))
 158             {
 159                 return NULL;
 160             }
 161         }
 162         else if (UNICODE_IS_NONCHAR(uv)) {
 163             if (flags & UNICODE_WARN_NONCHAR) {
 164                 Perl_ck_warner_d(aTHX_ packWARN(WARN_NONCHAR),
 165                  "Unicode non-character U+%04"UVXf" is illegal for open interchange",
 166                  uv);
 167             }
 168             if (flags & UNICODE_DISALLOW_NONCHAR) {
 169                 return NULL;
 170             }
 171         }
 172     }
 173     if (UNI_IS_INVARIANT(uv)) {
 174         *d++ = (U8)UTF_TO_NATIVE(uv);
 175         return d;
 176     }
 177 #if defined(EBCDIC)
 178     else {
 179         STRLEN len  = UNISKIP(uv);
 180         U8 *p = d+len-1;
 181         while (p > d) {
 182             *p-- = (U8)UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
 183             uv >>= UTF_ACCUMULATION_SHIFT;
 184         }
 185         *p = (U8)UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
 186         return d+len;
 187     }
 188 #else /* Non loop style */
 189     if (uv < 0x800) {
 190         *d++ = (U8)(( uv >>  6)         | 0xc0);
 191         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 192         return d;
 193     }
 194     if (uv < 0x10000) {
 195         *d++ = (U8)(( uv >> 12)         | 0xe0);
 196         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 197         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 198         return d;
 199     }
 200     if (uv < 0x200000) {
 201         *d++ = (U8)(( uv >> 18)         | 0xf0);
 202         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
 203         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 204         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 205         return d;
 206     }
 207     if (uv < 0x4000000) {
 208         *d++ = (U8)(( uv >> 24)         | 0xf8);
 209         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
 210         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
 211         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 212         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 213         return d;
 214     }
 215     if (uv < 0x80000000) {
 216         *d++ = (U8)(( uv >> 30)         | 0xfc);
 217         *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
 218         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
 219         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
 220         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 221         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 222         return d;
 223     }
 224 #ifdef HAS_QUAD
 225     if (uv < UTF8_QUAD_MAX)
 226 #endif
 227     {
 228         *d++ =                            0xfe; /* Can't match U+FEFF! */
 229         *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
 230         *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
 231         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
 232         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
 233         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 234         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 235         return d;
 236     }
 237 #ifdef HAS_QUAD
 238     {
 239         *d++ =                            0xff;         /* Can't match U+FFFE! */
 240         *d++ =                            0x80;         /* 6 Reserved bits */
 241         *d++ = (U8)(((uv >> 60) & 0x0f) | 0x80);        /* 2 Reserved bits */
 242         *d++ = (U8)(((uv >> 54) & 0x3f) | 0x80);
 243         *d++ = (U8)(((uv >> 48) & 0x3f) | 0x80);
 244         *d++ = (U8)(((uv >> 42) & 0x3f) | 0x80);
 245         *d++ = (U8)(((uv >> 36) & 0x3f) | 0x80);
 246         *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
 247         *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
 248         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
 249         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
 250         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 251         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 252         return d;
 253     }
 254 #endif
 255 #endif /* Loop style */
 256 }
 257
 258 /*
 259
 260 Tests if some arbitrary number of bytes begins in a valid UTF-8
 261 character.  Note that an INVARIANT (i.e. ASCII) character is a valid
 262 UTF-8 character.  The actual number of bytes in the UTF-8 character
 263 will be returned if it is valid, otherwise 0.
 264
 265 This is the "slow" version as opposed to the "fast" version which is
 266 the "unrolled" IS_UTF8_CHAR().  E.g. for t/uni/class.t the speed
 267 difference is a factor of 2 to 3.  For lengths (UTF8SKIP(s)) of four
 268 or less you should use the IS_UTF8_CHAR(), for lengths of five or more
 269 you should use the _slow().  In practice this means that the _slow()
 270 will be used very rarely, since the maximum Unicode code point (as of
 271 Unicode 4.1) is U+10FFFF, which encodes in UTF-8 to four bytes.  Only
 272 the "Perl extended UTF-8" (the infamous 'v-strings') will encode into
 273 five bytes or more.
 274
 275 =cut */
 276 STATIC STRLEN
 277 S_is_utf8_char_slow(const U8 *s, const STRLEN len)
 278 {
 279     U8 u = *s;
 280     STRLEN slen;
 281     UV uv, ouv;
 282
 283     PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW;
 284
 285     if (UTF8_IS_INVARIANT(u))
 286         return 1;
 287
 288     if (!UTF8_IS_START(u))
 289         return 0;
 290
 291     if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
 292         return 0;
 293
 294     slen = len - 1;
 295     s++;
 296 #ifdef EBCDIC
 297     u = NATIVE_TO_UTF(u);
 298 #endif
 299     u &= UTF_START_MASK(len);
 300     uv  = u;
 301     ouv = uv;
 302     while (slen--) {
 303         if (!UTF8_IS_CONTINUATION(*s))
 304             return 0;
 305         uv = UTF8_ACCUMULATE(uv, *s);
 306         if (uv < ouv)
 307             return 0;
 308         ouv = uv;
 309         s++;
 310     }
 311
 312     if ((STRLEN)UNISKIP(uv) < len)
 313         return 0;
 314
 315     return len;
 316 }
 317
 318 /*
 319 =for apidoc is_utf8_char
 320
 321 Tests if some arbitrary number of bytes begins in a valid UTF-8
 322 character.  Note that an INVARIANT (i.e. ASCII on non-EBCDIC machines)
 323 character is a valid UTF-8 character.  The actual number of bytes in the UTF-8
 324 character will be returned if it is valid, otherwise 0.
 325
 326 WARNING: use only if you *know* that C<s> has at least either UTF8_MAXBYTES or
 327 UTF8SKIP(s) bytes.
 328
 329 =cut */
 330 STRLEN
 331 Perl_is_utf8_char(const U8 *s)
 332 {
 333     const STRLEN len = UTF8SKIP(s);
 334
 335     PERL_ARGS_ASSERT_IS_UTF8_CHAR;
 336 #ifdef IS_UTF8_CHAR
 337     if (IS_UTF8_CHAR_FAST(len))
 338         return IS_UTF8_CHAR(s, len) ? len : 0;
 339 #endif /* #ifdef IS_UTF8_CHAR */
 340     return is_utf8_char_slow(s, len);
 341 }
 342
 343
 344 /*
 345 =for apidoc is_utf8_string
 346
 347 Returns true if first C<len> bytes of the given string form a valid
 348 UTF-8 string, false otherwise.  If C<len> is 0, it will be calculated
 349 using C<strlen(s)> (which means if you use this option, that C<s> has to have a
 350 terminating NUL byte).  Note that all characters being ASCII constitute 'a
 351 valid UTF-8 string'.
 352
 353 See also is_ascii_string(), is_utf8_string_loclen(), and is_utf8_string_loc().
 354
 355 =cut
 356 */
 357
 358 bool
 359 Perl_is_utf8_string(const U8 *s, STRLEN len)
 360 {
 361     const U8* const send = s + (len ? len : strlen((const char *)s));
 362     const U8* x = s;
 363
 364     PERL_ARGS_ASSERT_IS_UTF8_STRING;
 365
 366     while (x < send) {
 367          /* Inline the easy bits of is_utf8_char() here for speed... */
 368          if (UTF8_IS_INVARIANT(*x)) {
 369             x++;
 370          }
 371          else if (!UTF8_IS_START(*x))
 372              return FALSE;
 373          else {
 374               /* ... and call is_utf8_char() only if really needed. */
 375              const STRLEN c = UTF8SKIP(x);
 376              const U8* const next_char_ptr = x + c;
 377
 378              if (next_char_ptr > send) {
 379                  return FALSE;
 380              }
 381
 382              if (IS_UTF8_CHAR_FAST(c)) {
 383                  if (!IS_UTF8_CHAR(x, c))
 384                      return FALSE;
 385              }
 386              else if (! is_utf8_char_slow(x, c)) {
 387                  return FALSE;
 388              }
 389              x = next_char_ptr;
 390          }
 391     }
 392
 393     return TRUE;
 394 }
 395
 396 /*
 397 Implemented as a macro in utf8.h
 398
 399 =for apidoc is_utf8_string_loc
 400
 401 Like is_utf8_string() but stores the location of the failure (in the
 402 case of "utf8ness failure") or the location s+len (in the case of
 403 "utf8ness success") in the C<ep>.
 404
 405 See also is_utf8_string_loclen() and is_utf8_string().
 406
 407 =for apidoc is_utf8_string_loclen
 408
 409 Like is_utf8_string() but stores the location of the failure (in the
 410 case of "utf8ness failure") or the location s+len (in the case of
 411 "utf8ness success") in the C<ep>, and the number of UTF-8
 412 encoded characters in the C<el>.
 413
 414 See also is_utf8_string_loc() and is_utf8_string().
 415
 416 =cut
 417 */
 418
 419 bool
 420 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
 421 {
 422     const U8* const send = s + (len ? len : strlen((const char *)s));
 423     const U8* x = s;
 424     STRLEN c;
 425     STRLEN outlen = 0;
 426
 427     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
 428
 429     while (x < send) {
 430          const U8* next_char_ptr;
 431
 432          /* Inline the easy bits of is_utf8_char() here for speed... */
 433          if (UTF8_IS_INVARIANT(*x))
 434              next_char_ptr = x + 1;
 435          else if (!UTF8_IS_START(*x))
 436              goto out;
 437          else {
 438              /* ... and call is_utf8_char() only if really needed. */
 439              c = UTF8SKIP(x);
 440              next_char_ptr = c + x;
 441              if (next_char_ptr > send) {
 442                  goto out;
 443              }
 444              if (IS_UTF8_CHAR_FAST(c)) {
 445                  if (!IS_UTF8_CHAR(x, c))
 446                      c = 0;
 447              } else
 448                  c = is_utf8_char_slow(x, c);
 449              if (!c)
 450                  goto out;
 451          }
 452          x = next_char_ptr;
 453          outlen++;
 454     }
 455
 456  out:
 457     if (el)
 458         *el = outlen;
 459
 460     if (ep)
 461         *ep = x;
 462     return (x == send);
 463 }
 464
 465 /*
 466
 467 =for apidoc utf8n_to_uvuni
 468
 469 Bottom level UTF-8 decode routine.
 470 Returns the code point value of the first character in the string C<s>
 471 which is assumed to be in UTF-8 (or UTF-EBCDIC) encoding and no longer than
 472 C<curlen> bytes; C<retlen> will be set to the length, in bytes, of that
 473 character.
 474
 475 The value of C<flags> determines the behavior when C<s> does not point to a
 476 well-formed UTF-8 character.  If C<flags> is 0, when a malformation is found,
 477 C<retlen> is set to the expected length of the UTF-8 character in bytes, zero
 478 is returned, and if UTF-8 warnings haven't been lexically disabled, a warning
 479 is raised.
 480
 481 Various ALLOW flags can be set in C<flags> to allow (and not warn on)
 482 individual types of malformations, such as the sequence being overlong (that
 483 is, when there is a shorter sequence that can express the same code point;
 484 overlong sequences are expressly forbidden in the UTF-8 standard due to
 485 potential security issues).  Another malformation example is the first byte of
 486 a character not being a legal first byte.  See F<utf8.h> for the list of such
 487 flags.  Of course, the value returned by this function under such conditions is
 488 not reliable.
 489
 490 The UTF8_CHECK_ONLY flag overrides the behavior when a non-allowed (by other
 491 flags) malformation is found.  If this flag is set, the routine assumes that
 492 the caller will raise a warning, and this function will silently just set
 493 C<retlen> to C<-1> and return zero.
 494
 495 Certain code points are considered problematic.  These are Unicode surrogates,
 496 Unicode non-characters, and code points above the Unicode maximum of 0x10FFF.
 497 By default these are considered regular code points, but certain situations
 498 warrant special handling for them.  If C<flags> contains
 499 UTF8_DISALLOW_ILLEGAL_INTERCHANGE, all three classes are treated as
 500 malformations and handled as such.  The flags UTF8_DISALLOW_SURROGATE,
 501 UTF8_DISALLOW_NONCHAR, and UTF8_DISALLOW_SUPER (meaning above the legal Unicode
 502 maximum) can be set to disallow these categories individually.
 503
 504 The flags UTF8_WARN_ILLEGAL_INTERCHANGE, UTF8_WARN_SURROGATE,
 505 UTF8_WARN_NONCHAR, and UTF8_WARN_SUPER will cause warning messages to be raised
 506 for their respective categories, but otherwise the code points are considered
 507 valid (not malformations).  To get a category to both be treated as a
 508 malformation and raise a warning, specify both the WARN and DISALLOW flags.
 509 (But note that warnings are not raised if lexically disabled nor if
 510 UTF8_CHECK_ONLY is also specified.)
 511
 512 Very large code points (above 0x7FFF_FFFF) are considered more problematic than
 513 the others that are above the Unicode legal maximum.  There are several
 514 reasons, one of which is that the original UTF-8 specification never went above
 515 this number (the current 0x10FFF limit was imposed later).  The UTF-8 encoding
 516 on ASCII platforms for these large code points begins with a byte containing
 517 0xFE or 0xFF.  The UTF8_DISALLOW_FE_FF flag will cause them to be treated as
 518 malformations, while allowing smaller above-Unicode code points.  (Of course
 519 UTF8_DISALLOW_SUPER will treat all above-Unicode code points, including these,
 520 as malformations.) Similarly, UTF8_WARN_FE_FF acts just like the other WARN
 521 flags, but applies just to these code points.
 522
 523 All other code points corresponding to Unicode characters, including private
 524 use and those yet to be assigned, are never considered malformed and never
 525 warn.
 526
 527 Most code should use utf8_to_uvchr() rather than call this directly.
 528
 529 =cut
 530 */
 531
 532 UV
 533 Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
 534 {
 535     dVAR;
 536     const U8 * const s0 = s;
 537     UV uv = *s, ouv = 0;
 538     STRLEN len = 1;
 539     bool dowarn = ckWARN_d(WARN_UTF8);
 540     const UV startbyte = *s;
 541     STRLEN expectlen = 0;
 542     U32 warning = 0;
 543     SV* sv = NULL;
 544
 545     PERL_ARGS_ASSERT_UTF8N_TO_UVUNI;
 546
 547 /* This list is a superset of the UTF8_ALLOW_XXX. */
 548
 549 #define UTF8_WARN_EMPTY                          1
 550 #define UTF8_WARN_CONTINUATION                   2
 551 #define UTF8_WARN_NON_CONTINUATION               3
 552 #define UTF8_WARN_SHORT                          4
 553 #define UTF8_WARN_OVERFLOW                       5
 554 #define UTF8_WARN_LONG                           6
 555
 556     if (curlen == 0 &&
 557         !(flags & UTF8_ALLOW_EMPTY)) {
 558         warning = UTF8_WARN_EMPTY;
 559         goto malformed;
 560     }
 561
 562     if (UTF8_IS_INVARIANT(uv)) {
 563         if (retlen)
 564             *retlen = 1;
 565         return (UV) (NATIVE_TO_UTF(*s));
 566     }
 567
 568     if (UTF8_IS_CONTINUATION(uv) &&
 569         !(flags & UTF8_ALLOW_CONTINUATION)) {
 570         warning = UTF8_WARN_CONTINUATION;
 571         goto malformed;
 572     }
 573
 574     if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
 575         !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
 576         warning = UTF8_WARN_NON_CONTINUATION;
 577         goto malformed;
 578     }
 579
 580 #ifdef EBCDIC
 581     uv = NATIVE_TO_UTF(uv);
 582 #else
 583     if (uv == 0xfe || uv == 0xff) {
 584         if (flags & (UTF8_WARN_SUPER|UTF8_WARN_FE_FF)) {
 585             sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Code point beginning with byte 0x%02"UVXf" is not Unicode, and not portable", uv));
 586             flags &= ~UTF8_WARN_SUPER;  /* Only warn once on this problem */
 587         }
 588         if (flags & (UTF8_DISALLOW_SUPER|UTF8_DISALLOW_FE_FF)) {
 589             goto malformed;
 590         }
 591     }
 592 #endif
 593
 594     if      (!(uv & 0x20))      { len =  2; uv &= 0x1f; }
 595     else if (!(uv & 0x10))      { len =  3; uv &= 0x0f; }
 596     else if (!(uv & 0x08))      { len =  4; uv &= 0x07; }
 597     else if (!(uv & 0x04))      { len =  5; uv &= 0x03; }
 598 #ifdef EBCDIC
 599     else if (!(uv & 0x02))      { len =  6; uv &= 0x01; }
 600     else                        { len =  7; uv &= 0x01; }
 601 #else
 602     else if (!(uv & 0x02))      { len =  6; uv &= 0x01; }
 603     else if (!(uv & 0x01))      { len =  7; uv = 0; }
 604     else                        { len = 13; uv = 0; } /* whoa! */
 605 #endif
 606
 607     if (retlen)
 608         *retlen = len;
 609
 610     expectlen = len;
 611
 612     if ((curlen < expectlen) &&
 613         !(flags & UTF8_ALLOW_SHORT)) {
 614         warning = UTF8_WARN_SHORT;
 615         goto malformed;
 616     }
 617
 618     len--;
 619     s++;
 620     ouv = uv;   /* ouv is the value from the previous iteration */
 621
 622     while (len--) {
 623         if (!UTF8_IS_CONTINUATION(*s) &&
 624             !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
 625             s--;
 626             warning = UTF8_WARN_NON_CONTINUATION;
 627             goto malformed;
 628         }
 629         else
 630             uv = UTF8_ACCUMULATE(uv, *s);
 631         if (!(uv > ouv)) {  /* If the value didn't grow from the previous
 632                                iteration, something is horribly wrong */
 633             /* These cannot be allowed. */
 634             if (uv == ouv) {
 635                 if (expectlen != 13 && !(flags & UTF8_ALLOW_LONG)) {
 636                     warning = UTF8_WARN_LONG;
 637                     goto malformed;
 638                 }
 639             }
 640             else { /* uv < ouv */
 641                 /* This cannot be allowed. */
 642                 warning = UTF8_WARN_OVERFLOW;
 643                 goto malformed;
 644             }
 645         }
 646         s++;
 647         ouv = uv;
 648     }
 649
 650     if ((expectlen > (STRLEN)UNISKIP(uv)) && !(flags & UTF8_ALLOW_LONG)) {
 651         warning = UTF8_WARN_LONG;
 652         goto malformed;
 653     } else if (flags & (UTF8_DISALLOW_ILLEGAL_INTERCHANGE|UTF8_WARN_ILLEGAL_INTERCHANGE)) {
 654         if (UNICODE_IS_SURROGATE(uv)) {
 655             if ((flags & (UTF8_WARN_SURROGATE|UTF8_CHECK_ONLY)) == UTF8_WARN_SURROGATE) {
 656                 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "UTF-16 surrogate U+%04"UVXf"", uv));
 657             }
 658             if (flags & UTF8_DISALLOW_SURROGATE) {
 659                 goto disallowed;
 660             }
 661         }
 662         else if (UNICODE_IS_NONCHAR(uv)) {
 663             if ((flags & (UTF8_WARN_NONCHAR|UTF8_CHECK_ONLY)) == UTF8_WARN_NONCHAR ) {
 664                 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Unicode non-character U+%04"UVXf" is illegal for open interchange", uv));
 665             }
 666             if (flags & UTF8_DISALLOW_NONCHAR) {
 667                 goto disallowed;
 668             }
 669         }
 670         else if ((uv > PERL_UNICODE_MAX)) {
 671             if ((flags & (UTF8_WARN_SUPER|UTF8_CHECK_ONLY)) == UTF8_WARN_SUPER) {
 672                 sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv));
 673             }
 674             if (flags & UTF8_DISALLOW_SUPER) {
 675                 goto disallowed;
 676             }
 677         }
 678
 679         /* Here, this is not considered a malformed character, so drop through
 680          * to return it */
 681     }
 682
 683     return uv;
 684
 685 disallowed: /* Is disallowed, but otherwise not malformed.  'sv' will have been
 686                set if there is to be a warning. */
 687     if (!sv) {
 688         dowarn = 0;
 689     }
 690
 691 malformed:
 692
 693     if (flags & UTF8_CHECK_ONLY) {
 694         if (retlen)
 695             *retlen = ((STRLEN) -1);
 696         return 0;
 697     }
 698
 699     if (dowarn) {
 700         if (! sv) {
 701             sv = newSVpvs_flags("Malformed UTF-8 character ", SVs_TEMP);
 702         }
 703
 704         switch (warning) {
 705             case 0: /* Intentionally empty. */ break;
 706             case UTF8_WARN_EMPTY:
 707                 sv_catpvs(sv, "(empty string)");
 708                 break;
 709             case UTF8_WARN_CONTINUATION:
 710                 Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
 711                 break;
 712             case UTF8_WARN_NON_CONTINUATION:
 713                 if (s == s0)
 714                     Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
 715                                 (UV)s[1], startbyte);
 716                 else {
 717                     const int len = (int)(s-s0);
 718                     Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
 719                                 (UV)s[1], len, len > 1 ? "s" : "", startbyte, (int)expectlen);
 720                 }
 721
 722                 break;
 723             case UTF8_WARN_SHORT:
 724                 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
 725                                 (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, startbyte);
 726                 expectlen = curlen;             /* distance for caller to skip */
 727                 break;
 728             case UTF8_WARN_OVERFLOW:
 729                 Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
 730                                 ouv, *s, startbyte);
 731                 break;
 732             case UTF8_WARN_LONG:
 733                 Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
 734                                 (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
 735                 break;
 736             default:
 737                 sv_catpvs(sv, "(unknown reason)");
 738                 break;
 739         }
 740
 741         if (sv) {
 742             const char * const s = SvPVX_const(sv);
 743
 744             if (PL_op)
 745                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
 746                             "%s in %s", s,  OP_DESC(PL_op));
 747             else
 748                 Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s);
 749         }
 750     }
 751
 752     if (retlen)
 753         *retlen = expectlen ? expectlen : len;
 754
 755     return 0;
 756 }
 757
 758 /*
 759 =for apidoc utf8_to_uvchr
 760
 761 Returns the native code point of the first character in the string C<s>
 762 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
 763 length, in bytes, of that character.
 764
 765 If C<s> does not point to a well-formed UTF-8 character, zero is
 766 returned and retlen is set, if possible, to -1.
 767
 768 =cut
 769 */
 770
 771
 772 UV
 773 Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
 774 {
 775     PERL_ARGS_ASSERT_UTF8_TO_UVCHR;
 776
 777     return utf8n_to_uvchr(s, UTF8_MAXBYTES, retlen,
 778                           ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
 779 }
 780
 781 /*
 782 =for apidoc utf8_to_uvuni
 783
 784 Returns the Unicode code point of the first character in the string C<s>
 785 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
 786 length, in bytes, of that character.
 787
 788 This function should only be used when the returned UV is considered
 789 an index into the Unicode semantic tables (e.g. swashes).
 790
 791 If C<s> does not point to a well-formed UTF-8 character, zero is
 792 returned and retlen is set, if possible, to -1.
 793
 794 =cut
 795 */
 796
 797 UV
 798 Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
 799 {
 800     PERL_ARGS_ASSERT_UTF8_TO_UVUNI;
 801
 802     /* Call the low level routine asking for checks */
 803     return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXBYTES, retlen,
 804                                ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
 805 }
 806
 807 /*
 808 =for apidoc utf8_length
 809
 810 Return the length of the UTF-8 char encoded string C<s> in characters.
 811 Stops at C<e> (inclusive).  If C<e E<lt> s> or if the scan would end
 812 up past C<e>, croaks.
 813
 814 =cut
 815 */
 816
 817 STRLEN
 818 Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
 819 {
 820     dVAR;
 821     STRLEN len = 0;
 822
 823     PERL_ARGS_ASSERT_UTF8_LENGTH;
 824
 825     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
 826      * the bitops (especially ~) can create illegal UTF-8.
 827      * In other words: in Perl UTF-8 is not just for Unicode. */
 828
 829     if (e < s)
 830         goto warn_and_return;
 831     while (s < e) {
 832         if (!UTF8_IS_INVARIANT(*s))
 833             s += UTF8SKIP(s);
 834         else
 835             s++;
 836         len++;
 837     }
 838
 839     if (e != s) {
 840         len--;
 841         warn_and_return:
 842         if (PL_op)
 843             Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
 844                              "%s in %s", unees, OP_DESC(PL_op));
 845         else
 846             Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s", unees);
 847     }
 848
 849     return len;
 850 }
 851
 852 /*
 853 =for apidoc utf8_distance
 854
 855 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
 856 and C<b>.
 857
 858 WARNING: use only if you *know* that the pointers point inside the
 859 same UTF-8 buffer.
 860
 861 =cut
 862 */
 863
 864 IV
 865 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
 866 {
 867     PERL_ARGS_ASSERT_UTF8_DISTANCE;
 868
 869     return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
 870 }
 871
 872 /*
 873 =for apidoc utf8_hop
 874
 875 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
 876 forward or backward.
 877
 878 WARNING: do not use the following unless you *know* C<off> is within
 879 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
 880 on the first byte of character or just after the last byte of a character.
 881
 882 =cut
 883 */
 884
 885 U8 *
 886 Perl_utf8_hop(pTHX_ const U8 *s, I32 off)
 887 {
 888     PERL_ARGS_ASSERT_UTF8_HOP;
 889
 890     PERL_UNUSED_CONTEXT;
 891     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
 892      * the bitops (especially ~) can create illegal UTF-8.
 893      * In other words: in Perl UTF-8 is not just for Unicode. */
 894
 895     if (off >= 0) {
 896         while (off--)
 897             s += UTF8SKIP(s);
 898     }
 899     else {
 900         while (off++) {
 901             s--;
 902             while (UTF8_IS_CONTINUATION(*s))
 903                 s--;
 904         }
 905     }
 906     return (U8 *)s;
 907 }
 908
 909 /*
 910 =for apidoc bytes_cmp_utf8
 911
 912 Compares the sequence of characters (stored as octets) in b, blen with the
 913 sequence of characters (stored as UTF-8) in u, ulen. Returns 0 if they are
 914 equal, -1 or -2 if the first string is less than the second string, +1 or +2
 915 if the first string is greater than the second string.
 916
 917 -1 or +1 is returned if the shorter string was identical to the start of the
 918 longer string. -2 or +2 is returned if the was a difference between characters
 919 within the strings.
 920
 921 =cut
 922 */
 923
 924 int
 925 Perl_bytes_cmp_utf8(pTHX_ const U8 *b, STRLEN blen, const U8 *u, STRLEN ulen)
 926 {
 927     const U8 *const bend = b + blen;
 928     const U8 *const uend = u + ulen;
 929
 930     PERL_ARGS_ASSERT_BYTES_CMP_UTF8;
 931
 932     PERL_UNUSED_CONTEXT;
 933
 934     while (b < bend && u < uend) {
 935         U8 c = *u++;
 936         if (!UTF8_IS_INVARIANT(c)) {
 937             if (UTF8_IS_DOWNGRADEABLE_START(c)) {
 938                 if (u < uend) {
 939                     U8 c1 = *u++;
 940                     if (UTF8_IS_CONTINUATION(c1)) {
 941                         c = UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(c, c1));
 942                     } else {
 943                         Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
 944                                          "Malformed UTF-8 character "
 945                                          "(unexpected non-continuation byte 0x%02x"
 946                                          ", immediately after start byte 0x%02x)"
 947                                          /* Dear diag.t, it's in the pod.  */
 948                                          "%s%s", c1, c,
 949                                          PL_op ? " in " : "",
 950                                          PL_op ? OP_DESC(PL_op) : "");
 951                         return -2;
 952                     }
 953                 } else {
 954                     if (PL_op)
 955                         Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
 956                                          "%s in %s", unees, OP_DESC(PL_op));
 957                     else
 958                         Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s", unees);
 959                     return -2; /* Really want to return undef :-)  */
 960                 }
 961             } else {
 962                 return -2;
 963             }
 964         }
 965         if (*b != c) {
 966             return *b < c ? -2 : +2;
 967         }
 968         ++b;
 969     }
 970
 971     if (b == bend && u == uend)
 972         return 0;
 973
 974     return b < bend ? +1 : -1;
 975 }
 976
 977 /*
 978 =for apidoc utf8_to_bytes
 979
 980 Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
 981 Unlike C<bytes_to_utf8>, this over-writes the original string, and
 982 updates len to contain the new length.
 983 Returns zero on failure, setting C<len> to -1.
 984
 985 If you need a copy of the string, see C<bytes_from_utf8>.
 986
 987 =cut
 988 */
 989
 990 U8 *
 991 Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
 992 {
 993     U8 * const save = s;
 994     U8 * const send = s + *len;
 995     U8 *d;
 996
 997     PERL_ARGS_ASSERT_UTF8_TO_BYTES;
 998
 999     /* ensure valid UTF-8 and chars < 256 before updating string */
1000     while (s < send) {
1001         U8 c = *s++;
1002
1003         if (!UTF8_IS_INVARIANT(c) &&
1004             (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
1005              || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
1006             *len = ((STRLEN) -1);
1007             return 0;
1008         }
1009     }
1010
1011     d = s = save;
1012     while (s < send) {
1013         STRLEN ulen;
1014         *d++ = (U8)utf8_to_uvchr(s, &ulen);
1015         s += ulen;
1016     }
1017     *d = '\0';
1018     *len = d - save;
1019     return save;
1020 }
1021
1022 /*
1023 =for apidoc bytes_from_utf8
1024
1025 Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
1026 Unlike C<utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
1027 the newly-created string, and updates C<len> to contain the new
1028 length.  Returns the original string if no conversion occurs, C<len>
1029 is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
1030 0 if C<s> is converted or consisted entirely of characters that are invariant
1031 in utf8 (i.e., US-ASCII on non-EBCDIC machines).
1032
1033 =cut
1034 */
1035
1036 U8 *
1037 Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8)
1038 {
1039     U8 *d;
1040     const U8 *start = s;
1041     const U8 *send;
1042     I32 count = 0;
1043
1044     PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
1045
1046     PERL_UNUSED_CONTEXT;
1047     if (!*is_utf8)
1048         return (U8 *)start;
1049
1050     /* ensure valid UTF-8 and chars < 256 before converting string */
1051     for (send = s + *len; s < send;) {
1052         U8 c = *s++;
1053         if (!UTF8_IS_INVARIANT(c)) {
1054             if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
1055                 (c = *s++) && UTF8_IS_CONTINUATION(c))
1056                 count++;
1057             else
1058                 return (U8 *)start;
1059         }
1060     }
1061
1062     *is_utf8 = FALSE;
1063
1064     Newx(d, (*len) - count + 1, U8);
1065     s = start; start = d;
1066     while (s < send) {
1067         U8 c = *s++;
1068         if (!UTF8_IS_INVARIANT(c)) {
1069             /* Then it is two-byte encoded */
1070             c = UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(c, *s++));
1071         }
1072         *d++ = c;
1073     }
1074     *d = '\0';
1075     *len = d - start;
1076     return (U8 *)start;
1077 }
1078
1079 /*
1080 =for apidoc bytes_to_utf8
1081
1082 Converts a string C<s> of length C<len> bytes from the native encoding into
1083 UTF-8.
1084 Returns a pointer to the newly-created string, and sets C<len> to
1085 reflect the new length in bytes.
1086
1087 A NUL character will be written after the end of the string.
1088
1089 If you want to convert to UTF-8 from encodings other than
1090 the native (Latin1 or EBCDIC),
1091 see sv_recode_to_utf8().
1092
1093 =cut
1094 */
1095
1096 /* This logic is duplicated in sv_catpvn_flags, so any bug fixes will
1097    likewise need duplication. */
1098
1099 U8*
1100 Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len)
1101 {
1102     const U8 * const send = s + (*len);
1103     U8 *d;
1104     U8 *dst;
1105
1106     PERL_ARGS_ASSERT_BYTES_TO_UTF8;
1107     PERL_UNUSED_CONTEXT;
1108
1109     Newx(d, (*len) * 2 + 1, U8);
1110     dst = d;
1111
1112     while (s < send) {
1113         const UV uv = NATIVE_TO_ASCII(*s++);
1114         if (UNI_IS_INVARIANT(uv))
1115             *d++ = (U8)UTF_TO_NATIVE(uv);
1116         else {
1117             *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
1118             *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
1119         }
1120     }
1121     *d = '\0';
1122     *len = d-dst;
1123     return dst;
1124 }
1125
1126 /*
1127  * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
1128  *
1129  * Destination must be pre-extended to 3/2 source.  Do not use in-place.
1130  * We optimize for native, for obvious reasons. */
1131
1132 U8*
1133 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
1134 {
1135     U8* pend;
1136     U8* dstart = d;
1137
1138     PERL_ARGS_ASSERT_UTF16_TO_UTF8;
1139
1140     if (bytelen & 1)
1141         Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %"UVuf, (UV)bytelen);
1142
1143     pend = p + bytelen;
1144
1145     while (p < pend) {
1146         UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
1147         p += 2;
1148         if (uv < 0x80) {
1149 #ifdef EBCDIC
1150             *d++ = UNI_TO_NATIVE(uv);
1151 #else
1152             *d++ = (U8)uv;
1153 #endif
1154             continue;
1155         }
1156         if (uv < 0x800) {
1157             *d++ = (U8)(( uv >>  6)         | 0xc0);
1158             *d++ = (U8)(( uv        & 0x3f) | 0x80);
1159             continue;
1160         }
1161         if (uv >= 0xd800 && uv <= 0xdbff) {     /* surrogates */
1162             if (p >= pend) {
1163                 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
1164             } else {
1165                 UV low = (p[0] << 8) + p[1];
1166                 p += 2;
1167                 if (low < 0xdc00 || low > 0xdfff)
1168                     Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
1169                 uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
1170             }
1171         } else if (uv >= 0xdc00 && uv <= 0xdfff) {
1172             Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
1173         }
1174         if (uv < 0x10000) {
1175             *d++ = (U8)(( uv >> 12)         | 0xe0);
1176             *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
1177             *d++ = (U8)(( uv        & 0x3f) | 0x80);
1178             continue;
1179         }
1180         else {
1181             *d++ = (U8)(( uv >> 18)         | 0xf0);
1182             *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
1183             *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
1184             *d++ = (U8)(( uv        & 0x3f) | 0x80);
1185             continue;
1186         }
1187     }
1188     *newlen = d - dstart;
1189     return d;
1190 }
1191
1192 /* Note: this one is slightly destructive of the source. */
1193
1194 U8*
1195 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
1196 {
1197     U8* s = (U8*)p;
1198     U8* const send = s + bytelen;
1199
1200     PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED;
1201
1202     if (bytelen & 1)
1203         Perl_croak(aTHX_ "panic: utf16_to_utf8_reversed: odd bytelen %"UVuf,
1204                    (UV)bytelen);
1205
1206     while (s < send) {
1207         const U8 tmp = s[0];
1208         s[0] = s[1];
1209         s[1] = tmp;
1210         s += 2;
1211     }
1212     return utf16_to_utf8(p, d, bytelen, newlen);
1213 }
1214
1215 /* for now these are all defined (inefficiently) in terms of the utf8 versions.
1216  * Note that the macros in handy.h that call these short-circuit calling them
1217  * for Latin-1 range inputs */
1218
1219 bool
1220 Perl_is_uni_alnum(pTHX_ UV c)
1221 {
1222     U8 tmpbuf[UTF8_MAXBYTES+1];
1223     uvchr_to_utf8(tmpbuf, c);
1224     return is_utf8_alnum(tmpbuf);
1225 }
1226
1227 bool
1228 Perl_is_uni_idfirst(pTHX_ UV c)
1229 {
1230     U8 tmpbuf[UTF8_MAXBYTES+1];
1231     uvchr_to_utf8(tmpbuf, c);
1232     return is_utf8_idfirst(tmpbuf);
1233 }
1234
1235 bool
1236 Perl_is_uni_alpha(pTHX_ UV c)
1237 {
1238     U8 tmpbuf[UTF8_MAXBYTES+1];
1239     uvchr_to_utf8(tmpbuf, c);
1240     return is_utf8_alpha(tmpbuf);
1241 }
1242
1243 bool
1244 Perl_is_uni_ascii(pTHX_ UV c)
1245 {
1246     return isASCII(c);
1247 }
1248
1249 bool
1250 Perl_is_uni_space(pTHX_ UV c)
1251 {
1252     U8 tmpbuf[UTF8_MAXBYTES+1];
1253     uvchr_to_utf8(tmpbuf, c);
1254     return is_utf8_space(tmpbuf);
1255 }
1256
1257 bool
1258 Perl_is_uni_digit(pTHX_ UV c)
1259 {
1260     U8 tmpbuf[UTF8_MAXBYTES+1];
1261     uvchr_to_utf8(tmpbuf, c);
1262     return is_utf8_digit(tmpbuf);
1263 }
1264
1265 bool
1266 Perl_is_uni_upper(pTHX_ UV c)
1267 {
1268     U8 tmpbuf[UTF8_MAXBYTES+1];
1269     uvchr_to_utf8(tmpbuf, c);
1270     return is_utf8_upper(tmpbuf);
1271 }
1272
1273 bool
1274 Perl_is_uni_lower(pTHX_ UV c)
1275 {
1276     U8 tmpbuf[UTF8_MAXBYTES+1];
1277     uvchr_to_utf8(tmpbuf, c);
1278     return is_utf8_lower(tmpbuf);
1279 }
1280
1281 bool
1282 Perl_is_uni_cntrl(pTHX_ UV c)
1283 {
1284     return isCNTRL_L1(c);
1285 }
1286
1287 bool
1288 Perl_is_uni_graph(pTHX_ UV c)
1289 {
1290     U8 tmpbuf[UTF8_MAXBYTES+1];
1291     uvchr_to_utf8(tmpbuf, c);
1292     return is_utf8_graph(tmpbuf);
1293 }
1294
1295 bool
1296 Perl_is_uni_print(pTHX_ UV c)
1297 {
1298     U8 tmpbuf[UTF8_MAXBYTES+1];
1299     uvchr_to_utf8(tmpbuf, c);
1300     return is_utf8_print(tmpbuf);
1301 }
1302
1303 bool
1304 Perl_is_uni_punct(pTHX_ UV c)
1305 {
1306     U8 tmpbuf[UTF8_MAXBYTES+1];
1307     uvchr_to_utf8(tmpbuf, c);
1308     return is_utf8_punct(tmpbuf);
1309 }
1310
1311 bool
1312 Perl_is_uni_xdigit(pTHX_ UV c)
1313 {
1314     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1315     uvchr_to_utf8(tmpbuf, c);
1316     return is_utf8_xdigit(tmpbuf);
1317 }
1318
1319 UV
1320 Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const char S_or_s)
1321 {
1322     /* We have the latin1-range values compiled into the core, so just use
1323      * those, converting the result to utf8.  The only difference between upper
1324      * and title case in this range is that LATIN_SMALL_LETTER_SHARP_S is
1325      * either "SS" or "Ss".  Which one to use is passed into the routine in
1326      * 'S_or_s' to avoid a test */
1327
1328     UV converted = toUPPER_LATIN1_MOD(c);
1329
1330     PERL_ARGS_ASSERT__TO_UPPER_TITLE_LATIN1;
1331
1332     assert(S_or_s == 'S' || S_or_s == 's');
1333
1334     if (UNI_IS_INVARIANT(converted)) { /* No difference between the two for
1335                                           characters in this range */
1336         *p = (U8) converted;
1337         *lenp = 1;
1338         return converted;
1339     }
1340
1341     /* toUPPER_LATIN1_MOD gives the correct results except for three outliers,
1342      * which it maps to one of them, so as to only have to have one check for
1343      * it in the main case */
1344     if (UNLIKELY(converted == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
1345         switch (c) {
1346             case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
1347                 converted = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
1348                 break;
1349             case MICRO_SIGN:
1350                 converted = GREEK_CAPITAL_LETTER_MU;
1351                 break;
1352             case LATIN_SMALL_LETTER_SHARP_S:
1353                 *(p)++ = 'S';
1354                 *p = S_or_s;
1355                 *lenp = 2;
1356                 return 'S';
1357             default:
1358                 Perl_croak(aTHX_ "panic: to_upper_title_latin1 did not expect '%c' to map to '%c'", c, LATIN_SMALL_LETTER_Y_WITH_DIAERESIS);
1359                 /* NOTREACHED */
1360         }
1361     }
1362
1363     *(p)++ = UTF8_TWO_BYTE_HI(converted);
1364     *p = UTF8_TWO_BYTE_LO(converted);
1365     *lenp = 2;
1366
1367     return converted;
1368 }
1369
1370 /* Call the function to convert a UTF-8 encoded character to the specified case.
1371  * Note that there may be more than one character in the result.
1372  * INP is a pointer to the first byte of the input character
1373  * OUTP will be set to the first byte of the string of changed characters.  It
1374  *      needs to have space for UTF8_MAXBYTES_CASE+1 bytes
1375  * LENP will be set to the length in bytes of the string of changed characters
1376  *
1377  * The functions return the ordinal of the first character in the string of OUTP */
1378 #define CALL_UPPER_CASE(INP, OUTP, LENP) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_toupper, "ToUc", "utf8::ToSpecUpper")
1379 #define CALL_TITLE_CASE(INP, OUTP, LENP) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_totitle, "ToTc", "utf8::ToSpecTitle")
1380 #define CALL_LOWER_CASE(INP, OUTP, LENP) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_tolower, "ToLc", "utf8::ToSpecLower")
1381
1382 /* This additionally has the input parameter SPECIALS, which if non-zero will
1383  * cause this to use the SPECIALS hash for folding (meaning get full case
1384  * folding); otherwise, when zero, this implies a simple case fold */
1385 #define CALL_FOLD_CASE(INP, OUTP, LENP, SPECIALS) Perl_to_utf8_case(aTHX_ INP, OUTP, LENP, &PL_utf8_tofold, "ToCf", (SPECIALS) ? "utf8::ToSpecFold" : NULL)
1386
1387 UV
1388 Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
1389 {
1390     dVAR;
1391
1392     /* Convert the Unicode character whose ordinal is c to its uppercase
1393      * version and store that in UTF-8 in p and its length in bytes in lenp.
1394      * Note that the p needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
1395      * the changed version may be longer than the original character.
1396      *
1397      * The ordinal of the first character of the changed version is returned
1398      * (but note, as explained above, that there may be more.) */
1399
1400     PERL_ARGS_ASSERT_TO_UNI_UPPER;
1401
1402     if (c < 256) {
1403         return _to_upper_title_latin1((U8) c, p, lenp, 'S');
1404     }
1405
1406     uvchr_to_utf8(p, c);
1407     return CALL_UPPER_CASE(p, p, lenp);
1408 }
1409
1410 UV
1411 Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
1412 {
1413     dVAR;
1414
1415     PERL_ARGS_ASSERT_TO_UNI_TITLE;
1416
1417     if (c < 256) {
1418         return _to_upper_title_latin1((U8) c, p, lenp, 's');
1419     }
1420
1421     uvchr_to_utf8(p, c);
1422     return CALL_TITLE_CASE(p, p, lenp);
1423 }
1424
1425 STATIC U8
1426 S_to_lower_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp)
1427 {
1428     /* We have the latin1-range values compiled into the core, so just use
1429      * those, converting the result to utf8.  Since the result is always just
1430      * one character, we allow p to be NULL */
1431
1432     U8 converted = toLOWER_LATIN1(c);
1433
1434     if (p != NULL) {
1435         if (UNI_IS_INVARIANT(converted)) {
1436             *p = converted;
1437             *lenp = 1;
1438         }
1439         else {
1440             *p = UTF8_TWO_BYTE_HI(converted);
1441             *(p+1) = UTF8_TWO_BYTE_LO(converted);
1442             *lenp = 2;
1443         }
1444     }
1445     return converted;
1446 }
1447
1448 UV
1449 Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
1450 {
1451     dVAR;
1452
1453     PERL_ARGS_ASSERT_TO_UNI_LOWER;
1454
1455     if (c < 256) {
1456         return to_lower_latin1((U8) c, p, lenp);
1457     }
1458
1459     uvchr_to_utf8(p, c);
1460     return CALL_LOWER_CASE(p, p, lenp);
1461 }
1462
1463 UV
1464 Perl__to_fold_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const bool flags)
1465 {
1466     /* Corresponds to to_lower_latin1(), flags is TRUE if to use full case
1467      * folding */
1468
1469     UV converted;
1470
1471     PERL_ARGS_ASSERT__TO_FOLD_LATIN1;
1472
1473     if (c == MICRO_SIGN) {
1474         converted = GREEK_SMALL_LETTER_MU;
1475     }
1476     else if (flags && c == LATIN_SMALL_LETTER_SHARP_S) {
1477         *(p)++ = 's';
1478         *p = 's';
1479         *lenp = 2;
1480         return 's';
1481     }
1482     else { /* In this range the fold of all other characters is their lower
1483               case */
1484         converted = toLOWER_LATIN1(c);
1485     }
1486
1487     if (UNI_IS_INVARIANT(converted)) {
1488         *p = (U8) converted;
1489         *lenp = 1;
1490     }
1491     else {
1492         *(p)++ = UTF8_TWO_BYTE_HI(converted);
1493         *p = UTF8_TWO_BYTE_LO(converted);
1494         *lenp = 2;
1495     }
1496
1497     return converted;
1498 }
1499
1500 UV
1501 Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, const bool flags)
1502 {
1503
1504     /* Not currently externally documented, and subject to change, <flags> is
1505      * TRUE iff full folding is to be used */
1506
1507     PERL_ARGS_ASSERT__TO_UNI_FOLD_FLAGS;
1508
1509     if (c < 256) {
1510         return _to_fold_latin1((U8) c, p, lenp, flags);
1511     }
1512
1513     uvchr_to_utf8(p, c);
1514     return CALL_FOLD_CASE(p, p, lenp, flags);
1515 }
1516
1517 /* for now these all assume no locale info available for Unicode > 255 */
1518
1519 bool
1520 Perl_is_uni_alnum_lc(pTHX_ UV c)
1521 {
1522     return is_uni_alnum(c);     /* XXX no locale support yet */
1523 }
1524
1525 bool
1526 Perl_is_uni_idfirst_lc(pTHX_ UV c)
1527 {
1528     return is_uni_idfirst(c);   /* XXX no locale support yet */
1529 }
1530
1531 bool
1532 Perl_is_uni_alpha_lc(pTHX_ UV c)
1533 {
1534     return is_uni_alpha(c);     /* XXX no locale support yet */
1535 }
1536
1537 bool
1538 Perl_is_uni_ascii_lc(pTHX_ UV c)
1539 {
1540     return is_uni_ascii(c);     /* XXX no locale support yet */
1541 }
1542
1543 bool
1544 Perl_is_uni_space_lc(pTHX_ UV c)
1545 {
1546     return is_uni_space(c);     /* XXX no locale support yet */
1547 }
1548
1549 bool
1550 Perl_is_uni_digit_lc(pTHX_ UV c)
1551 {
1552     return is_uni_digit(c);     /* XXX no locale support yet */
1553 }
1554
1555 bool
1556 Perl_is_uni_upper_lc(pTHX_ UV c)
1557 {
1558     return is_uni_upper(c);     /* XXX no locale support yet */
1559 }
1560
1561 bool
1562 Perl_is_uni_lower_lc(pTHX_ UV c)
1563 {
1564     return is_uni_lower(c);     /* XXX no locale support yet */
1565 }
1566
1567 bool
1568 Perl_is_uni_cntrl_lc(pTHX_ UV c)
1569 {
1570     return is_uni_cntrl(c);     /* XXX no locale support yet */
1571 }
1572
1573 bool
1574 Perl_is_uni_graph_lc(pTHX_ UV c)
1575 {
1576     return is_uni_graph(c);     /* XXX no locale support yet */
1577 }
1578
1579 bool
1580 Perl_is_uni_print_lc(pTHX_ UV c)
1581 {
1582     return is_uni_print(c);     /* XXX no locale support yet */
1583 }
1584
1585 bool
1586 Perl_is_uni_punct_lc(pTHX_ UV c)
1587 {
1588     return is_uni_punct(c);     /* XXX no locale support yet */
1589 }
1590
1591 bool
1592 Perl_is_uni_xdigit_lc(pTHX_ UV c)
1593 {
1594     return is_uni_xdigit(c);    /* XXX no locale support yet */
1595 }
1596
1597 U32
1598 Perl_to_uni_upper_lc(pTHX_ U32 c)
1599 {
1600     /* XXX returns only the first character -- do not use XXX */
1601     /* XXX no locale support yet */
1602     STRLEN len;
1603     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1604     return (U32)to_uni_upper(c, tmpbuf, &len);
1605 }
1606
1607 U32
1608 Perl_to_uni_title_lc(pTHX_ U32 c)
1609 {
1610     /* XXX returns only the first character XXX -- do not use XXX */
1611     /* XXX no locale support yet */
1612     STRLEN len;
1613     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1614     return (U32)to_uni_title(c, tmpbuf, &len);
1615 }
1616
1617 U32
1618 Perl_to_uni_lower_lc(pTHX_ U32 c)
1619 {
1620     /* XXX returns only the first character -- do not use XXX */
1621     /* XXX no locale support yet */
1622     STRLEN len;
1623     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1624     return (U32)to_uni_lower(c, tmpbuf, &len);
1625 }
1626
1627 static bool
1628 S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
1629                  const char *const swashname)
1630 {
1631     dVAR;
1632
1633     PERL_ARGS_ASSERT_IS_UTF8_COMMON;
1634
1635     if (!is_utf8_char(p))
1636         return FALSE;
1637     if (!*swash)
1638         *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0);
1639     return swash_fetch(*swash, p, TRUE) != 0;
1640 }
1641
1642 bool
1643 Perl_is_utf8_alnum(pTHX_ const U8 *p)
1644 {
1645     dVAR;
1646
1647     PERL_ARGS_ASSERT_IS_UTF8_ALNUM;
1648
1649     /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1650      * descendant of isalnum(3), in other words, it doesn't
1651      * contain the '_'. --jhi */
1652     return is_utf8_common(p, &PL_utf8_alnum, "IsWord");
1653 }
1654
1655 bool
1656 Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
1657 {
1658     dVAR;
1659
1660     PERL_ARGS_ASSERT_IS_UTF8_IDFIRST;
1661
1662     if (*p == '_')
1663         return TRUE;
1664     /* is_utf8_idstart would be more logical. */
1665     return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
1666 }
1667
1668 bool
1669 Perl_is_utf8_xidfirst(pTHX_ const U8 *p) /* The naming is historical. */
1670 {
1671     dVAR;
1672
1673     PERL_ARGS_ASSERT_IS_UTF8_XIDFIRST;
1674
1675     if (*p == '_')
1676         return TRUE;
1677     /* is_utf8_idstart would be more logical. */
1678     return is_utf8_common(p, &PL_utf8_xidstart, "XIdStart");
1679 }
1680
1681 bool
1682 Perl__is_utf8__perl_idstart(pTHX_ const U8 *p)
1683 {
1684     dVAR;
1685
1686     PERL_ARGS_ASSERT__IS_UTF8__PERL_IDSTART;
1687
1688     return is_utf8_common(p, &PL_utf8_perl_idstart, "_Perl_IDStart");
1689 }
1690
1691 bool
1692 Perl_is_utf8_idcont(pTHX_ const U8 *p)
1693 {
1694     dVAR;
1695
1696     PERL_ARGS_ASSERT_IS_UTF8_IDCONT;
1697
1698     return is_utf8_common(p, &PL_utf8_idcont, "IdContinue");
1699 }
1700
1701 bool
1702 Perl_is_utf8_xidcont(pTHX_ const U8 *p)
1703 {
1704     dVAR;
1705
1706     PERL_ARGS_ASSERT_IS_UTF8_XIDCONT;
1707
1708     return is_utf8_common(p, &PL_utf8_idcont, "XIdContinue");
1709 }
1710
1711 bool
1712 Perl_is_utf8_alpha(pTHX_ const U8 *p)
1713 {
1714     dVAR;
1715
1716     PERL_ARGS_ASSERT_IS_UTF8_ALPHA;
1717
1718     return is_utf8_common(p, &PL_utf8_alpha, "IsAlpha");
1719 }
1720
1721 bool
1722 Perl_is_utf8_ascii(pTHX_ const U8 *p)
1723 {
1724     dVAR;
1725
1726     PERL_ARGS_ASSERT_IS_UTF8_ASCII;
1727
1728     /* ASCII characters are the same whether in utf8 or not.  So the macro
1729      * works on both utf8 and non-utf8 representations. */
1730     return isASCII(*p);
1731 }
1732
1733 bool
1734 Perl_is_utf8_space(pTHX_ const U8 *p)
1735 {
1736     dVAR;
1737
1738     PERL_ARGS_ASSERT_IS_UTF8_SPACE;
1739
1740     return is_utf8_common(p, &PL_utf8_space, "IsXPerlSpace");
1741 }
1742
1743 bool
1744 Perl_is_utf8_perl_space(pTHX_ const U8 *p)
1745 {
1746     dVAR;
1747
1748     PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE;
1749
1750     /* Only true if is an ASCII space-like character, and ASCII is invariant
1751      * under utf8, so can just use the macro */
1752     return isSPACE_A(*p);
1753 }
1754
1755 bool
1756 Perl_is_utf8_perl_word(pTHX_ const U8 *p)
1757 {
1758     dVAR;
1759
1760     PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD;
1761
1762     /* Only true if is an ASCII word character, and ASCII is invariant
1763      * under utf8, so can just use the macro */
1764     return isWORDCHAR_A(*p);
1765 }
1766
1767 bool
1768 Perl_is_utf8_digit(pTHX_ const U8 *p)
1769 {
1770     dVAR;
1771
1772     PERL_ARGS_ASSERT_IS_UTF8_DIGIT;
1773
1774     return is_utf8_common(p, &PL_utf8_digit, "IsDigit");
1775 }
1776
1777 bool
1778 Perl_is_utf8_posix_digit(pTHX_ const U8 *p)
1779 {
1780     dVAR;
1781
1782     PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT;
1783
1784     /* Only true if is an ASCII digit character, and ASCII is invariant
1785      * under utf8, so can just use the macro */
1786     return isDIGIT_A(*p);
1787 }
1788
1789 bool
1790 Perl_is_utf8_upper(pTHX_ const U8 *p)
1791 {
1792     dVAR;
1793
1794     PERL_ARGS_ASSERT_IS_UTF8_UPPER;
1795
1796     return is_utf8_common(p, &PL_utf8_upper, "IsUppercase");
1797 }
1798
1799 bool
1800 Perl_is_utf8_lower(pTHX_ const U8 *p)
1801 {
1802     dVAR;
1803
1804     PERL_ARGS_ASSERT_IS_UTF8_LOWER;
1805
1806     return is_utf8_common(p, &PL_utf8_lower, "IsLowercase");
1807 }
1808
1809 bool
1810 Perl_is_utf8_cntrl(pTHX_ const U8 *p)
1811 {
1812     dVAR;
1813
1814     PERL_ARGS_ASSERT_IS_UTF8_CNTRL;
1815
1816     if (isASCII(*p)) {
1817         return isCNTRL_A(*p);
1818     }
1819
1820     /* All controls are in Latin1 */
1821     if (! UTF8_IS_DOWNGRADEABLE_START(*p)) {
1822         return 0;
1823     }
1824     return isCNTRL_L1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
1825 }
1826
1827 bool
1828 Perl_is_utf8_graph(pTHX_ const U8 *p)
1829 {
1830     dVAR;
1831
1832     PERL_ARGS_ASSERT_IS_UTF8_GRAPH;
1833
1834     return is_utf8_common(p, &PL_utf8_graph, "IsGraph");
1835 }
1836
1837 bool
1838 Perl_is_utf8_print(pTHX_ const U8 *p)
1839 {
1840     dVAR;
1841
1842     PERL_ARGS_ASSERT_IS_UTF8_PRINT;
1843
1844     return is_utf8_common(p, &PL_utf8_print, "IsPrint");
1845 }
1846
1847 bool
1848 Perl_is_utf8_punct(pTHX_ const U8 *p)
1849 {
1850     dVAR;
1851
1852     PERL_ARGS_ASSERT_IS_UTF8_PUNCT;
1853
1854     return is_utf8_common(p, &PL_utf8_punct, "IsPunct");
1855 }
1856
1857 bool
1858 Perl_is_utf8_xdigit(pTHX_ const U8 *p)
1859 {
1860     dVAR;
1861
1862     PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
1863
1864     return is_utf8_common(p, &PL_utf8_xdigit, "IsXDigit");
1865 }
1866
1867 bool
1868 Perl_is_utf8_mark(pTHX_ const U8 *p)
1869 {
1870     dVAR;
1871
1872     PERL_ARGS_ASSERT_IS_UTF8_MARK;
1873
1874     return is_utf8_common(p, &PL_utf8_mark, "IsM");
1875 }
1876
1877 bool
1878 Perl_is_utf8_X_begin(pTHX_ const U8 *p)
1879 {
1880     dVAR;
1881
1882     PERL_ARGS_ASSERT_IS_UTF8_X_BEGIN;
1883
1884     return is_utf8_common(p, &PL_utf8_X_begin, "_X_Begin");
1885 }
1886
1887 bool
1888 Perl_is_utf8_X_extend(pTHX_ const U8 *p)
1889 {
1890     dVAR;
1891
1892     PERL_ARGS_ASSERT_IS_UTF8_X_EXTEND;
1893
1894     return is_utf8_common(p, &PL_utf8_X_extend, "_X_Extend");
1895 }
1896
1897 bool
1898 Perl_is_utf8_X_prepend(pTHX_ const U8 *p)
1899 {
1900     dVAR;
1901
1902     PERL_ARGS_ASSERT_IS_UTF8_X_PREPEND;
1903
1904     return is_utf8_common(p, &PL_utf8_X_prepend, "GCB=Prepend");
1905 }
1906
1907 bool
1908 Perl_is_utf8_X_non_hangul(pTHX_ const U8 *p)
1909 {
1910     dVAR;
1911
1912     PERL_ARGS_ASSERT_IS_UTF8_X_NON_HANGUL;
1913
1914     return is_utf8_common(p, &PL_utf8_X_non_hangul, "HST=Not_Applicable");
1915 }
1916
1917 bool
1918 Perl_is_utf8_X_L(pTHX_ const U8 *p)
1919 {
1920     dVAR;
1921
1922     PERL_ARGS_ASSERT_IS_UTF8_X_L;
1923
1924     return is_utf8_common(p, &PL_utf8_X_L, "GCB=L");
1925 }
1926
1927 bool
1928 Perl_is_utf8_X_LV(pTHX_ const U8 *p)
1929 {
1930     dVAR;
1931
1932     PERL_ARGS_ASSERT_IS_UTF8_X_LV;
1933
1934     return is_utf8_common(p, &PL_utf8_X_LV, "GCB=LV");
1935 }
1936
1937 bool
1938 Perl_is_utf8_X_LVT(pTHX_ const U8 *p)
1939 {
1940     dVAR;
1941
1942     PERL_ARGS_ASSERT_IS_UTF8_X_LVT;
1943
1944     return is_utf8_common(p, &PL_utf8_X_LVT, "GCB=LVT");
1945 }
1946
1947 bool
1948 Perl_is_utf8_X_T(pTHX_ const U8 *p)
1949 {
1950     dVAR;
1951
1952     PERL_ARGS_ASSERT_IS_UTF8_X_T;
1953
1954     return is_utf8_common(p, &PL_utf8_X_T, "GCB=T");
1955 }
1956
1957 bool
1958 Perl_is_utf8_X_V(pTHX_ const U8 *p)
1959 {
1960     dVAR;
1961
1962     PERL_ARGS_ASSERT_IS_UTF8_X_V;
1963
1964     return is_utf8_common(p, &PL_utf8_X_V, "GCB=V");
1965 }
1966
1967 bool
1968 Perl_is_utf8_X_LV_LVT_V(pTHX_ const U8 *p)
1969 {
1970     dVAR;
1971
1972     PERL_ARGS_ASSERT_IS_UTF8_X_LV_LVT_V;
1973
1974     return is_utf8_common(p, &PL_utf8_X_LV_LVT_V, "_X_LV_LVT_V");
1975 }
1976
1977 /*
1978 =for apidoc to_utf8_case
1979
1980 The "p" contains the pointer to the UTF-8 string encoding
1981 the character that is being converted.
1982
1983 The "ustrp" is a pointer to the character buffer to put the
1984 conversion result to.  The "lenp" is a pointer to the length
1985 of the result.
1986
1987 The "swashp" is a pointer to the swash to use.
1988
1989 Both the special and normal mappings are stored in lib/unicore/To/Foo.pl,
1990 and loaded by SWASHNEW, using lib/utf8_heavy.pl.  The special (usually,
1991 but not always, a multicharacter mapping), is tried first.
1992
1993 The "special" is a string like "utf8::ToSpecLower", which means the
1994 hash %utf8::ToSpecLower.  The access to the hash is through
1995 Perl_to_utf8_case().
1996
1997 The "normal" is a string like "ToLower" which means the swash
1998 %utf8::ToLower.
1999
2000 =cut */
2001
2002 UV
2003 Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
2004                         SV **swashp, const char *normal, const char *special)
2005 {
2006     dVAR;
2007     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
2008     STRLEN len = 0;
2009     const UV uv0 = utf8_to_uvchr(p, NULL);
2010     /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
2011      * are necessary in EBCDIC, they are redundant no-ops
2012      * in ASCII-ish platforms, and hopefully optimized away. */
2013     const UV uv1 = NATIVE_TO_UNI(uv0);
2014
2015     PERL_ARGS_ASSERT_TO_UTF8_CASE;
2016
2017     /* Note that swash_fetch() doesn't output warnings for these because it
2018      * assumes we will */
2019     if (uv1 >= UNICODE_SURROGATE_FIRST) {
2020         if (uv1 <= UNICODE_SURROGATE_LAST) {
2021             if (ckWARN_d(WARN_SURROGATE)) {
2022                 const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
2023                 Perl_warner(aTHX_ packWARN(WARN_SURROGATE),
2024                     "Operation \"%s\" returns its argument for UTF-16 surrogate U+%04"UVXf"", desc, uv1);
2025             }
2026         }
2027         else if (UNICODE_IS_SUPER(uv1)) {
2028             if (ckWARN_d(WARN_NON_UNICODE)) {
2029                 const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
2030                 Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
2031                     "Operation \"%s\" returns its argument for non-Unicode code point 0x%04"UVXf"", desc, uv1);
2032             }
2033         }
2034
2035         /* Note that non-characters are perfectly legal, so no warning should
2036          * be given */
2037     }
2038
2039     uvuni_to_utf8(tmpbuf, uv1);
2040
2041     if (!*swashp) /* load on-demand */
2042          *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
2043
2044     if (special) {
2045          /* It might be "special" (sometimes, but not always,
2046           * a multicharacter mapping) */
2047          HV * const hv = get_hv(special, 0);
2048          SV **svp;
2049
2050          if (hv &&
2051              (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
2052              (*svp)) {
2053              const char *s;
2054
2055               s = SvPV_const(*svp, len);
2056               if (len == 1)
2057                    len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
2058               else {
2059 #ifdef EBCDIC
2060                    /* If we have EBCDIC we need to remap the characters
2061                     * since any characters in the low 256 are Unicode
2062                     * code points, not EBCDIC. */
2063                    U8 *t = (U8*)s, *tend = t + len, *d;
2064
2065                    d = tmpbuf;
2066                    if (SvUTF8(*svp)) {
2067                         STRLEN tlen = 0;
2068
2069                         while (t < tend) {
2070                              const UV c = utf8_to_uvchr(t, &tlen);
2071                              if (tlen > 0) {
2072                                   d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
2073                                   t += tlen;
2074                              }
2075                              else
2076                                   break;
2077                         }
2078                    }
2079                    else {
2080                         while (t < tend) {
2081                              d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
2082                              t++;
2083                         }
2084                    }
2085                    len = d - tmpbuf;
2086                    Copy(tmpbuf, ustrp, len, U8);
2087 #else
2088                    Copy(s, ustrp, len, U8);
2089 #endif
2090               }
2091          }
2092     }
2093
2094     if (!len && *swashp) {
2095         const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
2096
2097          if (uv2) {
2098               /* It was "normal" (a single character mapping). */
2099               const UV uv3 = UNI_TO_NATIVE(uv2);
2100               len = uvchr_to_utf8(ustrp, uv3) - ustrp;
2101          }
2102     }
2103
2104     if (!len) /* Neither: just copy.  In other words, there was no mapping
2105                  defined, which means that the code point maps to itself */
2106          len = uvchr_to_utf8(ustrp, uv0) - ustrp;
2107
2108     if (lenp)
2109          *lenp = len;
2110
2111     return len ? utf8_to_uvchr(ustrp, 0) : 0;
2112 }
2113
2114 STATIC UV
2115 S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result, U8* const ustrp, STRLEN *lenp)
2116 {
2117     /* This is called when changing the case of a utf8-encoded character above
2118      * the Latin1 range, and the operation is in locale.  If the result
2119      * contains a character that crosses the 255/256 boundary, disallow the
2120      * change, and return the original code point.  See L<perlfunc/lc> for why;
2121      *
2122      * p        points to the original string whose case was changed
2123      * result   the code point of the first character in the changed-case string
2124      * ustrp    points to the changed-case string (<result> represents its first char)
2125      * lenp     points to the length of <ustrp> */
2126
2127     UV original;    /* To store the first code point of <p> */
2128
2129     PERL_ARGS_ASSERT_CHECK_LOCALE_BOUNDARY_CROSSING;
2130
2131     assert(! UTF8_IS_INVARIANT(*p) && ! UTF8_IS_DOWNGRADEABLE_START(*p));
2132
2133     /* We know immediately if the first character in the string crosses the
2134      * boundary, so can skip */
2135     if (result > 255) {
2136
2137         /* Look at every character in the result; if any cross the
2138         * boundary, the whole thing is disallowed */
2139         U8* s = ustrp + UTF8SKIP(ustrp);
2140         U8* e = ustrp + *lenp;
2141         while (s < e) {
2142             if (UTF8_IS_INVARIANT(*s) || UTF8_IS_DOWNGRADEABLE_START(*s))
2143             {
2144                 goto bad_crossing;
2145             }
2146             s += UTF8SKIP(s);
2147         }
2148
2149         /* Here, no characters crossed, result is ok as-is */
2150         return result;
2151     }
2152
2153 bad_crossing:
2154
2155     /* Failed, have to return the original */
2156     original = utf8_to_uvchr(p, lenp);
2157     Copy(p, ustrp, *lenp, char);
2158     return original;
2159 }
2160
2161 /*
2162 =for apidoc to_utf8_upper
2163
2164 Convert the UTF-8 encoded character at p to its uppercase version and
2165 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
2166 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
2167 the uppercase version may be longer than the original character.
2168
2169 The first character of the uppercased version is returned
2170 (but note, as explained above, that there may be more.)
2171
2172 =cut */
2173
2174 /* Not currently externally documented, and subject to change:
2175  * <flags> is set iff locale semantics are to be used for code points < 256
2176  * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
2177  *               were used in the calculation; otherwise unchanged. */
2178
2179 UV
2180 Perl__to_utf8_upper_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr)
2181 {
2182     dVAR;
2183
2184     UV result;
2185
2186     PERL_ARGS_ASSERT__TO_UTF8_UPPER_FLAGS;
2187
2188     if (UTF8_IS_INVARIANT(*p)) {
2189         if (flags) {
2190             result = toUPPER_LC(*p);
2191         }
2192         else {
2193             return _to_upper_title_latin1(*p, ustrp, lenp, 'S');
2194         }
2195     }
2196     else if UTF8_IS_DOWNGRADEABLE_START(*p) {
2197         if (flags) {
2198             result = toUPPER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
2199         }
2200         else {
2201             return _to_upper_title_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
2202                                           ustrp, lenp, 'S');
2203         }
2204     }
2205     else {  /* utf8, ord above 255 */
2206         result = CALL_UPPER_CASE(p, ustrp, lenp);
2207
2208         if (flags) {
2209             result = check_locale_boundary_crossing(p, result, ustrp, lenp);
2210         }
2211         return result;
2212     }
2213
2214     /* Here, used locale rules.  Convert back to utf8 */
2215     if (UTF8_IS_INVARIANT(result)) {
2216         *ustrp = (U8) result;
2217         *lenp = 1;
2218     }
2219     else {
2220         *ustrp = UTF8_EIGHT_BIT_HI(result);
2221         *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result);
2222         *lenp = 2;
2223     }
2224
2225     if (tainted_ptr) {
2226         *tainted_ptr = TRUE;
2227     }
2228     return result;
2229 }
2230
2231 /*
2232 =for apidoc to_utf8_title
2233
2234 Convert the UTF-8 encoded character at p to its titlecase version and
2235 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
2236 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
2237 titlecase version may be longer than the original character.
2238
2239 The first character of the titlecased version is returned
2240 (but note, as explained above, that there may be more.)
2241
2242 =cut */
2243
2244 /* Not currently externally documented, and subject to change:
2245  * <flags> is set iff locale semantics are to be used for code points < 256
2246  *         Since titlecase is not defined in POSIX, uppercase is used instead
2247  *         for these/
2248  * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
2249  *               were used in the calculation; otherwise unchanged. */
2250
2251 UV
2252 Perl__to_utf8_title_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr)
2253 {
2254     dVAR;
2255
2256     UV result;
2257
2258     PERL_ARGS_ASSERT__TO_UTF8_TITLE_FLAGS;
2259
2260     if (UTF8_IS_INVARIANT(*p)) {
2261         if (flags) {
2262             result = toUPPER_LC(*p);
2263         }
2264         else {
2265             return _to_upper_title_latin1(*p, ustrp, lenp, 's');
2266         }
2267     }
2268     else if UTF8_IS_DOWNGRADEABLE_START(*p) {
2269         if (flags) {
2270             result = toUPPER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
2271         }
2272         else {
2273             return _to_upper_title_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
2274                                           ustrp, lenp, 's');
2275         }
2276     }
2277     else {  /* utf8, ord above 255 */
2278         result = CALL_TITLE_CASE(p, ustrp, lenp);
2279
2280         if (flags) {
2281             result = check_locale_boundary_crossing(p, result, ustrp, lenp);
2282         }
2283         return result;
2284     }
2285
2286     /* Here, used locale rules.  Convert back to utf8 */
2287     if (UTF8_IS_INVARIANT(result)) {
2288         *ustrp = (U8) result;
2289         *lenp = 1;
2290     }
2291     else {
2292         *ustrp = UTF8_EIGHT_BIT_HI(result);
2293         *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result);
2294         *lenp = 2;
2295     }
2296
2297     if (tainted_ptr) {
2298         *tainted_ptr = TRUE;
2299     }
2300     return result;
2301 }
2302
2303 /*
2304 =for apidoc to_utf8_lower
2305
2306 Convert the UTF-8 encoded character at p to its lowercase version and
2307 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
2308 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
2309 lowercase version may be longer than the original character.
2310
2311 The first character of the lowercased version is returned
2312 (but note, as explained above, that there may be more.)
2313
2314 =cut */
2315
2316 /* Not currently externally documented, and subject to change:
2317  * <flags> is set iff locale semantics are to be used for code points < 256
2318  * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
2319  *               were used in the calculation; otherwise unchanged. */
2320
2321 UV
2322 Perl__to_utf8_lower_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, const bool flags, bool* tainted_ptr)
2323 {
2324     UV result;
2325
2326     dVAR;
2327
2328     PERL_ARGS_ASSERT__TO_UTF8_LOWER_FLAGS;
2329
2330     if (UTF8_IS_INVARIANT(*p)) {
2331         if (flags) {
2332             result = toLOWER_LC(*p);
2333         }
2334         else {
2335             return to_lower_latin1(*p, ustrp, lenp);
2336         }
2337     }
2338     else if UTF8_IS_DOWNGRADEABLE_START(*p) {
2339         if (flags) {
2340             result = toLOWER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
2341         }
2342         else {
2343             return to_lower_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
2344                                    ustrp, lenp);
2345         }
2346     }
2347     else {  /* utf8, ord above 255 */
2348         result = CALL_LOWER_CASE(p, ustrp, lenp);
2349
2350         if (flags) {
2351             result = check_locale_boundary_crossing(p, result, ustrp, lenp);
2352         }
2353
2354         return result;
2355     }
2356
2357     /* Here, used locale rules.  Convert back to utf8 */
2358     if (UTF8_IS_INVARIANT(result)) {
2359         *ustrp = (U8) result;
2360         *lenp = 1;
2361     }
2362     else {
2363         *ustrp = UTF8_EIGHT_BIT_HI(result);
2364         *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result);
2365         *lenp = 2;
2366     }
2367
2368     if (tainted_ptr) {
2369         *tainted_ptr = TRUE;
2370     }
2371     return result;
2372 }
2373
2374 /*
2375 =for apidoc to_utf8_fold
2376
2377 Convert the UTF-8 encoded character at p to its foldcase version and
2378 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
2379 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
2380 foldcase version may be longer than the original character (up to
2381 three characters).
2382
2383 The first character of the foldcased version is returned
2384 (but note, as explained above, that there may be more.)
2385
2386 =cut */
2387
2388 /* Not currently externally documented, and subject to change,
2389  * in <flags>
2390  *      bit FOLD_FLAGS_LOCALE is set iff locale semantics are to be used for code
2391  *                            points < 256.  Since foldcase is not defined in
2392  *                            POSIX, lowercase is used instead
2393  *      bit FOLD_FLAGS_FULL   is set iff full case folds are to be used;
2394  *                            otherwise simple folds
2395  * <tainted_ptr> if non-null, *tainted_ptr will be set TRUE iff locale rules
2396  *               were used in the calculation; otherwise unchanged. */
2397
2398 UV
2399 Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags, bool* tainted_ptr)
2400 {
2401     dVAR;
2402
2403     UV result;
2404
2405     PERL_ARGS_ASSERT__TO_UTF8_FOLD_FLAGS;
2406
2407     if (UTF8_IS_INVARIANT(*p)) {
2408         if (flags & FOLD_FLAGS_LOCALE) {
2409             result = toLOWER_LC(*p);
2410         }
2411         else {
2412             return _to_fold_latin1(*p, ustrp, lenp,
2413                                    cBOOL(flags & FOLD_FLAGS_FULL));
2414         }
2415     }
2416     else if UTF8_IS_DOWNGRADEABLE_START(*p) {
2417         if (flags & FOLD_FLAGS_LOCALE) {
2418             result = toLOWER_LC(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
2419         }
2420         else {
2421             return _to_fold_latin1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)),
2422                                    ustrp, lenp, cBOOL(flags & FOLD_FLAGS_FULL));
2423         }
2424     }
2425     else {  /* utf8, ord above 255 */
2426         result = CALL_FOLD_CASE(p, ustrp, lenp, flags);
2427
2428         if ((flags & FOLD_FLAGS_LOCALE)) {
2429             result = check_locale_boundary_crossing(p, result, ustrp, lenp);
2430         }
2431
2432         return result;
2433     }
2434
2435     /* Here, used locale rules.  Convert back to utf8 */
2436     if (UTF8_IS_INVARIANT(result)) {
2437         *ustrp = (U8) result;
2438         *lenp = 1;
2439     }
2440     else {
2441         *ustrp = UTF8_EIGHT_BIT_HI(result);
2442         *(ustrp + 1) = UTF8_EIGHT_BIT_LO(result);
2443         *lenp = 2;
2444     }
2445
2446     if (tainted_ptr) {
2447         *tainted_ptr = TRUE;
2448     }
2449     return result;
2450 }
2451
2452 /* Note:
2453  * Returns a "swash" which is a hash described in utf8.c:S_swash_fetch().
2454  * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
2455  * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
2456  */
2457
2458 SV*
2459 Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
2460 {
2461     PERL_ARGS_ASSERT_SWASH_INIT;
2462
2463     /* Returns a copy of a swash initiated by the called function.  This is the
2464      * public interface, and returning a copy prevents others from doing
2465      * mischief on the original */
2466
2467     return newSVsv(_core_swash_init(pkg, name, listsv, minbits, none, FALSE, NULL, FALSE));
2468 }
2469
2470 SV*
2471 Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none, bool return_if_undef, SV* invlist, bool passed_in_invlist_has_user_defined_property)
2472 {
2473     /* Initialize and return a swash, creating it if necessary.  It does this
2474      * by calling utf8_heavy.pl in the general case.
2475      *
2476      * This interface should only be used by functions that won't destroy or
2477      * adversely change the swash, as doing so affects all other uses of the
2478      * swash in the program; the general public should use 'Perl_swash_init'
2479      * instead.
2480      *
2481      * pkg  is the name of the package that <name> should be in.
2482      * name is the name of the swash to find.  Typically it is a Unicode
2483      *      property name, including user-defined ones
2484      * listsv is a string to initialize the swash with.  It must be of the form
2485      *      documented as the subroutine return value in
2486      *      L<perlunicode/User-Defined Character Properties>
2487      * minbits is the number of bits required to represent each data element.
2488      *      It is '1' for binary properties.
2489      * none I (khw) do not understand this one, but it is used only in tr///.
2490      * return_if_undef is TRUE if the routine shouldn't croak if it can't find
2491      *      the requested property
2492      * invlist is an inversion list to initialize the swash with (or NULL)
2493      * has_user_defined_property is TRUE if <invlist> has some component that
2494      *      came from a user-defined property
2495      *
2496      * Thus there are three possible inputs to find the swash: <name>,
2497      * <listsv>, and <invlist>.  At least one must be specified.  The result
2498      * will be the union of the specified ones, although <listsv>'s various
2499      * actions can intersect, etc. what <name> gives.
2500      *
2501      * <invlist> is only valid for binary properties */
2502
2503     dVAR;
2504     SV* retval = &PL_sv_undef;
2505
2506     assert(listsv != &PL_sv_undef || strNE(name, "") || invlist);
2507     assert(! invlist || minbits == 1);
2508
2509     /* If data was passed in to go out to utf8_heavy to find the swash of, do
2510      * so */
2511     if (listsv != &PL_sv_undef || strNE(name, "")) {
2512         dSP;
2513         const size_t pkg_len = strlen(pkg);
2514         const size_t name_len = strlen(name);
2515         HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
2516         SV* errsv_save;
2517         GV *method;
2518
2519         PERL_ARGS_ASSERT__CORE_SWASH_INIT;
2520
2521         PUSHSTACKi(PERLSI_MAGIC);
2522         ENTER;
2523         SAVEHINTS();
2524         save_re_context();
2525         if (PL_parser && PL_parser->error_count)
2526             SAVEI8(PL_parser->error_count), PL_parser->error_count = 0;
2527         method = gv_fetchmeth(stash, "SWASHNEW", 8, -1);
2528         if (!method) {  /* demand load utf8 */
2529             ENTER;
2530             errsv_save = newSVsv(ERRSV);
2531             /* It is assumed that callers of this routine are not passing in
2532              * any user derived data.  */
2533             /* Need to do this after save_re_context() as it will set
2534              * PL_tainted to 1 while saving $1 etc (see the code after getrx:
2535              * in Perl_magic_get).  Even line to create errsv_save can turn on
2536              * PL_tainted.  */
2537             SAVEBOOL(PL_tainted);
2538             PL_tainted = 0;
2539             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
2540                              NULL);
2541             if (!SvTRUE(ERRSV))
2542                 sv_setsv(ERRSV, errsv_save);
2543             SvREFCNT_dec(errsv_save);
2544             LEAVE;
2545         }
2546         SPAGAIN;
2547         PUSHMARK(SP);
2548         EXTEND(SP,5);
2549         mPUSHp(pkg, pkg_len);
2550         mPUSHp(name, name_len);
2551         PUSHs(listsv);
2552         mPUSHi(minbits);
2553         mPUSHi(none);
2554         PUTBACK;
2555         errsv_save = newSVsv(ERRSV);
2556         /* If we already have a pointer to the method, no need to use
2557          * call_method() to repeat the lookup.  */
2558         if (method ? call_sv(MUTABLE_SV(method), G_SCALAR)
2559             : call_sv(newSVpvs_flags("SWASHNEW", SVs_TEMP), G_SCALAR | G_METHOD))
2560         {
2561             retval = *PL_stack_sp--;
2562             SvREFCNT_inc(retval);
2563         }
2564         if (!SvTRUE(ERRSV))
2565             sv_setsv(ERRSV, errsv_save);
2566         SvREFCNT_dec(errsv_save);
2567         LEAVE;
2568         POPSTACK;
2569         if (IN_PERL_COMPILETIME) {
2570             CopHINTS_set(PL_curcop, PL_hints);
2571         }
2572         if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
2573             if (SvPOK(retval))
2574
2575                 /* If caller wants to handle missing properties, let them */
2576                 if (return_if_undef) {
2577                     return NULL;
2578                 }
2579                 Perl_croak(aTHX_
2580                            "Can't find Unicode property definition \"%"SVf"\"",
2581                            SVfARG(retval));
2582             Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
2583         }
2584     } /* End of calling the module to find the swash */
2585
2586     /* Make sure there is an inversion list for binary properties */
2587     if (minbits == 1) {
2588         SV** swash_invlistsvp = NULL;
2589         SV* swash_invlist = NULL;
2590         bool invlist_in_swash_is_valid = FALSE;
2591         HV* swash_hv;
2592
2593         /* If this operation fetched a swash, get its already existing
2594          * inversion list or create one for it */
2595         if (retval != &PL_sv_undef) {
2596             swash_hv = MUTABLE_HV(SvRV(retval));
2597
2598             swash_invlistsvp = hv_fetchs(swash_hv, "INVLIST", FALSE);
2599             if (swash_invlistsvp) {
2600                 swash_invlist = *swash_invlistsvp;
2601                 invlist_in_swash_is_valid = TRUE;
2602             }
2603             else {
2604                 swash_invlist = _swash_to_invlist(retval);
2605             }
2606         }
2607
2608         /* If an inversion list was passed in, have to include it */
2609         if (invlist) {
2610
2611             /* Any fetched swash will by now have an inversion list in it;
2612              * otherwise <swash_invlist>  will be NULL, indicating that we
2613              * didn't fetch a swash */
2614             if (swash_invlist) {
2615
2616                 /* Add the passed-in inversion list, which invalidates the one
2617                  * already stored in the swash */
2618                 invlist_in_swash_is_valid = FALSE;
2619                 _invlist_union(invlist, swash_invlist, &swash_invlist);
2620             }
2621             else {
2622
2623                 /* Here, there is no swash already.  Set up a minimal one */
2624                 swash_hv = newHV();
2625                 retval = newRV_inc(MUTABLE_SV(swash_hv));
2626                 swash_invlist = invlist;
2627             }
2628
2629             if (passed_in_invlist_has_user_defined_property) {
2630                 if (! hv_stores(swash_hv, "USER_DEFINED", newSVuv(1))) {
2631                     Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
2632                 }
2633             }
2634         }
2635
2636         /* Here, we have computed the union of all the passed-in data.  It may
2637          * be that there was an inversion list in the swash which didn't get
2638          * touched; otherwise save the one computed one */
2639         if (! invlist_in_swash_is_valid) {
2640             if (! hv_stores(MUTABLE_HV(SvRV(retval)), "INVLIST", swash_invlist))
2641             {
2642                 Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
2643             }
2644         }
2645     }
2646
2647     return retval;
2648 }
2649
2650
2651 /* This API is wrong for special case conversions since we may need to
2652  * return several Unicode characters for a single Unicode character
2653  * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
2654  * the lower-level routine, and it is similarly broken for returning
2655  * multiple values.  --jhi
2656  * For those, you should use to_utf8_case() instead */
2657 /* Now SWASHGET is recasted into S_swatch_get in this file. */
2658
2659 /* Note:
2660  * Returns the value of property/mapping C<swash> for the first character
2661  * of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
2662  * assumed to be in utf8. If C<do_utf8> is false, the string C<ptr> is
2663  * assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
2664  *
2665  * A "swash" is a hash which contains initially the keys/values set up by
2666  * SWASHNEW.  The purpose is to be able to completely represent a Unicode
2667  * property for all possible code points.  Things are stored in a compact form
2668  * (see utf8_heavy.pl) so that calculation is required to find the actual
2669  * property value for a given code point.  As code points are looked up, new
2670  * key/value pairs are added to the hash, so that the calculation doesn't have
2671  * to ever be re-done.  Further, each calculation is done, not just for the
2672  * desired one, but for a whole block of code points adjacent to that one.
2673  * For binary properties on ASCII machines, the block is usually for 64 code
2674  * points, starting with a code point evenly divisible by 64.  Thus if the
2675  * property value for code point 257 is requested, the code goes out and
2676  * calculates the property values for all 64 code points between 256 and 319,
2677  * and stores these as a single 64-bit long bit vector, called a "swatch",
2678  * under the key for code point 256.  The key is the UTF-8 encoding for code
2679  * point 256, minus the final byte.  Thus, if the length of the UTF-8 encoding
2680  * for a code point is 13 bytes, the key will be 12 bytes long.  If the value
2681  * for code point 258 is then requested, this code realizes that it would be
2682  * stored under the key for 256, and would find that value and extract the
2683  * relevant bit, offset from 256.
2684  *
2685  * Non-binary properties are stored in as many bits as necessary to represent
2686  * their values (32 currently, though the code is more general than that), not
2687  * as single bits, but the principal is the same: the value for each key is a
2688  * vector that encompasses the property values for all code points whose UTF-8
2689  * representations are represented by the key.  That is, for all code points
2690  * whose UTF-8 representations are length N bytes, and the key is the first N-1
2691  * bytes of that.
2692  */
2693 UV
2694 Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
2695 {
2696     dVAR;
2697     HV *const hv = MUTABLE_HV(SvRV(swash));
2698     U32 klen;
2699     U32 off;
2700     STRLEN slen;
2701     STRLEN needents;
2702     const U8 *tmps = NULL;
2703     U32 bit;
2704     SV *swatch;
2705     U8 tmputf8[2];
2706     const UV c = NATIVE_TO_ASCII(*ptr);
2707
2708     PERL_ARGS_ASSERT_SWASH_FETCH;
2709
2710     /* Convert to utf8 if not already */
2711     if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
2712         tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
2713         tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
2714         ptr = tmputf8;
2715     }
2716     /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
2717      * then the "swatch" is a vec() for all the chars which start
2718      * with 0xAA..0xYY
2719      * So the key in the hash (klen) is length of encoded char -1
2720      */
2721     klen = UTF8SKIP(ptr) - 1;
2722     off  = ptr[klen];
2723
2724     if (klen == 0) {
2725       /* If char is invariant then swatch is for all the invariant chars
2726        * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
2727        */
2728         needents = UTF_CONTINUATION_MARK;
2729         off      = NATIVE_TO_UTF(ptr[klen]);
2730     }
2731     else {
2732       /* If char is encoded then swatch is for the prefix */
2733         needents = (1 << UTF_ACCUMULATION_SHIFT);
2734         off      = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
2735     }
2736
2737     /*
2738      * This single-entry cache saves about 1/3 of the utf8 overhead in test
2739      * suite.  (That is, only 7-8% overall over just a hash cache.  Still,
2740      * it's nothing to sniff at.)  Pity we usually come through at least
2741      * two function calls to get here...
2742      *
2743      * NB: this code assumes that swatches are never modified, once generated!
2744      */
2745
2746     if (hv   == PL_last_swash_hv &&
2747         klen == PL_last_swash_klen &&
2748         (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
2749     {
2750         tmps = PL_last_swash_tmps;
2751         slen = PL_last_swash_slen;
2752     }
2753     else {
2754         /* Try our second-level swatch cache, kept in a hash. */
2755         SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE);
2756
2757         /* If not cached, generate it via swatch_get */
2758         if (!svp || !SvPOK(*svp)
2759                  || !(tmps = (const U8*)SvPV_const(*svp, slen))) {
2760             /* We use utf8n_to_uvuni() as we want an index into
2761                Unicode tables, not a native character number.
2762              */
2763             const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
2764                                            ckWARN(WARN_UTF8) ?
2765                                            0 : UTF8_ALLOW_ANY);
2766             swatch = swatch_get(swash,
2767                     /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
2768                                 (klen) ? (code_point & ~((UV)needents - 1)) : 0,
2769                                 needents);
2770
2771             if (IN_PERL_COMPILETIME)
2772                 CopHINTS_set(PL_curcop, PL_hints);
2773
2774             svp = hv_store(hv, (const char *)ptr, klen, swatch, 0);
2775
2776             if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
2777                      || (slen << 3) < needents)
2778                 Perl_croak(aTHX_ "panic: swash_fetch got improper swatch");
2779         }
2780
2781         PL_last_swash_hv = hv;
2782         assert(klen <= sizeof(PL_last_swash_key));
2783         PL_last_swash_klen = (U8)klen;
2784         /* FIXME change interpvar.h?  */
2785         PL_last_swash_tmps = (U8 *) tmps;
2786         PL_last_swash_slen = slen;
2787         if (klen)
2788             Copy(ptr, PL_last_swash_key, klen, U8);
2789     }
2790
2791     if (UTF8_IS_SUPER(ptr) && ckWARN_d(WARN_NON_UNICODE)) {
2792         SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
2793
2794         /* This outputs warnings for binary properties only, assuming that
2795          * to_utf8_case() will output any for non-binary.  Also, surrogates
2796          * aren't checked for, as that would warn on things like /\p{Gc=Cs}/ */
2797
2798         if (! bitssvp || SvUV(*bitssvp) == 1) {
2799             /* User-defined properties can silently match above-Unicode */
2800             SV** const user_defined_svp = hv_fetchs(hv, "USER_DEFINED", FALSE);
2801             if (! user_defined_svp || ! SvUV(*user_defined_svp)) {
2802                 const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0, 0);
2803                 Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
2804                     "Code point 0x%04"UVXf" is not Unicode, all \\p{} matches fail; all \\P{} matches succeed", code_point);
2805             }
2806         }
2807     }
2808
2809     switch ((int)((slen << 3) / needents)) {
2810     case 1:
2811         bit = 1 << (off & 7);
2812         off >>= 3;
2813         return (tmps[off] & bit) != 0;
2814     case 8:
2815         return tmps[off];
2816     case 16:
2817         off <<= 1;
2818         return (tmps[off] << 8) + tmps[off + 1] ;
2819     case 32:
2820         off <<= 2;
2821         return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
2822     }
2823     Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width");
2824     NORETURN_FUNCTION_END;
2825 }
2826
2827 /* Read a single line of the main body of the swash input text.  These are of
2828  * the form:
2829  * 0053 0056    0073
2830  * where each number is hex.  The first two numbers form the minimum and
2831  * maximum of a range, and the third is the value associated with the range.
2832  * Not all swashes should have a third number
2833  *
2834  * On input: l    points to the beginning of the line to be examined; it points
2835  *                to somewhere in the string of the whole input text, and is
2836  *                terminated by a \n or the null string terminator.
2837  *           lend   points to the null terminator of that string
2838  *           wants_value    is non-zero if the swash expects a third number
2839  *           typestr is the name of the swash's mapping, like 'ToLower'
2840  * On output: *min, *max, and *val are set to the values read from the line.
2841  *            returns a pointer just beyond the line examined.  If there was no
2842  *            valid min number on the line, returns lend+1
2843  */
2844
2845 STATIC U8*
2846 S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val,
2847                              const bool wants_value, const U8* const typestr)
2848 {
2849     const int  typeto  = typestr[0] == 'T' && typestr[1] == 'o';
2850     STRLEN numlen;          /* Length of the number */
2851     I32 flags = PERL_SCAN_SILENT_ILLDIGIT
2852                 | PERL_SCAN_DISALLOW_PREFIX
2853                 | PERL_SCAN_SILENT_NON_PORTABLE;
2854
2855     /* nl points to the next \n in the scan */
2856     U8* const nl = (U8*)memchr(l, '\n', lend - l);
2857
2858     /* Get the first number on the line: the range minimum */
2859     numlen = lend - l;
2860     *min = grok_hex((char *)l, &numlen, &flags, NULL);
2861     if (numlen)     /* If found a hex number, position past it */
2862         l += numlen;
2863     else if (nl) {          /* Else, go handle next line, if any */
2864         return nl + 1;  /* 1 is length of "\n" */
2865     }
2866     else {              /* Else, no next line */
2867         return lend + 1;        /* to LIST's end at which \n is not found */
2868     }
2869
2870     /* The max range value follows, separated by a BLANK */
2871     if (isBLANK(*l)) {
2872         ++l;
2873         flags = PERL_SCAN_SILENT_ILLDIGIT
2874                 | PERL_SCAN_DISALLOW_PREFIX
2875                 | PERL_SCAN_SILENT_NON_PORTABLE;
2876         numlen = lend - l;
2877         *max = grok_hex((char *)l, &numlen, &flags, NULL);
2878         if (numlen)
2879             l += numlen;
2880         else    /* If no value here, it is a single element range */
2881             *max = *min;
2882
2883         /* Non-binary tables have a third entry: what the first element of the
2884          * range maps to */
2885         if (wants_value) {
2886             if (isBLANK(*l)) {
2887                 ++l;
2888                 flags = PERL_SCAN_SILENT_ILLDIGIT
2889                       | PERL_SCAN_DISALLOW_PREFIX
2890                       | PERL_SCAN_SILENT_NON_PORTABLE;
2891                 numlen = lend - l;
2892                 *val = grok_hex((char *)l, &numlen, &flags, NULL);
2893                 if (numlen)
2894                     l += numlen;
2895                 else
2896                     *val = 0;
2897             }
2898             else {
2899                 *val = 0;
2900                 if (typeto) {
2901                     /* diag_listed_as: To%s: illegal mapping '%s' */
2902                     Perl_croak(aTHX_ "%s: illegal mapping '%s'",
2903                                      typestr, l);
2904                 }
2905             }
2906         }
2907         else
2908             *val = 0; /* bits == 1, then any val should be ignored */
2909     }
2910     else { /* Nothing following range min, should be single element with no
2911               mapping expected */
2912         *max = *min;
2913         if (wants_value) {
2914             *val = 0;
2915             if (typeto) {
2916                 /* diag_listed_as: To%s: illegal mapping '%s' */
2917                 Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
2918             }
2919         }
2920         else
2921             *val = 0; /* bits == 1, then val should be ignored */
2922     }
2923
2924     /* Position to next line if any, or EOF */
2925     if (nl)
2926         l = nl + 1;
2927     else
2928         l = lend;
2929
2930     return l;
2931 }
2932
2933 /* Note:
2934  * Returns a swatch (a bit vector string) for a code point sequence
2935  * that starts from the value C<start> and comprises the number C<span>.
2936  * A C<swash> must be an object created by SWASHNEW (see lib/utf8_heavy.pl).
2937  * Should be used via swash_fetch, which will cache the swatch in C<swash>.
2938  */
2939 STATIC SV*
2940 S_swatch_get(pTHX_ SV* swash, UV start, UV span)
2941 {
2942     SV *swatch;
2943     U8 *l, *lend, *x, *xend, *s, *send;
2944     STRLEN lcur, xcur, scur;
2945     HV *const hv = MUTABLE_HV(SvRV(swash));
2946     SV** const invlistsvp = hv_fetchs(hv, "INVLIST", FALSE);
2947
2948     SV** listsvp; /* The string containing the main body of the table */
2949     SV** extssvp;
2950     SV** invert_it_svp;
2951     U8* typestr;
2952     STRLEN bits;
2953     STRLEN octets; /* if bits == 1, then octets == 0 */
2954     UV  none;
2955     UV  end = start + span;
2956
2957     if (invlistsvp == NULL) {
2958         SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
2959         SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
2960         SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
2961         extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
2962         listsvp = hv_fetchs(hv, "LIST", FALSE);
2963         invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
2964
2965         bits  = SvUV(*bitssvp);
2966         none  = SvUV(*nonesvp);
2967         typestr = (U8*)SvPV_nolen(*typesvp);
2968     }
2969     else {
2970         bits = 1;
2971         none = 0;
2972     }
2973     octets = bits >> 3; /* if bits == 1, then octets == 0 */
2974
2975     PERL_ARGS_ASSERT_SWATCH_GET;
2976
2977     if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
2978         Perl_croak(aTHX_ "panic: swatch_get doesn't expect bits %"UVuf,
2979                                                  (UV)bits);
2980     }
2981
2982     /* If overflowed, use the max possible */
2983     if (end < start) {
2984         end = UV_MAX;
2985         span = end - start;
2986     }
2987
2988     /* create and initialize $swatch */
2989     scur   = octets ? (span * octets) : (span + 7) / 8;
2990     swatch = newSV(scur);
2991     SvPOK_on(swatch);
2992     s = (U8*)SvPVX(swatch);
2993     if (octets && none) {
2994         const U8* const e = s + scur;
2995         while (s < e) {
2996             if (bits == 8)
2997                 *s++ = (U8)(none & 0xff);
2998             else if (bits == 16) {
2999                 *s++ = (U8)((none >>  8) & 0xff);
3000                 *s++ = (U8)( none        & 0xff);
3001             }
3002             else if (bits == 32) {
3003                 *s++ = (U8)((none >> 24) & 0xff);
3004                 *s++ = (U8)((none >> 16) & 0xff);
3005                 *s++ = (U8)((none >>  8) & 0xff);
3006                 *s++ = (U8)( none        & 0xff);
3007             }
3008         }
3009         *s = '\0';
3010     }
3011     else {
3012         (void)memzero((U8*)s, scur + 1);
3013     }
3014     SvCUR_set(swatch, scur);
3015     s = (U8*)SvPVX(swatch);
3016
3017     if (invlistsvp) {   /* If has an inversion list set up use that */
3018         _invlist_populate_swatch(*invlistsvp, start, end, s);
3019         return swatch;
3020     }
3021
3022     /* read $swash->{LIST} */
3023     l = (U8*)SvPV(*listsvp, lcur);
3024     lend = l + lcur;
3025     while (l < lend) {
3026         UV min, max, val, upper;
3027         l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
3028                                          cBOOL(octets), typestr);
3029         if (l > lend) {
3030             break;
3031         }
3032
3033         /* If looking for something beyond this range, go try the next one */
3034         if (max < start)
3035             continue;
3036
3037         /* <end> is generally 1 beyond where we want to set things, but at the
3038          * platform's infinity, where we can't go any higher, we want to
3039          * include the code point at <end> */
3040         upper = (max < end)
3041                 ? max
3042                 : (max != UV_MAX || end != UV_MAX)
3043                   ? end - 1
3044                   : end;
3045
3046         if (octets) {
3047             UV key;
3048             if (min < start) {
3049                 if (!none || val < none) {
3050                     val += start - min;
3051                 }
3052                 min = start;
3053             }
3054             for (key = min; key <= upper; key++) {
3055                 STRLEN offset;
3056                 /* offset must be non-negative (start <= min <= key < end) */
3057                 offset = octets * (key - start);
3058                 if (bits == 8)
3059                     s[offset] = (U8)(val & 0xff);
3060                 else if (bits == 16) {
3061                     s[offset    ] = (U8)((val >>  8) & 0xff);
3062                     s[offset + 1] = (U8)( val        & 0xff);
3063                 }
3064                 else if (bits == 32) {
3065                     s[offset    ] = (U8)((val >> 24) & 0xff);
3066                     s[offset + 1] = (U8)((val >> 16) & 0xff);
3067                     s[offset + 2] = (U8)((val >>  8) & 0xff);
3068                     s[offset + 3] = (U8)( val        & 0xff);
3069                 }
3070
3071                 if (!none || val < none)
3072                     ++val;
3073             }
3074         }
3075         else { /* bits == 1, then val should be ignored */
3076             UV key;
3077             if (min < start)
3078                 min = start;
3079
3080             for (key = min; key <= upper; key++) {
3081                 const STRLEN offset = (STRLEN)(key - start);
3082                 s[offset >> 3] |= 1 << (offset & 7);
3083             }
3084         }
3085     } /* while */
3086
3087     /* Invert if the data says it should be.  Assumes that bits == 1 */
3088     if (invert_it_svp && SvUV(*invert_it_svp)) {
3089
3090         /* Unicode properties should come with all bits above PERL_UNICODE_MAX
3091          * be 0, and their inversion should also be 0, as we don't succeed any
3092          * Unicode property matches for non-Unicode code points */
3093         if (start <= PERL_UNICODE_MAX) {
3094
3095             /* The code below assumes that we never cross the
3096              * Unicode/above-Unicode boundary in a range, as otherwise we would
3097              * have to figure out where to stop flipping the bits.  Since this
3098              * boundary is divisible by a large power of 2, and swatches comes
3099              * in small powers of 2, this should be a valid assumption */
3100             assert(start + span - 1 <= PERL_UNICODE_MAX);
3101
3102             send = s + scur;
3103             while (s < send) {
3104                 *s = ~(*s);
3105                 s++;
3106             }
3107         }
3108     }
3109
3110     /* read $swash->{EXTRAS}
3111      * This code also copied to swash_to_invlist() below */
3112     x = (U8*)SvPV(*extssvp, xcur);
3113     xend = x + xcur;
3114     while (x < xend) {
3115         STRLEN namelen;
3116         U8 *namestr;
3117         SV** othersvp;
3118         HV* otherhv;
3119         STRLEN otherbits;
3120         SV **otherbitssvp, *other;
3121         U8 *s, *o, *nl;
3122         STRLEN slen, olen;
3123
3124         const U8 opc = *x++;
3125         if (opc == '\n')
3126             continue;
3127
3128         nl = (U8*)memchr(x, '\n', xend - x);
3129
3130         if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
3131             if (nl) {
3132                 x = nl + 1; /* 1 is length of "\n" */
3133                 continue;
3134             }
3135             else {
3136                 x = xend; /* to EXTRAS' end at which \n is not found */
3137                 break;
3138             }
3139         }
3140
3141         namestr = x;
3142         if (nl) {
3143             namelen = nl - namestr;
3144             x = nl + 1;
3145         }
3146         else {
3147             namelen = xend - namestr;
3148             x = xend;
3149         }
3150
3151         othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
3152         otherhv = MUTABLE_HV(SvRV(*othersvp));
3153         otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
3154         otherbits = (STRLEN)SvUV(*otherbitssvp);
3155         if (bits < otherbits)
3156             Perl_croak(aTHX_ "panic: swatch_get found swatch size mismatch");
3157
3158         /* The "other" swatch must be destroyed after. */
3159         other = swatch_get(*othersvp, start, span);
3160         o = (U8*)SvPV(other, olen);
3161
3162         if (!olen)
3163             Perl_croak(aTHX_ "panic: swatch_get got improper swatch");
3164
3165         s = (U8*)SvPV(swatch, slen);
3166         if (bits == 1 && otherbits == 1) {
3167             if (slen != olen)
3168                 Perl_croak(aTHX_ "panic: swatch_get found swatch length mismatch");
3169
3170             switch (opc) {
3171             case '+':
3172                 while (slen--)
3173                     *s++ |= *o++;
3174                 break;
3175             case '!':
3176                 while (slen--)
3177                     *s++ |= ~*o++;
3178                 break;
3179             case '-':
3180                 while (slen--)
3181                     *s++ &= ~*o++;
3182                 break;
3183             case '&':
3184                 while (slen--)
3185                     *s++ &= *o++;
3186                 break;
3187             default:
3188                 break;
3189             }
3190         }
3191         else {
3192             STRLEN otheroctets = otherbits >> 3;
3193             STRLEN offset = 0;
3194             U8* const send = s + slen;
3195
3196             while (s < send) {
3197                 UV otherval = 0;
3198
3199                 if (otherbits == 1) {
3200                     otherval = (o[offset >> 3] >> (offset & 7)) & 1;
3201                     ++offset;
3202                 }
3203                 else {
3204                     STRLEN vlen = otheroctets;
3205                     otherval = *o++;
3206                     while (--vlen) {
3207                         otherval <<= 8;
3208                         otherval |= *o++;
3209                     }
3210                 }
3211
3212                 if (opc == '+' && otherval)
3213                     NOOP;   /* replace with otherval */
3214                 else if (opc == '!' && !otherval)
3215                     otherval = 1;
3216                 else if (opc == '-' && otherval)
3217                     otherval = 0;
3218                 else if (opc == '&' && !otherval)
3219                     otherval = 0;
3220                 else {
3221                     s += octets; /* no replacement */
3222                     continue;
3223                 }
3224
3225                 if (bits == 8)
3226                     *s++ = (U8)( otherval & 0xff);
3227                 else if (bits == 16) {
3228                     *s++ = (U8)((otherval >>  8) & 0xff);
3229                     *s++ = (U8)( otherval        & 0xff);
3230                 }
3231                 else if (bits == 32) {
3232                     *s++ = (U8)((otherval >> 24) & 0xff);
3233                     *s++ = (U8)((otherval >> 16) & 0xff);
3234                     *s++ = (U8)((otherval >>  8) & 0xff);
3235                     *s++ = (U8)( otherval        & 0xff);
3236                 }
3237             }
3238         }
3239         sv_free(other); /* through with it! */
3240     } /* while */
3241     return swatch;
3242 }
3243
3244 HV*
3245 Perl__swash_inversion_hash(pTHX_ SV* const swash)
3246 {
3247
3248    /* Subject to change or removal.  For use only in one place in regcomp.c.
3249     * Can't be used on a property that is subject to user override, as it
3250     * relies on the value of SPECIALS in the swash which would be set by
3251     * utf8_heavy.pl to the hash in the non-overriden file, and hence is not set
3252     * for overridden properties
3253     *
3254     * Returns a hash which is the inversion and closure of a swash mapping.
3255     * For example, consider the input lines:
3256     * 004B              006B
3257     * 004C              006C
3258     * 212A              006B
3259     *
3260     * The returned hash would have two keys, the utf8 for 006B and the utf8 for
3261     * 006C.  The value for each key is an array.  For 006C, the array would
3262     * have a two elements, the utf8 for itself, and for 004C.  For 006B, there
3263     * would be three elements in its array, the utf8 for 006B, 004B and 212A.
3264     *
3265     * Essentially, for any code point, it gives all the code points that map to
3266     * it, or the list of 'froms' for that point.
3267     *
3268     * Currently it ignores any additions or deletions from other swashes,
3269     * looking at just the main body of the swash, and if there are SPECIALS
3270     * in the swash, at that hash
3271     *
3272     * The specials hash can be extra code points, and most likely consists of
3273     * maps from single code points to multiple ones (each expressed as a string
3274     * of utf8 characters).   This function currently returns only 1-1 mappings.
3275     * However consider this possible input in the specials hash:
3276     * "\xEF\xAC\x85" => "\x{0073}\x{0074}",         # U+FB05 => 0073 0074
3277     * "\xEF\xAC\x86" => "\x{0073}\x{0074}",         # U+FB06 => 0073 0074
3278     *
3279     * Both FB05 and FB06 map to the same multi-char sequence, which we don't
3280     * currently handle.  But it also means that FB05 and FB06 are equivalent in
3281     * a 1-1 mapping which we should handle, and this relationship may not be in
3282     * the main table.  Therefore this function examines all the multi-char
3283     * sequences and adds the 1-1 mappings that come out of that.  */
3284
3285     U8 *l, *lend;
3286     STRLEN lcur;
3287     HV *const hv = MUTABLE_HV(SvRV(swash));
3288
3289     /* The string containing the main body of the table */
3290     SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
3291
3292     SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
3293     SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
3294     SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
3295     /*SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);*/
3296     const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
3297     const STRLEN bits  = SvUV(*bitssvp);
3298     const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
3299     const UV     none  = SvUV(*nonesvp);
3300     SV **specials_p = hv_fetchs(hv, "SPECIALS", 0);
3301
3302     HV* ret = newHV();
3303
3304     PERL_ARGS_ASSERT__SWASH_INVERSION_HASH;
3305
3306     /* Must have at least 8 bits to get the mappings */
3307     if (bits != 8 && bits != 16 && bits != 32) {
3308         Perl_croak(aTHX_ "panic: swash_inversion_hash doesn't expect bits %"UVuf,
3309                                                  (UV)bits);
3310     }
3311
3312     if (specials_p) { /* It might be "special" (sometimes, but not always, a
3313                         mapping to more than one character */
3314
3315         /* Construct an inverse mapping hash for the specials */
3316         HV * const specials_hv = MUTABLE_HV(SvRV(*specials_p));
3317         HV * specials_inverse = newHV();
3318         char *char_from; /* the lhs of the map */
3319         I32 from_len;   /* its byte length */
3320         char *char_to;  /* the rhs of the map */
3321         I32 to_len;     /* its byte length */
3322         SV *sv_to;      /* and in a sv */
3323         AV* from_list;  /* list of things that map to each 'to' */
3324
3325         hv_iterinit(specials_hv);
3326
3327         /* The keys are the characters (in utf8) that map to the corresponding
3328          * utf8 string value.  Iterate through the list creating the inverse
3329          * list. */
3330         while ((sv_to = hv_iternextsv(specials_hv, &char_from, &from_len))) {
3331             SV** listp;
3332             if (! SvPOK(sv_to)) {
3333                 Perl_croak(aTHX_ "panic: value returned from hv_iternextsv() unexpectedly is not a string");
3334             }
3335             /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Found mapping from %"UVXf", First char of to is %"UVXf"\n", utf8_to_uvchr((U8*) char_from, 0), utf8_to_uvchr((U8*) SvPVX(sv_to), 0)));*/
3336
3337             /* Each key in the inverse list is a mapped-to value, and the key's
3338              * hash value is a list of the strings (each in utf8) that map to
3339              * it.  Those strings are all one character long */
3340             if ((listp = hv_fetch(specials_inverse,
3341                                     SvPVX(sv_to),
3342                                     SvCUR(sv_to), 0)))
3343             {
3344                 from_list = (AV*) *listp;
3345             }
3346             else { /* No entry yet for it: create one */
3347                 from_list = newAV();
3348                 if (! hv_store(specials_inverse,
3349                                 SvPVX(sv_to),
3350                                 SvCUR(sv_to),
3351                                 (SV*) from_list, 0))
3352                 {
3353                     Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
3354                 }
3355             }
3356
3357             /* Here have the list associated with this 'to' (perhaps newly
3358              * created and empty).  Just add to it.  Note that we ASSUME that
3359              * the input is guaranteed to not have duplications, so we don't
3360              * check for that.  Duplications just slow down execution time. */
3361             av_push(from_list, newSVpvn_utf8(char_from, from_len, TRUE));
3362         }
3363
3364         /* Here, 'specials_inverse' contains the inverse mapping.  Go through
3365          * it looking for cases like the FB05/FB06 examples above.  There would
3366          * be an entry in the hash like
3367         *       'st' => [ FB05, FB06 ]
3368         * In this example we will create two lists that get stored in the
3369         * returned hash, 'ret':
3370         *       FB05 => [ FB05, FB06 ]
3371         *       FB06 => [ FB05, FB06 ]
3372         *
3373         * Note that there is nothing to do if the array only has one element.
3374         * (In the normal 1-1 case handled below, we don't have to worry about
3375         * two lists, as everything gets tied to the single list that is
3376         * generated for the single character 'to'.  But here, we are omitting
3377         * that list, ('st' in the example), so must have multiple lists.) */
3378         while ((from_list = (AV *) hv_iternextsv(specials_inverse,
3379                                                  &char_to, &to_len)))
3380         {
3381             if (av_len(from_list) > 0) {
3382                 int i;
3383
3384                 /* We iterate over all combinations of i,j to place each code
3385                  * point on each list */
3386                 for (i = 0; i <= av_len(from_list); i++) {
3387                     int j;
3388                     AV* i_list = newAV();
3389                     SV** entryp = av_fetch(from_list, i, FALSE);
3390                     if (entryp == NULL) {
3391                         Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
3392                     }
3393                     if (hv_fetch(ret, SvPVX(*entryp), SvCUR(*entryp), FALSE)) {
3394                         Perl_croak(aTHX_ "panic: unexpected entry for %s", SvPVX(*entryp));
3395                     }
3396                     if (! hv_store(ret, SvPVX(*entryp), SvCUR(*entryp),
3397                                    (SV*) i_list, FALSE))
3398                     {
3399                         Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
3400                     }
3401
3402                     /* For debugging: UV u = utf8_to_uvchr((U8*) SvPVX(*entryp), 0);*/
3403                     for (j = 0; j <= av_len(from_list); j++) {
3404                         entryp = av_fetch(from_list, j, FALSE);
3405                         if (entryp == NULL) {
3406                             Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
3407                         }
3408
3409                         /* When i==j this adds itself to the list */
3410                         av_push(i_list, newSVuv(utf8_to_uvchr(
3411                                                 (U8*) SvPVX(*entryp), 0)));
3412                         /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Adding %"UVXf" to list for %"UVXf"\n", utf8_to_uvchr((U8*) SvPVX(*entryp), 0), u));*/
3413                     }
3414                 }
3415             }
3416         }
3417         SvREFCNT_dec(specials_inverse); /* done with it */
3418     } /* End of specials */
3419
3420     /* read $swash->{LIST} */
3421     l = (U8*)SvPV(*listsvp, lcur);
3422     lend = l + lcur;
3423
3424     /* Go through each input line */
3425     while (l < lend) {
3426         UV min, max, val;
3427         UV inverse;
3428         l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
3429                                          cBOOL(octets), typestr);
3430         if (l > lend) {
3431             break;
3432         }
3433
3434         /* Each element in the range is to be inverted */
3435         for (inverse = min; inverse <= max; inverse++) {
3436             AV* list;
3437             SV** listp;
3438             IV i;
3439             bool found_key = FALSE;
3440             bool found_inverse = FALSE;
3441
3442             /* The key is the inverse mapping */
3443             char key[UTF8_MAXBYTES+1];
3444             char* key_end = (char *) uvuni_to_utf8((U8*) key, val);
3445             STRLEN key_len = key_end - key;
3446
3447             /* Get the list for the map */
3448             if ((listp = hv_fetch(ret, key, key_len, FALSE))) {
3449                 list = (AV*) *listp;
3450             }
3451             else { /* No entry yet for it: create one */
3452                 list = newAV();
3453                 if (! hv_store(ret, key, key_len, (SV*) list, FALSE)) {
3454                     Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
3455                 }
3456             }
3457
3458             /* Look through list to see if this inverse mapping already is
3459              * listed, or if there is a mapping to itself already */
3460             for (i = 0; i <= av_len(list); i++) {
3461                 SV** entryp = av_fetch(list, i, FALSE);
3462                 SV* entry;
3463                 if (entryp == NULL) {
3464                     Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
3465                 }
3466                 entry = *entryp;
3467                 /*DEBUG_U(PerlIO_printf(Perl_debug_log, "list for %"UVXf" contains %"UVXf"\n", val, SvUV(entry)));*/
3468                 if (SvUV(entry) == val) {
3469                     found_key = TRUE;
3470                 }
3471                 if (SvUV(entry) == inverse) {
3472                     found_inverse = TRUE;
3473                 }
3474
3475                 /* No need to continue searching if found everything we are
3476                  * looking for */
3477                 if (found_key && found_inverse) {
3478                     break;
3479                 }
3480             }
3481
3482             /* Make sure there is a mapping to itself on the list */
3483             if (! found_key) {
3484                 av_push(list, newSVuv(val));
3485                 /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Adding %"UVXf" to list for %"UVXf"\n", val, val));*/
3486             }
3487
3488
3489             /* Simply add the value to the list */
3490             if (! found_inverse) {
3491                 av_push(list, newSVuv(inverse));
3492                 /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Adding %"UVXf" to list for %"UVXf"\n", inverse, val));*/
3493             }
3494
3495             /* swatch_get() increments the value of val for each element in the
3496              * range.  That makes more compact tables possible.  You can
3497              * express the capitalization, for example, of all consecutive
3498              * letters with a single line: 0061\t007A\t0041 This maps 0061 to
3499              * 0041, 0062 to 0042, etc.  I (khw) have never understood 'none',
3500              * and it's not documented; it appears to be used only in
3501              * implementing tr//; I copied the semantics from swatch_get(), just
3502              * in case */
3503             if (!none || val < none) {
3504                 ++val;
3505             }
3506         }
3507     }
3508
3509     return ret;
3510 }
3511
3512 SV*
3513 Perl__swash_to_invlist(pTHX_ SV* const swash)
3514 {
3515
3516    /* Subject to change or removal.  For use only in one place in regcomp.c */
3517
3518     U8 *l, *lend;
3519     char *loc;
3520     STRLEN lcur;
3521     HV *const hv = MUTABLE_HV(SvRV(swash));
3522     UV elements = 0;    /* Number of elements in the inversion list */
3523     U8 empty[] = "";
3524
3525     /* The string containing the main body of the table */
3526     SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
3527     SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
3528     SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
3529     SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
3530     SV** const invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
3531
3532     const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
3533     const STRLEN bits  = SvUV(*bitssvp);
3534     const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
3535     U8 *x, *xend;
3536     STRLEN xcur;
3537
3538     SV* invlist;
3539
3540     PERL_ARGS_ASSERT__SWASH_TO_INVLIST;
3541
3542     /* read $swash->{LIST} */
3543     if (SvPOK(*listsvp)) {
3544         l = (U8*)SvPV(*listsvp, lcur);
3545     }
3546     else {
3547         /* LIST legitimately doesn't contain a string during compilation phases
3548          * of Perl itself, before the Unicode tables are generated.  In this
3549          * case, just fake things up by creating an empty list */
3550         l = empty;
3551         lcur = 0;
3552     }
3553     loc = (char *) l;
3554     lend = l + lcur;
3555
3556     /* Scan the input to count the number of lines to preallocate array size
3557      * based on worst possible case, which is each line in the input creates 2
3558      * elements in the inversion list: 1) the beginning of a range in the list;
3559      * 2) the beginning of a range not in the list.  */
3560     while ((loc = (strchr(loc, '\n'))) != NULL) {
3561         elements += 2;
3562         loc++;
3563     }
3564
3565     /* If the ending is somehow corrupt and isn't a new line, add another
3566      * element for the final range that isn't in the inversion list */
3567     if (! (*lend == '\n'
3568         || (*lend == '\0' && (lcur == 0 || *(lend - 1) == '\n'))))
3569     {
3570         elements++;
3571     }
3572
3573     invlist = _new_invlist(elements);
3574
3575     /* Now go through the input again, adding each range to the list */
3576     while (l < lend) {
3577         UV start, end;
3578         UV val;         /* Not used by this function */
3579
3580         l = S_swash_scan_list_line(aTHX_ l, lend, &start, &end, &val,
3581                                          cBOOL(octets), typestr);
3582
3583         if (l > lend) {
3584             break;
3585         }
3586
3587         _append_range_to_invlist(invlist, start, end);
3588     }
3589
3590     /* Invert if the data says it should be */
3591     if (invert_it_svp && SvUV(*invert_it_svp)) {
3592         _invlist_invert_prop(invlist);
3593     }
3594
3595     /* This code is copied from swatch_get()
3596      * read $swash->{EXTRAS} */
3597     x = (U8*)SvPV(*extssvp, xcur);
3598     xend = x + xcur;
3599     while (x < xend) {
3600         STRLEN namelen;
3601         U8 *namestr;
3602         SV** othersvp;
3603         HV* otherhv;
3604         STRLEN otherbits;
3605         SV **otherbitssvp, *other;
3606         U8 *nl;
3607
3608         const U8 opc = *x++;
3609         if (opc == '\n')
3610             continue;
3611
3612         nl = (U8*)memchr(x, '\n', xend - x);
3613
3614         if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
3615             if (nl) {
3616                 x = nl + 1; /* 1 is length of "\n" */
3617                 continue;
3618             }
3619             else {
3620                 x = xend; /* to EXTRAS' end at which \n is not found */
3621                 break;
3622             }
3623         }
3624
3625         namestr = x;
3626         if (nl) {
3627             namelen = nl - namestr;
3628             x = nl + 1;
3629         }
3630         else {
3631             namelen = xend - namestr;
3632             x = xend;
3633         }
3634
3635         othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
3636         otherhv = MUTABLE_HV(SvRV(*othersvp));
3637         otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
3638         otherbits = (STRLEN)SvUV(*otherbitssvp);
3639
3640         if (bits != otherbits || bits != 1) {
3641             Perl_croak(aTHX_ "panic: _swash_to_invlist only operates on boolean properties");
3642         }
3643
3644         /* The "other" swatch must be destroyed after. */
3645         other = _swash_to_invlist((SV *)*othersvp);
3646
3647         /* End of code copied from swatch_get() */
3648         switch (opc) {
3649         case '+':
3650             _invlist_union(invlist, other, &invlist);
3651             break;
3652         case '!':
3653             _invlist_invert(other);
3654             _invlist_union(invlist, other, &invlist);
3655             break;
3656         case '-':
3657             _invlist_subtract(invlist, other, &invlist);
3658             break;
3659         case '&':
3660             _invlist_intersection(invlist, other, &invlist);
3661             break;
3662         default:
3663             break;
3664         }
3665         sv_free(other); /* through with it! */
3666     }
3667
3668     return invlist;
3669 }
3670
3671 /*
3672 =for apidoc uvchr_to_utf8
3673
3674 Adds the UTF-8 representation of the Native code point C<uv> to the end
3675 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
3676 bytes available. The return value is the pointer to the byte after the
3677 end of the new character. In other words,
3678
3679     d = uvchr_to_utf8(d, uv);
3680
3681 is the recommended wide native character-aware way of saying
3682
3683     *(d++) = uv;
3684
3685 =cut
3686 */
3687
3688 /* On ASCII machines this is normally a macro but we want a
3689    real function in case XS code wants it
3690 */
3691 U8 *
3692 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
3693 {
3694     PERL_ARGS_ASSERT_UVCHR_TO_UTF8;
3695
3696     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
3697 }
3698
3699 U8 *
3700 Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
3701 {
3702     PERL_ARGS_ASSERT_UVCHR_TO_UTF8_FLAGS;
3703
3704     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
3705 }
3706
3707 /*
3708 =for apidoc utf8n_to_uvchr
3709
3710 Returns the native character value of the first character in the string
3711 C<s>
3712 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
3713 length, in bytes, of that character.
3714
3715 length and flags are the same as utf8n_to_uvuni().
3716
3717 =cut
3718 */
3719 /* On ASCII machines this is normally a macro but we want
3720    a real function in case XS code wants it
3721 */
3722 UV
3723 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
3724 U32 flags)
3725 {
3726     const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
3727
3728     PERL_ARGS_ASSERT_UTF8N_TO_UVCHR;
3729
3730     return UNI_TO_NATIVE(uv);
3731 }
3732
3733 bool
3734 Perl_check_utf8_print(pTHX_ register const U8* s, const STRLEN len)
3735 {
3736     /* May change: warns if surrogates, non-character code points, or
3737      * non-Unicode code points are in s which has length len bytes.  Returns
3738      * TRUE if none found; FALSE otherwise.  The only other validity check is
3739      * to make sure that this won't exceed the string's length */
3740
3741     const U8* const e = s + len;
3742     bool ok = TRUE;
3743
3744     PERL_ARGS_ASSERT_CHECK_UTF8_PRINT;
3745
3746     while (s < e) {
3747         if (UTF8SKIP(s) > len) {
3748             Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
3749                            "%s in %s", unees, PL_op ? OP_DESC(PL_op) : "print");
3750             return FALSE;
3751         }
3752         if (UNLIKELY(*s >= UTF8_FIRST_PROBLEMATIC_CODE_POINT_FIRST_BYTE)) {
3753             STRLEN char_len;
3754             if (UTF8_IS_SUPER(s)) {
3755                 if (ckWARN_d(WARN_NON_UNICODE)) {
3756                     UV uv = utf8_to_uvchr(s, &char_len);
3757                     Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
3758                         "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv);
3759                     ok = FALSE;
3760                 }
3761             }
3762             else if (UTF8_IS_SURROGATE(s)) {
3763                 if (ckWARN_d(WARN_SURROGATE)) {
3764                     UV uv = utf8_to_uvchr(s, &char_len);
3765                     Perl_warner(aTHX_ packWARN(WARN_SURROGATE),
3766                         "Unicode surrogate U+%04"UVXf" is illegal in UTF-8", uv);
3767                     ok = FALSE;
3768                 }
3769             }
3770             else if
3771                 ((UTF8_IS_NONCHAR_GIVEN_THAT_NON_SUPER_AND_GE_PROBLEMATIC(s))
3772                  && (ckWARN_d(WARN_NONCHAR)))
3773             {
3774                 UV uv = utf8_to_uvchr(s, &char_len);
3775                 Perl_warner(aTHX_ packWARN(WARN_NONCHAR),
3776                     "Unicode non-character U+%04"UVXf" is illegal for open interchange", uv);
3777                 ok = FALSE;
3778             }
3779         }
3780         s += UTF8SKIP(s);
3781     }
3782
3783     return ok;
3784 }
3785
3786 /*
3787 =for apidoc pv_uni_display
3788
3789 Build to the scalar dsv a displayable version of the string spv,
3790 length len, the displayable version being at most pvlim bytes long
3791 (if longer, the rest is truncated and "..." will be appended).
3792
3793 The flags argument can have UNI_DISPLAY_ISPRINT set to display
3794 isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
3795 to display the \\[nrfta\\] as the backslashed versions (like '\n')
3796 (UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
3797 UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
3798 UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
3799
3800 The pointer to the PV of the dsv is returned.
3801
3802 =cut */
3803 char *
3804 Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
3805 {
3806     int truncated = 0;
3807     const char *s, *e;
3808
3809     PERL_ARGS_ASSERT_PV_UNI_DISPLAY;
3810
3811     sv_setpvs(dsv, "");
3812     SvUTF8_off(dsv);
3813     for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
3814          UV u;
3815           /* This serves double duty as a flag and a character to print after
3816              a \ when flags & UNI_DISPLAY_BACKSLASH is true.
3817           */
3818          char ok = 0;
3819
3820          if (pvlim && SvCUR(dsv) >= pvlim) {
3821               truncated++;
3822               break;
3823          }
3824          u = utf8_to_uvchr((U8*)s, 0);
3825          if (u < 256) {
3826              const unsigned char c = (unsigned char)u & 0xFF;
3827              if (flags & UNI_DISPLAY_BACKSLASH) {
3828                  switch (c) {
3829                  case '\n':
3830                      ok = 'n'; break;
3831                  case '\r':
3832                      ok = 'r'; break;
3833                  case '\t':
3834                      ok = 't'; break;
3835                  case '\f':
3836                      ok = 'f'; break;
3837                  case '\a':
3838                      ok = 'a'; break;
3839                  case '\\':
3840                      ok = '\\'; break;
3841                  default: break;
3842                  }
3843                  if (ok) {
3844                      const char string = ok;
3845                      sv_catpvs(dsv, "\\");
3846                      sv_catpvn(dsv, &string, 1);
3847                  }
3848              }
3849              /* isPRINT() is the locale-blind version. */
3850              if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
3851                  const char string = c;
3852                  sv_catpvn(dsv, &string, 1);
3853                  ok = 1;
3854              }
3855          }
3856          if (!ok)
3857              Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
3858     }
3859     if (truncated)
3860          sv_catpvs(dsv, "...");
3861
3862     return SvPVX(dsv);
3863 }
3864
3865 /*
3866 =for apidoc sv_uni_display
3867
3868 Build to the scalar dsv a displayable version of the scalar sv,
3869 the displayable version being at most pvlim bytes long
3870 (if longer, the rest is truncated and "..." will be appended).
3871
3872 The flags argument is as in pv_uni_display().
3873
3874 The pointer to the PV of the dsv is returned.
3875
3876 =cut
3877 */
3878 char *
3879 Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
3880 {
3881     PERL_ARGS_ASSERT_SV_UNI_DISPLAY;
3882
3883      return Perl_pv_uni_display(aTHX_ dsv, (const U8*)SvPVX_const(ssv),
3884                                 SvCUR(ssv), pvlim, flags);
3885 }
3886
3887 /*
3888 =for apidoc foldEQ_utf8
3889
3890 Returns true if the leading portions of the strings s1 and s2 (either or both
3891 of which may be in UTF-8) are the same case-insensitively; false otherwise.
3892 How far into the strings to compare is determined by other input parameters.
3893
3894 If u1 is true, the string s1 is assumed to be in UTF-8-encoded Unicode;
3895 otherwise it is assumed to be in native 8-bit encoding.  Correspondingly for u2
3896 with respect to s2.
3897
3898 If the byte length l1 is non-zero, it says how far into s1 to check for fold
3899 equality.  In other words, s1+l1 will be used as a goal to reach.  The
3900 scan will not be considered to be a match unless the goal is reached, and
3901 scanning won't continue past that goal.  Correspondingly for l2 with respect to
3902 s2.
3903
3904 If pe1 is non-NULL and the pointer it points to is not NULL, that pointer is
3905 considered an end pointer beyond which scanning of s1 will not continue under
3906 any circumstances.  This means that if both l1 and pe1 are specified, and pe1
3907 is less than s1+l1, the match will never be successful because it can never
3908 get as far as its goal (and in fact is asserted against).  Correspondingly for
3909 pe2 with respect to s2.
3910
3911 At least one of s1 and s2 must have a goal (at least one of l1 and l2 must be
3912 non-zero), and if both do, both have to be
3913 reached for a successful match.   Also, if the fold of a character is multiple
3914 characters, all of them must be matched (see tr21 reference below for
3915 'folding').
3916
3917 Upon a successful match, if pe1 is non-NULL,
3918 it will be set to point to the beginning of the I<next> character of s1 beyond
3919 what was matched.  Correspondingly for pe2 and s2.
3920
3921 For case-insensitiveness, the "casefolding" of Unicode is used
3922 instead of upper/lowercasing both the characters, see
3923 http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
3924
3925 =cut */
3926
3927 /* A flags parameter has been added which may change, and hence isn't
3928  * externally documented.  Currently it is:
3929  *  0 for as-documented above
3930  *  FOLDEQ_UTF8_NOMIX_ASCII meaning that if a non-ASCII character folds to an
3931                             ASCII one, to not match
3932  *  FOLDEQ_UTF8_LOCALE      meaning that locale rules are to be used for code
3933  *                          points below 256; unicode rules for above 255; and
3934  *                          folds that cross those boundaries are disallowed,
3935  *                          like the NOMIX_ASCII option
3936  *  FOLDEQ_S1_ALREADY_FOLDED s1 has already been folded before calling this
3937  *                           routine.  This allows that step to be skipped.
3938  *  FOLDEQ_S2_ALREADY_FOLDED   Similarly.
3939  */
3940 I32
3941 Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2, U32 flags)
3942 {
3943     dVAR;
3944     register const U8 *p1  = (const U8*)s1; /* Point to current char */
3945     register const U8 *p2  = (const U8*)s2;
3946     register const U8 *g1 = NULL;       /* goal for s1 */
3947     register const U8 *g2 = NULL;
3948     register const U8 *e1 = NULL;       /* Don't scan s1 past this */
3949     register U8 *f1 = NULL;             /* Point to current folded */
3950     register const U8 *e2 = NULL;
3951     register U8 *f2 = NULL;
3952     STRLEN n1 = 0, n2 = 0;              /* Number of bytes in current char */
3953     U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
3954     U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
3955
3956     PERL_ARGS_ASSERT_FOLDEQ_UTF8_FLAGS;
3957
3958     /* The algorithm requires that input with the flags on the first line of
3959      * the assert not be pre-folded. */
3960     assert( ! ((flags & (FOLDEQ_UTF8_NOMIX_ASCII | FOLDEQ_UTF8_LOCALE))
3961         && (flags & (FOLDEQ_S1_ALREADY_FOLDED | FOLDEQ_S2_ALREADY_FOLDED))));
3962
3963     if (pe1) {
3964         e1 = *(U8**)pe1;
3965     }
3966
3967     if (l1) {
3968         g1 = (const U8*)s1 + l1;
3969     }
3970
3971     if (pe2) {
3972         e2 = *(U8**)pe2;
3973     }
3974
3975     if (l2) {
3976         g2 = (const U8*)s2 + l2;
3977     }
3978
3979     /* Must have at least one goal */
3980     assert(g1 || g2);
3981
3982     if (g1) {
3983
3984         /* Will never match if goal is out-of-bounds */
3985         assert(! e1  || e1 >= g1);
3986
3987         /* Here, there isn't an end pointer, or it is beyond the goal.  We
3988         * only go as far as the goal */
3989         e1 = g1;
3990     }
3991     else {
3992         assert(e1);    /* Must have an end for looking at s1 */
3993     }
3994
3995     /* Same for goal for s2 */
3996     if (g2) {
3997         assert(! e2  || e2 >= g2);
3998         e2 = g2;
3999     }
4000     else {
4001         assert(e2);
4002     }
4003
4004     /* If both operands are already folded, we could just do a memEQ on the
4005      * whole strings at once, but it would be better if the caller realized
4006      * this and didn't even call us */
4007
4008     /* Look through both strings, a character at a time */
4009     while (p1 < e1 && p2 < e2) {
4010
4011         /* If at the beginning of a new character in s1, get its fold to use
4012          * and the length of the fold.  (exception: locale rules just get the
4013          * character to a single byte) */
4014         if (n1 == 0) {
4015             if (flags & FOLDEQ_S1_ALREADY_FOLDED) {
4016                 f1 = (U8 *) p1;
4017                 n1 = UTF8SKIP(f1);
4018             }
4019
4020             else {
4021                 /* If in locale matching, we use two sets of rules, depending
4022                  * on if the code point is above or below 255.  Here, we test
4023                  * for and handle locale rules */
4024                 if ((flags & FOLDEQ_UTF8_LOCALE)
4025                     && (! u1 || UTF8_IS_INVARIANT(*p1)
4026                         || UTF8_IS_DOWNGRADEABLE_START(*p1)))
4027                 {
4028                     /* There is no mixing of code points above and below 255. */
4029                     if (u2 && (! UTF8_IS_INVARIANT(*p2)
4030                         && ! UTF8_IS_DOWNGRADEABLE_START(*p2)))
4031                     {
4032                         return 0;
4033                     }
4034
4035                     /* We handle locale rules by converting, if necessary, the
4036                      * code point to a single byte. */
4037                     if (! u1 || UTF8_IS_INVARIANT(*p1)) {
4038                         *foldbuf1 = *p1;
4039                     }
4040                     else {
4041                         *foldbuf1 = TWO_BYTE_UTF8_TO_UNI(*p1, *(p1 + 1));
4042                     }
4043                     n1 = 1;
4044                 }
4045                 else if (isASCII(*p1)) {    /* Note, that here won't be both
4046                                                ASCII and using locale rules */
4047
4048                     /* If trying to mix non- with ASCII, and not supposed to,
4049                      * fail */
4050                     if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p2)) {
4051                         return 0;
4052                     }
4053                     n1 = 1;
4054                     *foldbuf1 = toLOWER(*p1);   /* Folds in the ASCII range are
4055                                                    just lowercased */
4056                 }
4057                 else if (u1) {
4058                     to_utf8_fold(p1, foldbuf1, &n1);
4059                 }
4060                 else {  /* Not utf8, get utf8 fold */
4061                     to_uni_fold(NATIVE_TO_UNI(*p1), foldbuf1, &n1);
4062                 }
4063                 f1 = foldbuf1;
4064             }
4065         }
4066
4067         if (n2 == 0) {    /* Same for s2 */
4068             if (flags & FOLDEQ_S2_ALREADY_FOLDED) {
4069                 f2 = (U8 *) p2;
4070                 n2 = UTF8SKIP(f2);
4071             }
4072             else {
4073                 if ((flags & FOLDEQ_UTF8_LOCALE)
4074                     && (! u2 || UTF8_IS_INVARIANT(*p2) || UTF8_IS_DOWNGRADEABLE_START(*p2)))
4075                 {
4076                     /* Here, the next char in s2 is < 256.  We've already
4077                      * worked on s1, and if it isn't also < 256, can't match */
4078                     if (u1 && (! UTF8_IS_INVARIANT(*p1)
4079                         && ! UTF8_IS_DOWNGRADEABLE_START(*p1)))
4080                     {
4081                         return 0;
4082                     }
4083                     if (! u2 || UTF8_IS_INVARIANT(*p2)) {
4084                         *foldbuf2 = *p2;
4085                     }
4086                     else {
4087                         *foldbuf2 = TWO_BYTE_UTF8_TO_UNI(*p2, *(p2 + 1));
4088                     }
4089
4090                     /* Use another function to handle locale rules.  We've made
4091                      * sure that both characters to compare are single bytes */
4092                     if (! foldEQ_locale((char *) f1, (char *) foldbuf2, 1)) {
4093                         return 0;
4094                     }
4095                     n1 = n2 = 0;
4096                 }
4097                 else if (isASCII(*p2)) {
4098                     if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p1)) {
4099                         return 0;
4100                     }
4101                     n2 = 1;
4102                     *foldbuf2 = toLOWER(*p2);
4103                 }
4104                 else if (u2) {
4105                     to_utf8_fold(p2, foldbuf2, &n2);
4106                 }
4107                 else {
4108                     to_uni_fold(NATIVE_TO_UNI(*p2), foldbuf2, &n2);
4109                 }
4110                 f2 = foldbuf2;
4111             }
4112         }
4113
4114         /* Here f1 and f2 point to the beginning of the strings to compare.
4115          * These strings are the folds of the next character from each input
4116          * string, stored in utf8. */
4117
4118         /* While there is more to look for in both folds, see if they
4119         * continue to match */
4120         while (n1 && n2) {
4121             U8 fold_length = UTF8SKIP(f1);
4122             if (fold_length != UTF8SKIP(f2)
4123                 || (fold_length == 1 && *f1 != *f2) /* Short circuit memNE
4124                                                        function call for single
4125                                                        byte */
4126                 || memNE((char*)f1, (char*)f2, fold_length))
4127             {
4128                 return 0; /* mismatch */
4129             }
4130
4131             /* Here, they matched, advance past them */
4132             n1 -= fold_length;
4133             f1 += fold_length;
4134             n2 -= fold_length;
4135             f2 += fold_length;
4136         }
4137
4138         /* When reach the end of any fold, advance the input past it */
4139         if (n1 == 0) {
4140             p1 += u1 ? UTF8SKIP(p1) : 1;
4141         }
4142         if (n2 == 0) {
4143             p2 += u2 ? UTF8SKIP(p2) : 1;
4144         }
4145     } /* End of loop through both strings */
4146
4147     /* A match is defined by each scan that specified an explicit length
4148     * reaching its final goal, and the other not having matched a partial
4149     * character (which can happen when the fold of a character is more than one
4150     * character). */
4151     if (! ((g1 == 0 || p1 == g1) && (g2 == 0 || p2 == g2)) || n1 || n2) {
4152         return 0;
4153     }
4154
4155     /* Successful match.  Set output pointers */
4156     if (pe1) {
4157         *pe1 = (char*)p1;
4158     }
4159     if (pe2) {
4160         *pe2 = (char*)p2;
4161     }
4162     return 1;
4163 }
4164
4165 /*
4166  * Local variables:
4167  * c-indentation-style: bsd
4168  * c-basic-offset: 4
4169  * indent-tabs-mode: t
4170  * End:
4171  *
4172  * ex: set ts=8 sts=4 sw=4 noet:
4173  */