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 SV*
2458 Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
2459 {
2460     dVAR;
2461     SV* retval;
2462     dSP;
2463     const size_t pkg_len = strlen(pkg);
2464     const size_t name_len = strlen(name);
2465     HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
2466     SV* errsv_save;
2467     GV *method;
2468
2469     PERL_ARGS_ASSERT_SWASH_INIT;
2470
2471     PUSHSTACKi(PERLSI_MAGIC);
2472     ENTER;
2473     SAVEHINTS();
2474     save_re_context();
2475     if (PL_parser && PL_parser->error_count)
2476         SAVEI8(PL_parser->error_count), PL_parser->error_count = 0;
2477     method = gv_fetchmeth(stash, "SWASHNEW", 8, -1);
2478     if (!method) {      /* demand load utf8 */
2479         ENTER;
2480         errsv_save = newSVsv(ERRSV);
2481         /* It is assumed that callers of this routine are not passing in any
2482            user derived data.  */
2483         /* Need to do this after save_re_context() as it will set PL_tainted to
2484            1 while saving $1 etc (see the code after getrx: in Perl_magic_get).
2485            Even line to create errsv_save can turn on PL_tainted.  */
2486         SAVEBOOL(PL_tainted);
2487         PL_tainted = 0;
2488         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
2489                          NULL);
2490         if (!SvTRUE(ERRSV))
2491             sv_setsv(ERRSV, errsv_save);
2492         SvREFCNT_dec(errsv_save);
2493         LEAVE;
2494     }
2495     SPAGAIN;
2496     PUSHMARK(SP);
2497     EXTEND(SP,5);
2498     mPUSHp(pkg, pkg_len);
2499     mPUSHp(name, name_len);
2500     PUSHs(listsv);
2501     mPUSHi(minbits);
2502     mPUSHi(none);
2503     PUTBACK;
2504     errsv_save = newSVsv(ERRSV);
2505     /* If we already have a pointer to the method, no need to use call_method()
2506        to repeat the lookup.  */
2507     if (method ? call_sv(MUTABLE_SV(method), G_SCALAR)
2508         : call_sv(newSVpvs_flags("SWASHNEW", SVs_TEMP), G_SCALAR | G_METHOD))
2509         retval = newSVsv(*PL_stack_sp--);
2510     else
2511         retval = &PL_sv_undef;
2512     if (!SvTRUE(ERRSV))
2513         sv_setsv(ERRSV, errsv_save);
2514     SvREFCNT_dec(errsv_save);
2515     LEAVE;
2516     POPSTACK;
2517     if (IN_PERL_COMPILETIME) {
2518         CopHINTS_set(PL_curcop, PL_hints);
2519     }
2520     if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
2521         if (SvPOK(retval))
2522             Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
2523                        SVfARG(retval));
2524         Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
2525     }
2526     return retval;
2527 }
2528
2529
2530 /* This API is wrong for special case conversions since we may need to
2531  * return several Unicode characters for a single Unicode character
2532  * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
2533  * the lower-level routine, and it is similarly broken for returning
2534  * multiple values.  --jhi
2535  * For those, you should use to_utf8_case() instead */
2536 /* Now SWASHGET is recasted into S_swash_get in this file. */
2537
2538 /* Note:
2539  * Returns the value of property/mapping C<swash> for the first character
2540  * of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
2541  * assumed to be in utf8. If C<do_utf8> is false, the string C<ptr> is
2542  * assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
2543  *
2544  * A "swash" is a hash which contains initially the keys/values set up by
2545  * SWASHNEW.  The purpose is to be able to completely represent a Unicode
2546  * property for all possible code points.  Things are stored in a compact form
2547  * (see utf8_heavy.pl) so that calculation is required to find the actual
2548  * property value for a given code point.  As code points are looked up, new
2549  * key/value pairs are added to the hash, so that the calculation doesn't have
2550  * to ever be re-done.  Further, each calculation is done, not just for the
2551  * desired one, but for a whole block of code points adjacent to that one.
2552  * For binary properties on ASCII machines, the block is usually for 64 code
2553  * points, starting with a code point evenly divisible by 64.  Thus if the
2554  * property value for code point 257 is requested, the code goes out and
2555  * calculates the property values for all 64 code points between 256 and 319,
2556  * and stores these as a single 64-bit long bit vector, called a "swatch",
2557  * under the key for code point 256.  The key is the UTF-8 encoding for code
2558  * point 256, minus the final byte.  Thus, if the length of the UTF-8 encoding
2559  * for a code point is 13 bytes, the key will be 12 bytes long.  If the value
2560  * for code point 258 is then requested, this code realizes that it would be
2561  * stored under the key for 256, and would find that value and extract the
2562  * relevant bit, offset from 256.
2563  *
2564  * Non-binary properties are stored in as many bits as necessary to represent
2565  * their values (32 currently, though the code is more general than that), not
2566  * as single bits, but the principal is the same: the value for each key is a
2567  * vector that encompasses the property values for all code points whose UTF-8
2568  * representations are represented by the key.  That is, for all code points
2569  * whose UTF-8 representations are length N bytes, and the key is the first N-1
2570  * bytes of that.
2571  */
2572 UV
2573 Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
2574 {
2575     dVAR;
2576     HV *const hv = MUTABLE_HV(SvRV(swash));
2577     U32 klen;
2578     U32 off;
2579     STRLEN slen;
2580     STRLEN needents;
2581     const U8 *tmps = NULL;
2582     U32 bit;
2583     SV *swatch;
2584     U8 tmputf8[2];
2585     const UV c = NATIVE_TO_ASCII(*ptr);
2586
2587     PERL_ARGS_ASSERT_SWASH_FETCH;
2588
2589     if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
2590         tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
2591         tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
2592         ptr = tmputf8;
2593     }
2594     /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
2595      * then the "swatch" is a vec() for all the chars which start
2596      * with 0xAA..0xYY
2597      * So the key in the hash (klen) is length of encoded char -1
2598      */
2599     klen = UTF8SKIP(ptr) - 1;
2600     off  = ptr[klen];
2601
2602     if (klen == 0) {
2603       /* If char is invariant then swatch is for all the invariant chars
2604        * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
2605        */
2606         needents = UTF_CONTINUATION_MARK;
2607         off      = NATIVE_TO_UTF(ptr[klen]);
2608     }
2609     else {
2610       /* If char is encoded then swatch is for the prefix */
2611         needents = (1 << UTF_ACCUMULATION_SHIFT);
2612         off      = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
2613     }
2614
2615     /*
2616      * This single-entry cache saves about 1/3 of the utf8 overhead in test
2617      * suite.  (That is, only 7-8% overall over just a hash cache.  Still,
2618      * it's nothing to sniff at.)  Pity we usually come through at least
2619      * two function calls to get here...
2620      *
2621      * NB: this code assumes that swatches are never modified, once generated!
2622      */
2623
2624     if (hv   == PL_last_swash_hv &&
2625         klen == PL_last_swash_klen &&
2626         (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
2627     {
2628         tmps = PL_last_swash_tmps;
2629         slen = PL_last_swash_slen;
2630     }
2631     else {
2632         /* Try our second-level swatch cache, kept in a hash. */
2633         SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE);
2634
2635         /* If not cached, generate it via swash_get */
2636         if (!svp || !SvPOK(*svp)
2637                  || !(tmps = (const U8*)SvPV_const(*svp, slen))) {
2638             /* We use utf8n_to_uvuni() as we want an index into
2639                Unicode tables, not a native character number.
2640              */
2641             const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
2642                                            ckWARN(WARN_UTF8) ?
2643                                            0 : UTF8_ALLOW_ANY);
2644             swatch = swash_get(swash,
2645                     /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
2646                                 (klen) ? (code_point & ~((UV)needents - 1)) : 0,
2647                                 needents);
2648
2649             if (IN_PERL_COMPILETIME)
2650                 CopHINTS_set(PL_curcop, PL_hints);
2651
2652             svp = hv_store(hv, (const char *)ptr, klen, swatch, 0);
2653
2654             if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
2655                      || (slen << 3) < needents)
2656                 Perl_croak(aTHX_ "panic: swash_fetch got improper swatch");
2657         }
2658
2659         PL_last_swash_hv = hv;
2660         assert(klen <= sizeof(PL_last_swash_key));
2661         PL_last_swash_klen = (U8)klen;
2662         /* FIXME change interpvar.h?  */
2663         PL_last_swash_tmps = (U8 *) tmps;
2664         PL_last_swash_slen = slen;
2665         if (klen)
2666             Copy(ptr, PL_last_swash_key, klen, U8);
2667     }
2668
2669     if (UTF8_IS_SUPER(ptr) && ckWARN_d(WARN_NON_UNICODE)) {
2670         SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
2671
2672         /* This outputs warnings for binary properties only, assuming that
2673          * to_utf8_case() will output any for non-binary.  Also, surrogates
2674          * aren't checked for, as that would warn on things like /\p{Gc=Cs}/ */
2675
2676         if (SvUV(*bitssvp) == 1) {
2677             /* User-defined properties can silently match above-Unicode */
2678             SV** const user_defined_svp = hv_fetchs(hv, "USER_DEFINED", FALSE);
2679             if (! user_defined_svp || ! SvUV(*user_defined_svp)) {
2680                 const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0, 0);
2681                 Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
2682                     "Code point 0x%04"UVXf" is not Unicode, all \\p{} matches fail; all \\P{} matches succeed", code_point);
2683             }
2684         }
2685     }
2686
2687     switch ((int)((slen << 3) / needents)) {
2688     case 1:
2689         bit = 1 << (off & 7);
2690         off >>= 3;
2691         return (tmps[off] & bit) != 0;
2692     case 8:
2693         return tmps[off];
2694     case 16:
2695         off <<= 1;
2696         return (tmps[off] << 8) + tmps[off + 1] ;
2697     case 32:
2698         off <<= 2;
2699         return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
2700     }
2701     Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width");
2702     NORETURN_FUNCTION_END;
2703 }
2704
2705 /* Read a single line of the main body of the swash input text.  These are of
2706  * the form:
2707  * 0053 0056    0073
2708  * where each number is hex.  The first two numbers form the minimum and
2709  * maximum of a range, and the third is the value associated with the range.
2710  * Not all swashes should have a third number
2711  *
2712  * On input: l    points to the beginning of the line to be examined; it points
2713  *                to somewhere in the string of the whole input text, and is
2714  *                terminated by a \n or the null string terminator.
2715  *           lend   points to the null terminator of that string
2716  *           wants_value    is non-zero if the swash expects a third number
2717  *           typestr is the name of the swash's mapping, like 'ToLower'
2718  * On output: *min, *max, and *val are set to the values read from the line.
2719  *            returns a pointer just beyond the line examined.  If there was no
2720  *            valid min number on the line, returns lend+1
2721  */
2722
2723 STATIC U8*
2724 S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val,
2725                              const bool wants_value, const U8* const typestr)
2726 {
2727     const int  typeto  = typestr[0] == 'T' && typestr[1] == 'o';
2728     STRLEN numlen;          /* Length of the number */
2729     I32 flags = PERL_SCAN_SILENT_ILLDIGIT
2730                 | PERL_SCAN_DISALLOW_PREFIX
2731                 | PERL_SCAN_SILENT_NON_PORTABLE;
2732
2733     /* nl points to the next \n in the scan */
2734     U8* const nl = (U8*)memchr(l, '\n', lend - l);
2735
2736     /* Get the first number on the line: the range minimum */
2737     numlen = lend - l;
2738     *min = grok_hex((char *)l, &numlen, &flags, NULL);
2739     if (numlen)     /* If found a hex number, position past it */
2740         l += numlen;
2741     else if (nl) {          /* Else, go handle next line, if any */
2742         return nl + 1;  /* 1 is length of "\n" */
2743     }
2744     else {              /* Else, no next line */
2745         return lend + 1;        /* to LIST's end at which \n is not found */
2746     }
2747
2748     /* The max range value follows, separated by a BLANK */
2749     if (isBLANK(*l)) {
2750         ++l;
2751         flags = PERL_SCAN_SILENT_ILLDIGIT
2752                 | PERL_SCAN_DISALLOW_PREFIX
2753                 | PERL_SCAN_SILENT_NON_PORTABLE;
2754         numlen = lend - l;
2755         *max = grok_hex((char *)l, &numlen, &flags, NULL);
2756         if (numlen)
2757             l += numlen;
2758         else    /* If no value here, it is a single element range */
2759             *max = *min;
2760
2761         /* Non-binary tables have a third entry: what the first element of the
2762          * range maps to */
2763         if (wants_value) {
2764             if (isBLANK(*l)) {
2765                 ++l;
2766                 flags = PERL_SCAN_SILENT_ILLDIGIT
2767                       | PERL_SCAN_DISALLOW_PREFIX
2768                       | PERL_SCAN_SILENT_NON_PORTABLE;
2769                 numlen = lend - l;
2770                 *val = grok_hex((char *)l, &numlen, &flags, NULL);
2771                 if (numlen)
2772                     l += numlen;
2773                 else
2774                     *val = 0;
2775             }
2776             else {
2777                 *val = 0;
2778                 if (typeto) {
2779                     /* diag_listed_as: To%s: illegal mapping '%s' */
2780                     Perl_croak(aTHX_ "%s: illegal mapping '%s'",
2781                                      typestr, l);
2782                 }
2783             }
2784         }
2785         else
2786             *val = 0; /* bits == 1, then any val should be ignored */
2787     }
2788     else { /* Nothing following range min, should be single element with no
2789               mapping expected */
2790         *max = *min;
2791         if (wants_value) {
2792             *val = 0;
2793             if (typeto) {
2794                 /* diag_listed_as: To%s: illegal mapping '%s' */
2795                 Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
2796             }
2797         }
2798         else
2799             *val = 0; /* bits == 1, then val should be ignored */
2800     }
2801
2802     /* Position to next line if any, or EOF */
2803     if (nl)
2804         l = nl + 1;
2805     else
2806         l = lend;
2807
2808     return l;
2809 }
2810
2811 /* Note:
2812  * Returns a swatch (a bit vector string) for a code point sequence
2813  * that starts from the value C<start> and comprises the number C<span>.
2814  * A C<swash> must be an object created by SWASHNEW (see lib/utf8_heavy.pl).
2815  * Should be used via swash_fetch, which will cache the swatch in C<swash>.
2816  */
2817 STATIC SV*
2818 S_swash_get(pTHX_ SV* swash, UV start, UV span)
2819 {
2820     SV *swatch;
2821     U8 *l, *lend, *x, *xend, *s, *send;
2822     STRLEN lcur, xcur, scur;
2823     HV *const hv = MUTABLE_HV(SvRV(swash));
2824
2825     /* The string containing the main body of the table */
2826     SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
2827
2828     SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
2829     SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
2830     SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
2831     SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
2832     SV** const invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
2833     const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
2834     const STRLEN bits  = SvUV(*bitssvp);
2835     const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
2836     const UV     none  = SvUV(*nonesvp);
2837     UV           end   = start + span;
2838
2839     PERL_ARGS_ASSERT_SWASH_GET;
2840
2841     if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
2842         Perl_croak(aTHX_ "panic: swash_get doesn't expect bits %"UVuf,
2843                                                  (UV)bits);
2844     }
2845
2846     /* If overflowed, use the max possible */
2847     if (end < start) {
2848         end = UV_MAX;
2849         span = end - start;
2850     }
2851
2852     /* create and initialize $swatch */
2853     scur   = octets ? (span * octets) : (span + 7) / 8;
2854     swatch = newSV(scur);
2855     SvPOK_on(swatch);
2856     s = (U8*)SvPVX(swatch);
2857     if (octets && none) {
2858         const U8* const e = s + scur;
2859         while (s < e) {
2860             if (bits == 8)
2861                 *s++ = (U8)(none & 0xff);
2862             else if (bits == 16) {
2863                 *s++ = (U8)((none >>  8) & 0xff);
2864                 *s++ = (U8)( none        & 0xff);
2865             }
2866             else if (bits == 32) {
2867                 *s++ = (U8)((none >> 24) & 0xff);
2868                 *s++ = (U8)((none >> 16) & 0xff);
2869                 *s++ = (U8)((none >>  8) & 0xff);
2870                 *s++ = (U8)( none        & 0xff);
2871             }
2872         }
2873         *s = '\0';
2874     }
2875     else {
2876         (void)memzero((U8*)s, scur + 1);
2877     }
2878     SvCUR_set(swatch, scur);
2879     s = (U8*)SvPVX(swatch);
2880
2881     /* read $swash->{LIST}.  XXX Note that this is a linear scan through a
2882      * sorted list.  A binary search would be much more efficient */
2883     l = (U8*)SvPV(*listsvp, lcur);
2884     lend = l + lcur;
2885     while (l < lend) {
2886         UV min, max, val;
2887         l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
2888                                          cBOOL(octets), typestr);
2889         if (l > lend) {
2890             break;
2891         }
2892
2893         /* If looking for something beyond this range, go try the next one */
2894         if (max < start)
2895             continue;
2896
2897         if (octets) {
2898             UV key;
2899             if (min < start) {
2900                 if (!none || val < none) {
2901                     val += start - min;
2902                 }
2903                 min = start;
2904             }
2905             for (key = min; key <= max; key++) {
2906                 STRLEN offset;
2907                 if (key >= end)
2908                     goto go_out_list;
2909                 /* XXX If it should ever happen (very unlikely) that we would
2910                  * want a non-binary result for the code point at UV_MAX,
2911                  * special handling would need to be inserted here, as is done
2912                  * below for the binary case */
2913                 /* offset must be non-negative (start <= min <= key < end) */
2914                 offset = octets * (key - start);
2915                 if (bits == 8)
2916                     s[offset] = (U8)(val & 0xff);
2917                 else if (bits == 16) {
2918                     s[offset    ] = (U8)((val >>  8) & 0xff);
2919                     s[offset + 1] = (U8)( val        & 0xff);
2920                 }
2921                 else if (bits == 32) {
2922                     s[offset    ] = (U8)((val >> 24) & 0xff);
2923                     s[offset + 1] = (U8)((val >> 16) & 0xff);
2924                     s[offset + 2] = (U8)((val >>  8) & 0xff);
2925                     s[offset + 3] = (U8)( val        & 0xff);
2926                 }
2927
2928                 if (!none || val < none)
2929                     ++val;
2930             }
2931         }
2932         else { /* bits == 1, then val should be ignored */
2933             UV key;
2934             if (min < start)
2935                 min = start;
2936
2937             /* Special case when the upper-end is the highest possible code
2938              * point representable on the platform.  Otherwise, the code below
2939              * exits before setting this bit.  Done here to avoid testing for
2940              * this extremely unlikely possibility in the loop */
2941             if (UNLIKELY(end == UV_MAX && max == UV_MAX)) {
2942                 const STRLEN offset = (STRLEN)(max - start);
2943                 s[offset >> 3] |= 1 << (offset & 7);
2944             }
2945             for (key = min; key <= max; key++) {
2946                 const STRLEN offset = (STRLEN)(key - start);
2947                 if (key >= end)
2948                     goto go_out_list;
2949                 s[offset >> 3] |= 1 << (offset & 7);
2950             }
2951         }
2952     } /* while */
2953   go_out_list:
2954
2955     /* Invert if the data says it should be.  Assumes that bits == 1 */
2956     if (invert_it_svp && SvUV(*invert_it_svp)) {
2957
2958         /* Unicode properties should come with all bits above PERL_UNICODE_MAX
2959          * be 0, and their inversion should also be 0, as we don't succeed any
2960          * Unicode property matches for non-Unicode code points */
2961         if (start <= PERL_UNICODE_MAX) {
2962
2963             /* The code below assumes that we never cross the
2964              * Unicode/above-Unicode boundary in a range, as otherwise we would
2965              * have to figure out where to stop flipping the bits.  Since this
2966              * boundary is divisible by a large power of 2, and swatches comes
2967              * in small powers of 2, this should be a valid assumption */
2968             assert(start + span - 1 <= PERL_UNICODE_MAX);
2969
2970             send = s + scur;
2971             while (s < send) {
2972                 *s = ~(*s);
2973                 s++;
2974             }
2975         }
2976     }
2977
2978     /* read $swash->{EXTRAS}
2979      * This code also copied to swash_to_invlist() below */
2980     x = (U8*)SvPV(*extssvp, xcur);
2981     xend = x + xcur;
2982     while (x < xend) {
2983         STRLEN namelen;
2984         U8 *namestr;
2985         SV** othersvp;
2986         HV* otherhv;
2987         STRLEN otherbits;
2988         SV **otherbitssvp, *other;
2989         U8 *s, *o, *nl;
2990         STRLEN slen, olen;
2991
2992         const U8 opc = *x++;
2993         if (opc == '\n')
2994             continue;
2995
2996         nl = (U8*)memchr(x, '\n', xend - x);
2997
2998         if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
2999             if (nl) {
3000                 x = nl + 1; /* 1 is length of "\n" */
3001                 continue;
3002             }
3003             else {
3004                 x = xend; /* to EXTRAS' end at which \n is not found */
3005                 break;
3006             }
3007         }
3008
3009         namestr = x;
3010         if (nl) {
3011             namelen = nl - namestr;
3012             x = nl + 1;
3013         }
3014         else {
3015             namelen = xend - namestr;
3016             x = xend;
3017         }
3018
3019         othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
3020         otherhv = MUTABLE_HV(SvRV(*othersvp));
3021         otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
3022         otherbits = (STRLEN)SvUV(*otherbitssvp);
3023         if (bits < otherbits)
3024             Perl_croak(aTHX_ "panic: swash_get found swatch size mismatch");
3025
3026         /* The "other" swatch must be destroyed after. */
3027         other = swash_get(*othersvp, start, span);
3028         o = (U8*)SvPV(other, olen);
3029
3030         if (!olen)
3031             Perl_croak(aTHX_ "panic: swash_get got improper swatch");
3032
3033         s = (U8*)SvPV(swatch, slen);
3034         if (bits == 1 && otherbits == 1) {
3035             if (slen != olen)
3036                 Perl_croak(aTHX_ "panic: swash_get found swatch length mismatch");
3037
3038             switch (opc) {
3039             case '+':
3040                 while (slen--)
3041                     *s++ |= *o++;
3042                 break;
3043             case '!':
3044                 while (slen--)
3045                     *s++ |= ~*o++;
3046                 break;
3047             case '-':
3048                 while (slen--)
3049                     *s++ &= ~*o++;
3050                 break;
3051             case '&':
3052                 while (slen--)
3053                     *s++ &= *o++;
3054                 break;
3055             default:
3056                 break;
3057             }
3058         }
3059         else {
3060             STRLEN otheroctets = otherbits >> 3;
3061             STRLEN offset = 0;
3062             U8* const send = s + slen;
3063
3064             while (s < send) {
3065                 UV otherval = 0;
3066
3067                 if (otherbits == 1) {
3068                     otherval = (o[offset >> 3] >> (offset & 7)) & 1;
3069                     ++offset;
3070                 }
3071                 else {
3072                     STRLEN vlen = otheroctets;
3073                     otherval = *o++;
3074                     while (--vlen) {
3075                         otherval <<= 8;
3076                         otherval |= *o++;
3077                     }
3078                 }
3079
3080                 if (opc == '+' && otherval)
3081                     NOOP;   /* replace with otherval */
3082                 else if (opc == '!' && !otherval)
3083                     otherval = 1;
3084                 else if (opc == '-' && otherval)
3085                     otherval = 0;
3086                 else if (opc == '&' && !otherval)
3087                     otherval = 0;
3088                 else {
3089                     s += octets; /* no replacement */
3090                     continue;
3091                 }
3092
3093                 if (bits == 8)
3094                     *s++ = (U8)( otherval & 0xff);
3095                 else if (bits == 16) {
3096                     *s++ = (U8)((otherval >>  8) & 0xff);
3097                     *s++ = (U8)( otherval        & 0xff);
3098                 }
3099                 else if (bits == 32) {
3100                     *s++ = (U8)((otherval >> 24) & 0xff);
3101                     *s++ = (U8)((otherval >> 16) & 0xff);
3102                     *s++ = (U8)((otherval >>  8) & 0xff);
3103                     *s++ = (U8)( otherval        & 0xff);
3104                 }
3105             }
3106         }
3107         sv_free(other); /* through with it! */
3108     } /* while */
3109     return swatch;
3110 }
3111
3112 HV*
3113 Perl__swash_inversion_hash(pTHX_ SV* const swash)
3114 {
3115
3116    /* Subject to change or removal.  For use only in one place in regcomp.c.
3117     * Can't be used on a property that is subject to user override, as it
3118     * relies on the value of SPECIALS in the swash which would be set by
3119     * utf8_heavy.pl to the hash in the non-overriden file, and hence is not set
3120     * for overridden properties
3121     *
3122     * Returns a hash which is the inversion and closure of a swash mapping.
3123     * For example, consider the input lines:
3124     * 004B              006B
3125     * 004C              006C
3126     * 212A              006B
3127     *
3128     * The returned hash would have two keys, the utf8 for 006B and the utf8 for
3129     * 006C.  The value for each key is an array.  For 006C, the array would
3130     * have a two elements, the utf8 for itself, and for 004C.  For 006B, there
3131     * would be three elements in its array, the utf8 for 006B, 004B and 212A.
3132     *
3133     * Essentially, for any code point, it gives all the code points that map to
3134     * it, or the list of 'froms' for that point.
3135     *
3136     * Currently it ignores any additions or deletions from other swashes,
3137     * looking at just the main body of the swash, and if there are SPECIALS
3138     * in the swash, at that hash
3139     *
3140     * The specials hash can be extra code points, and most likely consists of
3141     * maps from single code points to multiple ones (each expressed as a string
3142     * of utf8 characters).   This function currently returns only 1-1 mappings.
3143     * However consider this possible input in the specials hash:
3144     * "\xEF\xAC\x85" => "\x{0073}\x{0074}",         # U+FB05 => 0073 0074
3145     * "\xEF\xAC\x86" => "\x{0073}\x{0074}",         # U+FB06 => 0073 0074
3146     *
3147     * Both FB05 and FB06 map to the same multi-char sequence, which we don't
3148     * currently handle.  But it also means that FB05 and FB06 are equivalent in
3149     * a 1-1 mapping which we should handle, and this relationship may not be in
3150     * the main table.  Therefore this function examines all the multi-char
3151     * sequences and adds the 1-1 mappings that come out of that.  */
3152
3153     U8 *l, *lend;
3154     STRLEN lcur;
3155     HV *const hv = MUTABLE_HV(SvRV(swash));
3156
3157     /* The string containing the main body of the table */
3158     SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
3159
3160     SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
3161     SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
3162     SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
3163     /*SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);*/
3164     const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
3165     const STRLEN bits  = SvUV(*bitssvp);
3166     const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
3167     const UV     none  = SvUV(*nonesvp);
3168     SV **specials_p = hv_fetchs(hv, "SPECIALS", 0);
3169
3170     HV* ret = newHV();
3171
3172     PERL_ARGS_ASSERT__SWASH_INVERSION_HASH;
3173
3174     /* Must have at least 8 bits to get the mappings */
3175     if (bits != 8 && bits != 16 && bits != 32) {
3176         Perl_croak(aTHX_ "panic: swash_inversion_hash doesn't expect bits %"UVuf,
3177                                                  (UV)bits);
3178     }
3179
3180     if (specials_p) { /* It might be "special" (sometimes, but not always, a
3181                         mapping to more than one character */
3182
3183         /* Construct an inverse mapping hash for the specials */
3184         HV * const specials_hv = MUTABLE_HV(SvRV(*specials_p));
3185         HV * specials_inverse = newHV();
3186         char *char_from; /* the lhs of the map */
3187         I32 from_len;   /* its byte length */
3188         char *char_to;  /* the rhs of the map */
3189         I32 to_len;     /* its byte length */
3190         SV *sv_to;      /* and in a sv */
3191         AV* from_list;  /* list of things that map to each 'to' */
3192
3193         hv_iterinit(specials_hv);
3194
3195         /* The keys are the characters (in utf8) that map to the corresponding
3196          * utf8 string value.  Iterate through the list creating the inverse
3197          * list. */
3198         while ((sv_to = hv_iternextsv(specials_hv, &char_from, &from_len))) {
3199             SV** listp;
3200             if (! SvPOK(sv_to)) {
3201                 Perl_croak(aTHX_ "panic: value returned from hv_iternextsv() unexpectedly is not a string");
3202             }
3203             /*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)));*/
3204
3205             /* Each key in the inverse list is a mapped-to value, and the key's
3206              * hash value is a list of the strings (each in utf8) that map to
3207              * it.  Those strings are all one character long */
3208             if ((listp = hv_fetch(specials_inverse,
3209                                     SvPVX(sv_to),
3210                                     SvCUR(sv_to), 0)))
3211             {
3212                 from_list = (AV*) *listp;
3213             }
3214             else { /* No entry yet for it: create one */
3215                 from_list = newAV();
3216                 if (! hv_store(specials_inverse,
3217                                 SvPVX(sv_to),
3218                                 SvCUR(sv_to),
3219                                 (SV*) from_list, 0))
3220                 {
3221                     Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
3222                 }
3223             }
3224
3225             /* Here have the list associated with this 'to' (perhaps newly
3226              * created and empty).  Just add to it.  Note that we ASSUME that
3227              * the input is guaranteed to not have duplications, so we don't
3228              * check for that.  Duplications just slow down execution time. */
3229             av_push(from_list, newSVpvn_utf8(char_from, from_len, TRUE));
3230         }
3231
3232         /* Here, 'specials_inverse' contains the inverse mapping.  Go through
3233          * it looking for cases like the FB05/FB06 examples above.  There would
3234          * be an entry in the hash like
3235         *       'st' => [ FB05, FB06 ]
3236         * In this example we will create two lists that get stored in the
3237         * returned hash, 'ret':
3238         *       FB05 => [ FB05, FB06 ]
3239         *       FB06 => [ FB05, FB06 ]
3240         *
3241         * Note that there is nothing to do if the array only has one element.
3242         * (In the normal 1-1 case handled below, we don't have to worry about
3243         * two lists, as everything gets tied to the single list that is
3244         * generated for the single character 'to'.  But here, we are omitting
3245         * that list, ('st' in the example), so must have multiple lists.) */
3246         while ((from_list = (AV *) hv_iternextsv(specials_inverse,
3247                                                  &char_to, &to_len)))
3248         {
3249             if (av_len(from_list) > 0) {
3250                 int i;
3251
3252                 /* We iterate over all combinations of i,j to place each code
3253                  * point on each list */
3254                 for (i = 0; i <= av_len(from_list); i++) {
3255                     int j;
3256                     AV* i_list = newAV();
3257                     SV** entryp = av_fetch(from_list, i, FALSE);
3258                     if (entryp == NULL) {
3259                         Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
3260                     }
3261                     if (hv_fetch(ret, SvPVX(*entryp), SvCUR(*entryp), FALSE)) {
3262                         Perl_croak(aTHX_ "panic: unexpected entry for %s", SvPVX(*entryp));
3263                     }
3264                     if (! hv_store(ret, SvPVX(*entryp), SvCUR(*entryp),
3265                                    (SV*) i_list, FALSE))
3266                     {
3267                         Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
3268                     }
3269
3270                     /* For debugging: UV u = utf8_to_uvchr((U8*) SvPVX(*entryp), 0);*/
3271                     for (j = 0; j <= av_len(from_list); j++) {
3272                         entryp = av_fetch(from_list, j, FALSE);
3273                         if (entryp == NULL) {
3274                             Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
3275                         }
3276
3277                         /* When i==j this adds itself to the list */
3278                         av_push(i_list, newSVuv(utf8_to_uvchr(
3279                                                 (U8*) SvPVX(*entryp), 0)));
3280                         /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Adding %"UVXf" to list for %"UVXf"\n", utf8_to_uvchr((U8*) SvPVX(*entryp), 0), u));*/
3281                     }
3282                 }
3283             }
3284         }
3285         SvREFCNT_dec(specials_inverse); /* done with it */
3286     } /* End of specials */
3287
3288     /* read $swash->{LIST} */
3289     l = (U8*)SvPV(*listsvp, lcur);
3290     lend = l + lcur;
3291
3292     /* Go through each input line */
3293     while (l < lend) {
3294         UV min, max, val;
3295         UV inverse;
3296         l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
3297                                          cBOOL(octets), typestr);
3298         if (l > lend) {
3299             break;
3300         }
3301
3302         /* Each element in the range is to be inverted */
3303         for (inverse = min; inverse <= max; inverse++) {
3304             AV* list;
3305             SV** listp;
3306             IV i;
3307             bool found_key = FALSE;
3308             bool found_inverse = FALSE;
3309
3310             /* The key is the inverse mapping */
3311             char key[UTF8_MAXBYTES+1];
3312             char* key_end = (char *) uvuni_to_utf8((U8*) key, val);
3313             STRLEN key_len = key_end - key;
3314
3315             /* Get the list for the map */
3316             if ((listp = hv_fetch(ret, key, key_len, FALSE))) {
3317                 list = (AV*) *listp;
3318             }
3319             else { /* No entry yet for it: create one */
3320                 list = newAV();
3321                 if (! hv_store(ret, key, key_len, (SV*) list, FALSE)) {
3322                     Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
3323                 }
3324             }
3325
3326             /* Look through list to see if this inverse mapping already is
3327              * listed, or if there is a mapping to itself already */
3328             for (i = 0; i <= av_len(list); i++) {
3329                 SV** entryp = av_fetch(list, i, FALSE);
3330                 SV* entry;
3331                 if (entryp == NULL) {
3332                     Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
3333                 }
3334                 entry = *entryp;
3335                 /*DEBUG_U(PerlIO_printf(Perl_debug_log, "list for %"UVXf" contains %"UVXf"\n", val, SvUV(entry)));*/
3336                 if (SvUV(entry) == val) {
3337                     found_key = TRUE;
3338                 }
3339                 if (SvUV(entry) == inverse) {
3340                     found_inverse = TRUE;
3341                 }
3342
3343                 /* No need to continue searching if found everything we are
3344                  * looking for */
3345                 if (found_key && found_inverse) {
3346                     break;
3347                 }
3348             }
3349
3350             /* Make sure there is a mapping to itself on the list */
3351             if (! found_key) {
3352                 av_push(list, newSVuv(val));
3353                 /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Adding %"UVXf" to list for %"UVXf"\n", val, val));*/
3354             }
3355
3356
3357             /* Simply add the value to the list */
3358             if (! found_inverse) {
3359                 av_push(list, newSVuv(inverse));
3360                 /*DEBUG_U(PerlIO_printf(Perl_debug_log, "Adding %"UVXf" to list for %"UVXf"\n", inverse, val));*/
3361             }
3362
3363             /* swash_get() increments the value of val for each element in the
3364              * range.  That makes more compact tables possible.  You can
3365              * express the capitalization, for example, of all consecutive
3366              * letters with a single line: 0061\t007A\t0041 This maps 0061 to
3367              * 0041, 0062 to 0042, etc.  I (khw) have never understood 'none',
3368              * and it's not documented; it appears to be used only in
3369              * implementing tr//; I copied the semantics from swash_get(), just
3370              * in case */
3371             if (!none || val < none) {
3372                 ++val;
3373             }
3374         }
3375     }
3376
3377     return ret;
3378 }
3379
3380 SV*
3381 Perl__swash_to_invlist(pTHX_ SV* const swash)
3382 {
3383
3384    /* Subject to change or removal.  For use only in one place in regcomp.c */
3385
3386     U8 *l, *lend;
3387     char *loc;
3388     STRLEN lcur;
3389     HV *const hv = MUTABLE_HV(SvRV(swash));
3390     UV elements = 0;    /* Number of elements in the inversion list */
3391     U8 empty[] = "";
3392
3393     /* The string containing the main body of the table */
3394     SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
3395     SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
3396     SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
3397     SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
3398     SV** const invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
3399
3400     const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
3401     const STRLEN bits  = SvUV(*bitssvp);
3402     const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
3403     U8 *x, *xend;
3404     STRLEN xcur;
3405
3406     SV* invlist;
3407
3408     PERL_ARGS_ASSERT__SWASH_TO_INVLIST;
3409
3410     /* read $swash->{LIST} */
3411     if (SvPOK(*listsvp)) {
3412         l = (U8*)SvPV(*listsvp, lcur);
3413     }
3414     else {
3415         /* LIST legitimately doesn't contain a string during compilation phases
3416          * of Perl itself, before the Unicode tables are generated.  In this
3417          * case, just fake things up by creating an empty list */
3418         l = empty;
3419         lcur = 0;
3420     }
3421     loc = (char *) l;
3422     lend = l + lcur;
3423
3424     /* Scan the input to count the number of lines to preallocate array size
3425      * based on worst possible case, which is each line in the input creates 2
3426      * elements in the inversion list: 1) the beginning of a range in the list;
3427      * 2) the beginning of a range not in the list.  */
3428     while ((loc = (strchr(loc, '\n'))) != NULL) {
3429         elements += 2;
3430         loc++;
3431     }
3432
3433     /* If the ending is somehow corrupt and isn't a new line, add another
3434      * element for the final range that isn't in the inversion list */
3435     if (! (*lend == '\n' || (*lend == '\0' && *(lend - 1) == '\n'))) {
3436         elements++;
3437     }
3438
3439     invlist = _new_invlist(elements);
3440
3441     /* Now go through the input again, adding each range to the list */
3442     while (l < lend) {
3443         UV start, end;
3444         UV val;         /* Not used by this function */
3445
3446         l = S_swash_scan_list_line(aTHX_ l, lend, &start, &end, &val,
3447                                          cBOOL(octets), typestr);
3448
3449         if (l > lend) {
3450             break;
3451         }
3452
3453         _append_range_to_invlist(invlist, start, end);
3454     }
3455
3456     /* Invert if the data says it should be */
3457     if (invert_it_svp && SvUV(*invert_it_svp)) {
3458         _invlist_invert_prop(invlist);
3459     }
3460
3461     /* This code is copied from swash_get()
3462      * read $swash->{EXTRAS} */
3463     x = (U8*)SvPV(*extssvp, xcur);
3464     xend = x + xcur;
3465     while (x < xend) {
3466         STRLEN namelen;
3467         U8 *namestr;
3468         SV** othersvp;
3469         HV* otherhv;
3470         STRLEN otherbits;
3471         SV **otherbitssvp, *other;
3472         U8 *nl;
3473
3474         const U8 opc = *x++;
3475         if (opc == '\n')
3476             continue;
3477
3478         nl = (U8*)memchr(x, '\n', xend - x);
3479
3480         if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
3481             if (nl) {
3482                 x = nl + 1; /* 1 is length of "\n" */
3483                 continue;
3484             }
3485             else {
3486                 x = xend; /* to EXTRAS' end at which \n is not found */
3487                 break;
3488             }
3489         }
3490
3491         namestr = x;
3492         if (nl) {
3493             namelen = nl - namestr;
3494             x = nl + 1;
3495         }
3496         else {
3497             namelen = xend - namestr;
3498             x = xend;
3499         }
3500
3501         othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
3502         otherhv = MUTABLE_HV(SvRV(*othersvp));
3503         otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
3504         otherbits = (STRLEN)SvUV(*otherbitssvp);
3505
3506         if (bits != otherbits || bits != 1) {
3507             Perl_croak(aTHX_ "panic: _swash_to_invlist only operates on boolean properties");
3508         }
3509
3510         /* The "other" swatch must be destroyed after. */
3511         other = _swash_to_invlist((SV *)*othersvp);
3512
3513         /* End of code copied from swash_get() */
3514         switch (opc) {
3515         case '+':
3516             _invlist_union(invlist, other, &invlist);
3517             break;
3518         case '!':
3519             _invlist_invert(other);
3520             _invlist_union(invlist, other, &invlist);
3521             break;
3522         case '-':
3523             _invlist_subtract(invlist, other, &invlist);
3524             break;
3525         case '&':
3526             _invlist_intersection(invlist, other, &invlist);
3527             break;
3528         default:
3529             break;
3530         }
3531         sv_free(other); /* through with it! */
3532     }
3533
3534     return invlist;
3535 }
3536
3537 /*
3538 =for apidoc uvchr_to_utf8
3539
3540 Adds the UTF-8 representation of the Native code point C<uv> to the end
3541 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
3542 bytes available. The return value is the pointer to the byte after the
3543 end of the new character. In other words,
3544
3545     d = uvchr_to_utf8(d, uv);
3546
3547 is the recommended wide native character-aware way of saying
3548
3549     *(d++) = uv;
3550
3551 =cut
3552 */
3553
3554 /* On ASCII machines this is normally a macro but we want a
3555    real function in case XS code wants it
3556 */
3557 U8 *
3558 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
3559 {
3560     PERL_ARGS_ASSERT_UVCHR_TO_UTF8;
3561
3562     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
3563 }
3564
3565 U8 *
3566 Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
3567 {
3568     PERL_ARGS_ASSERT_UVCHR_TO_UTF8_FLAGS;
3569
3570     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
3571 }
3572
3573 /*
3574 =for apidoc utf8n_to_uvchr
3575
3576 Returns the native character value of the first character in the string
3577 C<s>
3578 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
3579 length, in bytes, of that character.
3580
3581 length and flags are the same as utf8n_to_uvuni().
3582
3583 =cut
3584 */
3585 /* On ASCII machines this is normally a macro but we want
3586    a real function in case XS code wants it
3587 */
3588 UV
3589 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
3590 U32 flags)
3591 {
3592     const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
3593
3594     PERL_ARGS_ASSERT_UTF8N_TO_UVCHR;
3595
3596     return UNI_TO_NATIVE(uv);
3597 }
3598
3599 bool
3600 Perl_check_utf8_print(pTHX_ register const U8* s, const STRLEN len)
3601 {
3602     /* May change: warns if surrogates, non-character code points, or
3603      * non-Unicode code points are in s which has length len bytes.  Returns
3604      * TRUE if none found; FALSE otherwise.  The only other validity check is
3605      * to make sure that this won't exceed the string's length */
3606
3607     const U8* const e = s + len;
3608     bool ok = TRUE;
3609
3610     PERL_ARGS_ASSERT_CHECK_UTF8_PRINT;
3611
3612     while (s < e) {
3613         if (UTF8SKIP(s) > len) {
3614             Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
3615                            "%s in %s", unees, PL_op ? OP_DESC(PL_op) : "print");
3616             return FALSE;
3617         }
3618         if (UNLIKELY(*s >= UTF8_FIRST_PROBLEMATIC_CODE_POINT_FIRST_BYTE)) {
3619             STRLEN char_len;
3620             if (UTF8_IS_SUPER(s)) {
3621                 if (ckWARN_d(WARN_NON_UNICODE)) {
3622                     UV uv = utf8_to_uvchr(s, &char_len);
3623                     Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
3624                         "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv);
3625                     ok = FALSE;
3626                 }
3627             }
3628             else if (UTF8_IS_SURROGATE(s)) {
3629                 if (ckWARN_d(WARN_SURROGATE)) {
3630                     UV uv = utf8_to_uvchr(s, &char_len);
3631                     Perl_warner(aTHX_ packWARN(WARN_SURROGATE),
3632                         "Unicode surrogate U+%04"UVXf" is illegal in UTF-8", uv);
3633                     ok = FALSE;
3634                 }
3635             }
3636             else if
3637                 ((UTF8_IS_NONCHAR_GIVEN_THAT_NON_SUPER_AND_GE_PROBLEMATIC(s))
3638                  && (ckWARN_d(WARN_NONCHAR)))
3639             {
3640                 UV uv = utf8_to_uvchr(s, &char_len);
3641                 Perl_warner(aTHX_ packWARN(WARN_NONCHAR),
3642                     "Unicode non-character U+%04"UVXf" is illegal for open interchange", uv);
3643                 ok = FALSE;
3644             }
3645         }
3646         s += UTF8SKIP(s);
3647     }
3648
3649     return ok;
3650 }
3651
3652 /*
3653 =for apidoc pv_uni_display
3654
3655 Build to the scalar dsv a displayable version of the string spv,
3656 length len, the displayable version being at most pvlim bytes long
3657 (if longer, the rest is truncated and "..." will be appended).
3658
3659 The flags argument can have UNI_DISPLAY_ISPRINT set to display
3660 isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
3661 to display the \\[nrfta\\] as the backslashed versions (like '\n')
3662 (UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
3663 UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
3664 UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
3665
3666 The pointer to the PV of the dsv is returned.
3667
3668 =cut */
3669 char *
3670 Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
3671 {
3672     int truncated = 0;
3673     const char *s, *e;
3674
3675     PERL_ARGS_ASSERT_PV_UNI_DISPLAY;
3676
3677     sv_setpvs(dsv, "");
3678     SvUTF8_off(dsv);
3679     for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
3680          UV u;
3681           /* This serves double duty as a flag and a character to print after
3682              a \ when flags & UNI_DISPLAY_BACKSLASH is true.
3683           */
3684          char ok = 0;
3685
3686          if (pvlim && SvCUR(dsv) >= pvlim) {
3687               truncated++;
3688               break;
3689          }
3690          u = utf8_to_uvchr((U8*)s, 0);
3691          if (u < 256) {
3692              const unsigned char c = (unsigned char)u & 0xFF;
3693              if (flags & UNI_DISPLAY_BACKSLASH) {
3694                  switch (c) {
3695                  case '\n':
3696                      ok = 'n'; break;
3697                  case '\r':
3698                      ok = 'r'; break;
3699                  case '\t':
3700                      ok = 't'; break;
3701                  case '\f':
3702                      ok = 'f'; break;
3703                  case '\a':
3704                      ok = 'a'; break;
3705                  case '\\':
3706                      ok = '\\'; break;
3707                  default: break;
3708                  }
3709                  if (ok) {
3710                      const char string = ok;
3711                      sv_catpvs(dsv, "\\");
3712                      sv_catpvn(dsv, &string, 1);
3713                  }
3714              }
3715              /* isPRINT() is the locale-blind version. */
3716              if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
3717                  const char string = c;
3718                  sv_catpvn(dsv, &string, 1);
3719                  ok = 1;
3720              }
3721          }
3722          if (!ok)
3723              Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
3724     }
3725     if (truncated)
3726          sv_catpvs(dsv, "...");
3727
3728     return SvPVX(dsv);
3729 }
3730
3731 /*
3732 =for apidoc sv_uni_display
3733
3734 Build to the scalar dsv a displayable version of the scalar sv,
3735 the displayable version being at most pvlim bytes long
3736 (if longer, the rest is truncated and "..." will be appended).
3737
3738 The flags argument is as in pv_uni_display().
3739
3740 The pointer to the PV of the dsv is returned.
3741
3742 =cut
3743 */
3744 char *
3745 Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
3746 {
3747     PERL_ARGS_ASSERT_SV_UNI_DISPLAY;
3748
3749      return Perl_pv_uni_display(aTHX_ dsv, (const U8*)SvPVX_const(ssv),
3750                                 SvCUR(ssv), pvlim, flags);
3751 }
3752
3753 /*
3754 =for apidoc foldEQ_utf8
3755
3756 Returns true if the leading portions of the strings s1 and s2 (either or both
3757 of which may be in UTF-8) are the same case-insensitively; false otherwise.
3758 How far into the strings to compare is determined by other input parameters.
3759
3760 If u1 is true, the string s1 is assumed to be in UTF-8-encoded Unicode;
3761 otherwise it is assumed to be in native 8-bit encoding.  Correspondingly for u2
3762 with respect to s2.
3763
3764 If the byte length l1 is non-zero, it says how far into s1 to check for fold
3765 equality.  In other words, s1+l1 will be used as a goal to reach.  The
3766 scan will not be considered to be a match unless the goal is reached, and
3767 scanning won't continue past that goal.  Correspondingly for l2 with respect to
3768 s2.
3769
3770 If pe1 is non-NULL and the pointer it points to is not NULL, that pointer is
3771 considered an end pointer beyond which scanning of s1 will not continue under
3772 any circumstances.  This means that if both l1 and pe1 are specified, and pe1
3773 is less than s1+l1, the match will never be successful because it can never
3774 get as far as its goal (and in fact is asserted against).  Correspondingly for
3775 pe2 with respect to s2.
3776
3777 At least one of s1 and s2 must have a goal (at least one of l1 and l2 must be
3778 non-zero), and if both do, both have to be
3779 reached for a successful match.   Also, if the fold of a character is multiple
3780 characters, all of them must be matched (see tr21 reference below for
3781 'folding').
3782
3783 Upon a successful match, if pe1 is non-NULL,
3784 it will be set to point to the beginning of the I<next> character of s1 beyond
3785 what was matched.  Correspondingly for pe2 and s2.
3786
3787 For case-insensitiveness, the "casefolding" of Unicode is used
3788 instead of upper/lowercasing both the characters, see
3789 http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
3790
3791 =cut */
3792
3793 /* A flags parameter has been added which may change, and hence isn't
3794  * externally documented.  Currently it is:
3795  *  0 for as-documented above
3796  *  FOLDEQ_UTF8_NOMIX_ASCII meaning that if a non-ASCII character folds to an
3797                             ASCII one, to not match
3798  *  FOLDEQ_UTF8_LOCALE      meaning that locale rules are to be used for code
3799  *                          points below 256; unicode rules for above 255; and
3800  *                          folds that cross those boundaries are disallowed,
3801  *                          like the NOMIX_ASCII option
3802  *  FOLDEQ_S1_ALREADY_FOLDED s1 has already been folded before calling this
3803  *                           routine.  This allows that step to be skipped.
3804  *  FOLDEQ_S2_ALREADY_FOLDED   Similarly.
3805  */
3806 I32
3807 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)
3808 {
3809     dVAR;
3810     register const U8 *p1  = (const U8*)s1; /* Point to current char */
3811     register const U8 *p2  = (const U8*)s2;
3812     register const U8 *g1 = NULL;       /* goal for s1 */
3813     register const U8 *g2 = NULL;
3814     register const U8 *e1 = NULL;       /* Don't scan s1 past this */
3815     register U8 *f1 = NULL;             /* Point to current folded */
3816     register const U8 *e2 = NULL;
3817     register U8 *f2 = NULL;
3818     STRLEN n1 = 0, n2 = 0;              /* Number of bytes in current char */
3819     U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
3820     U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
3821
3822     PERL_ARGS_ASSERT_FOLDEQ_UTF8_FLAGS;
3823
3824     /* The algorithm requires that input with the flags on the first line of
3825      * the assert not be pre-folded. */
3826     assert( ! ((flags & (FOLDEQ_UTF8_NOMIX_ASCII | FOLDEQ_UTF8_LOCALE))
3827         && (flags & (FOLDEQ_S1_ALREADY_FOLDED | FOLDEQ_S2_ALREADY_FOLDED))));
3828
3829     if (pe1) {
3830         e1 = *(U8**)pe1;
3831     }
3832
3833     if (l1) {
3834         g1 = (const U8*)s1 + l1;
3835     }
3836
3837     if (pe2) {
3838         e2 = *(U8**)pe2;
3839     }
3840
3841     if (l2) {
3842         g2 = (const U8*)s2 + l2;
3843     }
3844
3845     /* Must have at least one goal */
3846     assert(g1 || g2);
3847
3848     if (g1) {
3849
3850         /* Will never match if goal is out-of-bounds */
3851         assert(! e1  || e1 >= g1);
3852
3853         /* Here, there isn't an end pointer, or it is beyond the goal.  We
3854         * only go as far as the goal */
3855         e1 = g1;
3856     }
3857     else {
3858         assert(e1);    /* Must have an end for looking at s1 */
3859     }
3860
3861     /* Same for goal for s2 */
3862     if (g2) {
3863         assert(! e2  || e2 >= g2);
3864         e2 = g2;
3865     }
3866     else {
3867         assert(e2);
3868     }
3869
3870     /* If both operands are already folded, we could just do a memEQ on the
3871      * whole strings at once, but it would be better if the caller realized
3872      * this and didn't even call us */
3873
3874     /* Look through both strings, a character at a time */
3875     while (p1 < e1 && p2 < e2) {
3876
3877         /* If at the beginning of a new character in s1, get its fold to use
3878          * and the length of the fold.  (exception: locale rules just get the
3879          * character to a single byte) */
3880         if (n1 == 0) {
3881             if (flags & FOLDEQ_S1_ALREADY_FOLDED) {
3882                 f1 = (U8 *) p1;
3883                 n1 = UTF8SKIP(f1);
3884             }
3885
3886             else {
3887                 /* If in locale matching, we use two sets of rules, depending
3888                  * on if the code point is above or below 255.  Here, we test
3889                  * for and handle locale rules */
3890                 if ((flags & FOLDEQ_UTF8_LOCALE)
3891                     && (! u1 || UTF8_IS_INVARIANT(*p1)
3892                         || UTF8_IS_DOWNGRADEABLE_START(*p1)))
3893                 {
3894                     /* There is no mixing of code points above and below 255. */
3895                     if (u2 && (! UTF8_IS_INVARIANT(*p2)
3896                         && ! UTF8_IS_DOWNGRADEABLE_START(*p2)))
3897                     {
3898                         return 0;
3899                     }
3900
3901                     /* We handle locale rules by converting, if necessary, the
3902                      * code point to a single byte. */
3903                     if (! u1 || UTF8_IS_INVARIANT(*p1)) {
3904                         *foldbuf1 = *p1;
3905                     }
3906                     else {
3907                         *foldbuf1 = TWO_BYTE_UTF8_TO_UNI(*p1, *(p1 + 1));
3908                     }
3909                     n1 = 1;
3910                 }
3911                 else if (isASCII(*p1)) {    /* Note, that here won't be both
3912                                                ASCII and using locale rules */
3913
3914                     /* If trying to mix non- with ASCII, and not supposed to,
3915                      * fail */
3916                     if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p2)) {
3917                         return 0;
3918                     }
3919                     n1 = 1;
3920                     *foldbuf1 = toLOWER(*p1);   /* Folds in the ASCII range are
3921                                                    just lowercased */
3922                 }
3923                 else if (u1) {
3924                     to_utf8_fold(p1, foldbuf1, &n1);
3925                 }
3926                 else {  /* Not utf8, get utf8 fold */
3927                     to_uni_fold(NATIVE_TO_UNI(*p1), foldbuf1, &n1);
3928                 }
3929                 f1 = foldbuf1;
3930             }
3931         }
3932
3933         if (n2 == 0) {    /* Same for s2 */
3934             if (flags & FOLDEQ_S2_ALREADY_FOLDED) {
3935                 f2 = (U8 *) p2;
3936                 n2 = UTF8SKIP(f2);
3937             }
3938             else {
3939                 if ((flags & FOLDEQ_UTF8_LOCALE)
3940                     && (! u2 || UTF8_IS_INVARIANT(*p2) || UTF8_IS_DOWNGRADEABLE_START(*p2)))
3941                 {
3942                     /* Here, the next char in s2 is < 256.  We've already
3943                      * worked on s1, and if it isn't also < 256, can't match */
3944                     if (u1 && (! UTF8_IS_INVARIANT(*p1)
3945                         && ! UTF8_IS_DOWNGRADEABLE_START(*p1)))
3946                     {
3947                         return 0;
3948                     }
3949                     if (! u2 || UTF8_IS_INVARIANT(*p2)) {
3950                         *foldbuf2 = *p2;
3951                     }
3952                     else {
3953                         *foldbuf2 = TWO_BYTE_UTF8_TO_UNI(*p2, *(p2 + 1));
3954                     }
3955
3956                     /* Use another function to handle locale rules.  We've made
3957                      * sure that both characters to compare are single bytes */
3958                     if (! foldEQ_locale((char *) f1, (char *) foldbuf2, 1)) {
3959                         return 0;
3960                     }
3961                     n1 = n2 = 0;
3962                 }
3963                 else if (isASCII(*p2)) {
3964                     if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p1)) {
3965                         return 0;
3966                     }
3967                     n2 = 1;
3968                     *foldbuf2 = toLOWER(*p2);
3969                 }
3970                 else if (u2) {
3971                     to_utf8_fold(p2, foldbuf2, &n2);
3972                 }
3973                 else {
3974                     to_uni_fold(NATIVE_TO_UNI(*p2), foldbuf2, &n2);
3975                 }
3976                 f2 = foldbuf2;
3977             }
3978         }
3979
3980         /* Here f1 and f2 point to the beginning of the strings to compare.
3981          * These strings are the folds of the next character from each input
3982          * string, stored in utf8. */
3983
3984         /* While there is more to look for in both folds, see if they
3985         * continue to match */
3986         while (n1 && n2) {
3987             U8 fold_length = UTF8SKIP(f1);
3988             if (fold_length != UTF8SKIP(f2)
3989                 || (fold_length == 1 && *f1 != *f2) /* Short circuit memNE
3990                                                        function call for single
3991                                                        byte */
3992                 || memNE((char*)f1, (char*)f2, fold_length))
3993             {
3994                 return 0; /* mismatch */
3995             }
3996
3997             /* Here, they matched, advance past them */
3998             n1 -= fold_length;
3999             f1 += fold_length;
4000             n2 -= fold_length;
4001             f2 += fold_length;
4002         }
4003
4004         /* When reach the end of any fold, advance the input past it */
4005         if (n1 == 0) {
4006             p1 += u1 ? UTF8SKIP(p1) : 1;
4007         }
4008         if (n2 == 0) {
4009             p2 += u2 ? UTF8SKIP(p2) : 1;
4010         }
4011     } /* End of loop through both strings */
4012
4013     /* A match is defined by each scan that specified an explicit length
4014     * reaching its final goal, and the other not having matched a partial
4015     * character (which can happen when the fold of a character is more than one
4016     * character). */
4017     if (! ((g1 == 0 || p1 == g1) && (g2 == 0 || p2 == g2)) || n1 || n2) {
4018         return 0;
4019     }
4020
4021     /* Successful match.  Set output pointers */
4022     if (pe1) {
4023         *pe1 = (char*)p1;
4024     }
4025     if (pe2) {
4026         *pe2 = (char*)p2;
4027     }
4028     return 1;
4029 }
4030
4031 /*
4032  * Local variables:
4033  * c-indentation-style: bsd
4034  * c-basic-offset: 4
4035  * indent-tabs-mode: t
4036  * End:
4037  *
4038  * ex: set ts=8 sts=4 sw=4 noet:
4039  */