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 See also is_utf8_string(), is_utf8_string_loclen(), and is_utf8_string_loc().
  66
  67 =cut
  68 */
  69
  70 bool
  71 Perl_is_ascii_string(const U8 *s, STRLEN len)
  72 {
  73     const U8* const send = s + (len ? len : strlen((const char *)s));
  74     const U8* x = s;
  75
  76     PERL_ARGS_ASSERT_IS_ASCII_STRING;
  77
  78     for (; x < send; ++x) {
  79         if (!UTF8_IS_INVARIANT(*x))
  80             break;
  81     }
  82
  83     return x == send;
  84 }
  85
  86 /*
  87 =for apidoc uvuni_to_utf8_flags
  88
  89 Adds the UTF-8 representation of the Unicode codepoint C<uv> to the end
  90 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
  91 bytes available. The return value is the pointer to the byte after the
  92 end of the new character. In other words,
  93
  94     d = uvuni_to_utf8_flags(d, uv, flags);
  95
  96 or, in most cases,
  97
  98     d = uvuni_to_utf8(d, uv);
  99
 100 (which is equivalent to)
 101
 102     d = uvuni_to_utf8_flags(d, uv, 0);
 103
 104 is the recommended Unicode-aware way of saying
 105
 106     *(d++) = uv;
 107
 108 =cut
 109 */
 110
 111 U8 *
 112 Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
 113 {
 114     PERL_ARGS_ASSERT_UVUNI_TO_UTF8_FLAGS;
 115
 116     if (ckWARN(WARN_UTF8)) {
 117          if (UNICODE_IS_SURROGATE(uv) &&
 118              !(flags & UNICODE_ALLOW_SURROGATE))
 119               Perl_warner(aTHX_ packWARN(WARN_UTF8), "UTF-16 surrogate 0x%04"UVxf, uv);
 120          else if (
 121                   ((uv >= 0xFDD0 && uv <= 0xFDEF &&
 122                     !(flags & UNICODE_ALLOW_FDD0))
 123                    ||
 124                    ((uv & 0xFFFE) == 0xFFFE && /* Either FFFE or FFFF. */
 125                     !(flags & UNICODE_ALLOW_FFFF))) &&
 126                   /* UNICODE_ALLOW_SUPER includes
 127                    * FFFEs and FFFFs beyond 0x10FFFF. */
 128                   ((uv <= PERL_UNICODE_MAX) ||
 129                    !(flags & UNICODE_ALLOW_SUPER))
 130                   )
 131               Perl_warner(aTHX_ packWARN(WARN_UTF8),
 132                       "Unicode non-character 0x%04"UVxf" is illegal for interchange", uv);
 133     }
 134     if (UNI_IS_INVARIANT(uv)) {
 135         *d++ = (U8)UTF_TO_NATIVE(uv);
 136         return d;
 137     }
 138 #if defined(EBCDIC)
 139     else {
 140         STRLEN len  = UNISKIP(uv);
 141         U8 *p = d+len-1;
 142         while (p > d) {
 143             *p-- = (U8)UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
 144             uv >>= UTF_ACCUMULATION_SHIFT;
 145         }
 146         *p = (U8)UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
 147         return d+len;
 148     }
 149 #else /* Non loop style */
 150     if (uv < 0x800) {
 151         *d++ = (U8)(( uv >>  6)         | 0xc0);
 152         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 153         return d;
 154     }
 155     if (uv < 0x10000) {
 156         *d++ = (U8)(( uv >> 12)         | 0xe0);
 157         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 158         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 159         return d;
 160     }
 161     if (uv < 0x200000) {
 162         *d++ = (U8)(( uv >> 18)         | 0xf0);
 163         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
 164         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 165         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 166         return d;
 167     }
 168     if (uv < 0x4000000) {
 169         *d++ = (U8)(( uv >> 24)         | 0xf8);
 170         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
 171         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
 172         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 173         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 174         return d;
 175     }
 176     if (uv < 0x80000000) {
 177         *d++ = (U8)(( uv >> 30)         | 0xfc);
 178         *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
 179         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
 180         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
 181         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 182         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 183         return d;
 184     }
 185 #ifdef HAS_QUAD
 186     if (uv < UTF8_QUAD_MAX)
 187 #endif
 188     {
 189         *d++ =                            0xfe; /* Can't match U+FEFF! */
 190         *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
 191         *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
 192         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
 193         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
 194         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 195         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 196         return d;
 197     }
 198 #ifdef HAS_QUAD
 199     {
 200         *d++ =                            0xff;         /* Can't match U+FFFE! */
 201         *d++ =                            0x80;         /* 6 Reserved bits */
 202         *d++ = (U8)(((uv >> 60) & 0x0f) | 0x80);        /* 2 Reserved bits */
 203         *d++ = (U8)(((uv >> 54) & 0x3f) | 0x80);
 204         *d++ = (U8)(((uv >> 48) & 0x3f) | 0x80);
 205         *d++ = (U8)(((uv >> 42) & 0x3f) | 0x80);
 206         *d++ = (U8)(((uv >> 36) & 0x3f) | 0x80);
 207         *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
 208         *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
 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 #endif
 216 #endif /* Loop style */
 217 }
 218
 219 /*
 220
 221 Tests if some arbitrary number of bytes begins in a valid UTF-8
 222 character.  Note that an INVARIANT (i.e. ASCII) character is a valid
 223 UTF-8 character.  The actual number of bytes in the UTF-8 character
 224 will be returned if it is valid, otherwise 0.
 225
 226 This is the "slow" version as opposed to the "fast" version which is
 227 the "unrolled" IS_UTF8_CHAR().  E.g. for t/uni/class.t the speed
 228 difference is a factor of 2 to 3.  For lengths (UTF8SKIP(s)) of four
 229 or less you should use the IS_UTF8_CHAR(), for lengths of five or more
 230 you should use the _slow().  In practice this means that the _slow()
 231 will be used very rarely, since the maximum Unicode code point (as of
 232 Unicode 4.1) is U+10FFFF, which encodes in UTF-8 to four bytes.  Only
 233 the "Perl extended UTF-8" (the infamous 'v-strings') will encode into
 234 five bytes or more.
 235
 236 =cut */
 237 STATIC STRLEN
 238 S_is_utf8_char_slow(const U8 *s, const STRLEN len)
 239 {
 240     U8 u = *s;
 241     STRLEN slen;
 242     UV uv, ouv;
 243
 244     PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW;
 245
 246     if (UTF8_IS_INVARIANT(u))
 247         return 1;
 248
 249     if (!UTF8_IS_START(u))
 250         return 0;
 251
 252     if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
 253         return 0;
 254
 255     slen = len - 1;
 256     s++;
 257 #ifdef EBCDIC
 258     u = NATIVE_TO_UTF(u);
 259 #endif
 260     u &= UTF_START_MASK(len);
 261     uv  = u;
 262     ouv = uv;
 263     while (slen--) {
 264         if (!UTF8_IS_CONTINUATION(*s))
 265             return 0;
 266         uv = UTF8_ACCUMULATE(uv, *s);
 267         if (uv < ouv)
 268             return 0;
 269         ouv = uv;
 270         s++;
 271     }
 272
 273     if ((STRLEN)UNISKIP(uv) < len)
 274         return 0;
 275
 276     return len;
 277 }
 278
 279 /*
 280 =for apidoc is_utf8_char
 281
 282 Tests if some arbitrary number of bytes begins in a valid UTF-8
 283 character.  Note that an INVARIANT (i.e. ASCII on non-EBCDIC machines)
 284 character is a valid UTF-8 character.  The actual number of bytes in the UTF-8
 285 character will be returned if it is valid, otherwise 0.
 286
 287 =cut */
 288 STRLEN
 289 Perl_is_utf8_char(const U8 *s)
 290 {
 291     const STRLEN len = UTF8SKIP(s);
 292
 293     PERL_ARGS_ASSERT_IS_UTF8_CHAR;
 294 #ifdef IS_UTF8_CHAR
 295     if (IS_UTF8_CHAR_FAST(len))
 296         return IS_UTF8_CHAR(s, len) ? len : 0;
 297 #endif /* #ifdef IS_UTF8_CHAR */
 298     return is_utf8_char_slow(s, len);
 299 }
 300
 301
 302 /*
 303 =for apidoc is_utf8_string
 304
 305 Returns true if first C<len> bytes of the given string form a valid
 306 UTF-8 string, false otherwise.  Note that 'a valid UTF-8 string' does
 307 not mean 'a string that contains code points above 0x7F encoded in UTF-8'
 308 because a valid ASCII string is a valid UTF-8 string.
 309
 310 See also is_ascii_string(), is_utf8_string_loclen(), and is_utf8_string_loc().
 311
 312 =cut
 313 */
 314
 315 bool
 316 Perl_is_utf8_string(const U8 *s, STRLEN len)
 317 {
 318     const U8* const send = s + (len ? len : strlen((const char *)s));
 319     const U8* x = s;
 320
 321     PERL_ARGS_ASSERT_IS_UTF8_STRING;
 322
 323     while (x < send) {
 324         STRLEN c;
 325          /* Inline the easy bits of is_utf8_char() here for speed... */
 326          if (UTF8_IS_INVARIANT(*x))
 327               c = 1;
 328          else if (!UTF8_IS_START(*x))
 329              goto out;
 330          else {
 331               /* ... and call is_utf8_char() only if really needed. */
 332 #ifdef IS_UTF8_CHAR
 333              c = UTF8SKIP(x);
 334              if (IS_UTF8_CHAR_FAST(c)) {
 335                  if (!IS_UTF8_CHAR(x, c))
 336                      c = 0;
 337              }
 338              else
 339                 c = is_utf8_char_slow(x, c);
 340 #else
 341              c = is_utf8_char(x);
 342 #endif /* #ifdef IS_UTF8_CHAR */
 343               if (!c)
 344                   goto out;
 345          }
 346         x += c;
 347     }
 348
 349  out:
 350     if (x != send)
 351         return FALSE;
 352
 353     return TRUE;
 354 }
 355
 356 /*
 357 Implemented as a macro in utf8.h
 358
 359 =for apidoc is_utf8_string_loc
 360
 361 Like is_utf8_string() but stores the location of the failure (in the
 362 case of "utf8ness failure") or the location s+len (in the case of
 363 "utf8ness success") in the C<ep>.
 364
 365 See also is_utf8_string_loclen() and is_utf8_string().
 366
 367 =for apidoc is_utf8_string_loclen
 368
 369 Like is_utf8_string() but stores the location of the failure (in the
 370 case of "utf8ness failure") or the location s+len (in the case of
 371 "utf8ness success") in the C<ep>, and the number of UTF-8
 372 encoded characters in the C<el>.
 373
 374 See also is_utf8_string_loc() and is_utf8_string().
 375
 376 =cut
 377 */
 378
 379 bool
 380 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
 381 {
 382     const U8* const send = s + (len ? len : strlen((const char *)s));
 383     const U8* x = s;
 384     STRLEN c;
 385     STRLEN outlen = 0;
 386
 387     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
 388
 389     while (x < send) {
 390          /* Inline the easy bits of is_utf8_char() here for speed... */
 391          if (UTF8_IS_INVARIANT(*x))
 392              c = 1;
 393          else if (!UTF8_IS_START(*x))
 394              goto out;
 395          else {
 396              /* ... and call is_utf8_char() only if really needed. */
 397 #ifdef IS_UTF8_CHAR
 398              c = UTF8SKIP(x);
 399              if (IS_UTF8_CHAR_FAST(c)) {
 400                  if (!IS_UTF8_CHAR(x, c))
 401                      c = 0;
 402              } else
 403                  c = is_utf8_char_slow(x, c);
 404 #else
 405              c = is_utf8_char(x);
 406 #endif /* #ifdef IS_UTF8_CHAR */
 407              if (!c)
 408                  goto out;
 409          }
 410          x += c;
 411          outlen++;
 412     }
 413
 414  out:
 415     if (el)
 416         *el = outlen;
 417
 418     if (ep)
 419         *ep = x;
 420     return (x == send);
 421 }
 422
 423 /*
 424
 425 =for apidoc utf8n_to_uvuni
 426
 427 Bottom level UTF-8 decode routine.
 428 Returns the Unicode code point value of the first character in the string C<s>
 429 which is assumed to be in UTF-8 encoding and no longer than C<curlen>;
 430 C<retlen> will be set to the length, in bytes, of that character.
 431
 432 If C<s> does not point to a well-formed UTF-8 character, the behaviour
 433 is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
 434 it is assumed that the caller will raise a warning, and this function
 435 will silently just set C<retlen> to C<-1> and return zero.  If the
 436 C<flags> does not contain UTF8_CHECK_ONLY, warnings about
 437 malformations will be given, C<retlen> will be set to the expected
 438 length of the UTF-8 character in bytes, and zero will be returned.
 439
 440 The C<flags> can also contain various flags to allow deviations from
 441 the strict UTF-8 encoding (see F<utf8.h>).
 442
 443 Most code should use utf8_to_uvchr() rather than call this directly.
 444
 445 =cut
 446 */
 447
 448 UV
 449 Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
 450 {
 451     dVAR;
 452     const U8 * const s0 = s;
 453     UV uv = *s, ouv = 0;
 454     STRLEN len = 1;
 455     const bool dowarn = ckWARN_d(WARN_UTF8);
 456     const UV startbyte = *s;
 457     STRLEN expectlen = 0;
 458     U32 warning = 0;
 459     SV* sv;
 460
 461     PERL_ARGS_ASSERT_UTF8N_TO_UVUNI;
 462
 463 /* This list is a superset of the UTF8_ALLOW_XXX.  BUT it isn't, eg SUPER missing XXX */
 464
 465 #define UTF8_WARN_EMPTY                          1
 466 #define UTF8_WARN_CONTINUATION                   2
 467 #define UTF8_WARN_NON_CONTINUATION               3
 468 #define UTF8_WARN_FE_FF                          4
 469 #define UTF8_WARN_SHORT                          5
 470 #define UTF8_WARN_OVERFLOW                       6
 471 #define UTF8_WARN_SURROGATE                      7
 472 #define UTF8_WARN_LONG                           8
 473 #define UTF8_WARN_FFFF                           9 /* Also FFFE. */
 474
 475     if (curlen == 0 &&
 476         !(flags & UTF8_ALLOW_EMPTY)) {
 477         warning = UTF8_WARN_EMPTY;
 478         goto malformed;
 479     }
 480
 481     if (UTF8_IS_INVARIANT(uv)) {
 482         if (retlen)
 483             *retlen = 1;
 484         return (UV) (NATIVE_TO_UTF(*s));
 485     }
 486
 487     if (UTF8_IS_CONTINUATION(uv) &&
 488         !(flags & UTF8_ALLOW_CONTINUATION)) {
 489         warning = UTF8_WARN_CONTINUATION;
 490         goto malformed;
 491     }
 492
 493     if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
 494         !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
 495         warning = UTF8_WARN_NON_CONTINUATION;
 496         goto malformed;
 497     }
 498
 499 #ifdef EBCDIC
 500     uv = NATIVE_TO_UTF(uv);
 501 #else
 502     if ((uv == 0xfe || uv == 0xff) &&
 503         !(flags & UTF8_ALLOW_FE_FF)) {
 504         warning = UTF8_WARN_FE_FF;
 505         goto malformed;
 506     }
 507 #endif
 508
 509     if      (!(uv & 0x20))      { len =  2; uv &= 0x1f; }
 510     else if (!(uv & 0x10))      { len =  3; uv &= 0x0f; }
 511     else if (!(uv & 0x08))      { len =  4; uv &= 0x07; }
 512     else if (!(uv & 0x04))      { len =  5; uv &= 0x03; }
 513 #ifdef EBCDIC
 514     else if (!(uv & 0x02))      { len =  6; uv &= 0x01; }
 515     else                        { len =  7; uv &= 0x01; }
 516 #else
 517     else if (!(uv & 0x02))      { len =  6; uv &= 0x01; }
 518     else if (!(uv & 0x01))      { len =  7; uv = 0; }
 519     else                        { len = 13; uv = 0; } /* whoa! */
 520 #endif
 521
 522     if (retlen)
 523         *retlen = len;
 524
 525     expectlen = len;
 526
 527     if ((curlen < expectlen) &&
 528         !(flags & UTF8_ALLOW_SHORT)) {
 529         warning = UTF8_WARN_SHORT;
 530         goto malformed;
 531     }
 532
 533     len--;
 534     s++;
 535     ouv = uv;
 536
 537     while (len--) {
 538         if (!UTF8_IS_CONTINUATION(*s) &&
 539             !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
 540             s--;
 541             warning = UTF8_WARN_NON_CONTINUATION;
 542             goto malformed;
 543         }
 544         else
 545             uv = UTF8_ACCUMULATE(uv, *s);
 546         if (!(uv > ouv)) {
 547             /* These cannot be allowed. */
 548             if (uv == ouv) {
 549                 if (expectlen != 13 && !(flags & UTF8_ALLOW_LONG)) {
 550                     warning = UTF8_WARN_LONG;
 551                     goto malformed;
 552                 }
 553             }
 554             else { /* uv < ouv */
 555                 /* This cannot be allowed. */
 556                 warning = UTF8_WARN_OVERFLOW;
 557                 goto malformed;
 558             }
 559         }
 560         s++;
 561         ouv = uv;
 562     }
 563
 564     if (UNICODE_IS_SURROGATE(uv) &&
 565         !(flags & UTF8_ALLOW_SURROGATE)) {
 566         warning = UTF8_WARN_SURROGATE;
 567         goto malformed;
 568     } else if ((expectlen > (STRLEN)UNISKIP(uv)) &&
 569                !(flags & UTF8_ALLOW_LONG)) {
 570         warning = UTF8_WARN_LONG;
 571         goto malformed;
 572     } else if (UNICODE_IS_ILLEGAL(uv) &&
 573                !(flags & UTF8_ALLOW_FFFF)) {
 574         warning = UTF8_WARN_FFFF;
 575         goto malformed;
 576     }
 577
 578     return uv;
 579
 580 malformed:
 581
 582     if (flags & UTF8_CHECK_ONLY) {
 583         if (retlen)
 584             *retlen = ((STRLEN) -1);
 585         return 0;
 586     }
 587
 588     if (dowarn) {
 589         if (warning == UTF8_WARN_FFFF) {
 590             sv = newSVpvs_flags("Unicode non-character ", SVs_TEMP);
 591             Perl_sv_catpvf(aTHX_ sv, "0x%04"UVxf" is illegal for interchange", uv);
 592         }
 593         else {
 594             sv = newSVpvs_flags("Malformed UTF-8 character ", SVs_TEMP);
 595
 596             switch (warning) {
 597                 case 0: /* Intentionally empty. */ break;
 598                 case UTF8_WARN_EMPTY:
 599                     sv_catpvs(sv, "(empty string)");
 600                     break;
 601                 case UTF8_WARN_CONTINUATION:
 602                     Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
 603                     break;
 604                 case UTF8_WARN_NON_CONTINUATION:
 605                     if (s == s0)
 606                         Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
 607                                    (UV)s[1], startbyte);
 608                     else {
 609                         const int len = (int)(s-s0);
 610                         Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
 611                                    (UV)s[1], len, len > 1 ? "s" : "", startbyte, (int)expectlen);
 612                     }
 613
 614                     break;
 615                 case UTF8_WARN_FE_FF:
 616                     Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
 617                     break;
 618                 case UTF8_WARN_SHORT:
 619                     Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
 620                                    (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, startbyte);
 621                     expectlen = curlen;         /* distance for caller to skip */
 622                     break;
 623                 case UTF8_WARN_OVERFLOW:
 624                     Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
 625                                    ouv, *s, startbyte);
 626                     break;
 627                 case UTF8_WARN_SURROGATE:
 628                     Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
 629                     break;
 630                 case UTF8_WARN_LONG:
 631                     Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
 632                                    (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
 633                     break;
 634                 default:
 635                     sv_catpvs(sv, "(unknown reason)");
 636                     break;
 637             }
 638         }
 639
 640         if (warning) {
 641             const char * const s = SvPVX_const(sv);
 642
 643             if (PL_op)
 644                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
 645                             "%s in %s", s,  OP_DESC(PL_op));
 646             else
 647                 Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s);
 648         }
 649     }
 650
 651     if (retlen)
 652         *retlen = expectlen ? expectlen : len;
 653
 654     return 0;
 655 }
 656
 657 /*
 658 =for apidoc utf8_to_uvchr
 659
 660 Returns the native character value of the first character in the string C<s>
 661 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
 662 length, in bytes, of that character.
 663
 664 If C<s> does not point to a well-formed UTF-8 character, zero is
 665 returned and retlen is set, if possible, to -1.
 666
 667 =cut
 668 */
 669
 670 UV
 671 Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
 672 {
 673     PERL_ARGS_ASSERT_UTF8_TO_UVCHR;
 674
 675     return utf8n_to_uvchr(s, UTF8_MAXBYTES, retlen,
 676                           ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
 677 }
 678
 679 /*
 680 =for apidoc utf8_to_uvuni
 681
 682 Returns the Unicode code point of the first character in the string C<s>
 683 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
 684 length, in bytes, of that character.
 685
 686 This function should only be used when the returned UV is considered
 687 an index into the Unicode semantic tables (e.g. swashes).
 688
 689 If C<s> does not point to a well-formed UTF-8 character, zero is
 690 returned and retlen is set, if possible, to -1.
 691
 692 =cut
 693 */
 694
 695 UV
 696 Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
 697 {
 698     PERL_ARGS_ASSERT_UTF8_TO_UVUNI;
 699
 700     /* Call the low level routine asking for checks */
 701     return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXBYTES, retlen,
 702                                ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
 703 }
 704
 705 /*
 706 =for apidoc utf8_length
 707
 708 Return the length of the UTF-8 char encoded string C<s> in characters.
 709 Stops at C<e> (inclusive).  If C<e E<lt> s> or if the scan would end
 710 up past C<e>, croaks.
 711
 712 =cut
 713 */
 714
 715 STRLEN
 716 Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
 717 {
 718     dVAR;
 719     STRLEN len = 0;
 720
 721     PERL_ARGS_ASSERT_UTF8_LENGTH;
 722
 723     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
 724      * the bitops (especially ~) can create illegal UTF-8.
 725      * In other words: in Perl UTF-8 is not just for Unicode. */
 726
 727     if (e < s)
 728         goto warn_and_return;
 729     while (s < e) {
 730         if (!UTF8_IS_INVARIANT(*s))
 731             s += UTF8SKIP(s);
 732         else
 733             s++;
 734         len++;
 735     }
 736
 737     if (e != s) {
 738         len--;
 739         warn_and_return:
 740         if (PL_op)
 741             Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
 742                              "%s in %s", unees, OP_DESC(PL_op));
 743         else
 744             Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), unees);
 745     }
 746
 747     return len;
 748 }
 749
 750 /*
 751 =for apidoc utf8_distance
 752
 753 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
 754 and C<b>.
 755
 756 WARNING: use only if you *know* that the pointers point inside the
 757 same UTF-8 buffer.
 758
 759 =cut
 760 */
 761
 762 IV
 763 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
 764 {
 765     PERL_ARGS_ASSERT_UTF8_DISTANCE;
 766
 767     return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
 768 }
 769
 770 /*
 771 =for apidoc utf8_hop
 772
 773 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
 774 forward or backward.
 775
 776 WARNING: do not use the following unless you *know* C<off> is within
 777 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
 778 on the first byte of character or just after the last byte of a character.
 779
 780 =cut
 781 */
 782
 783 U8 *
 784 Perl_utf8_hop(pTHX_ const U8 *s, I32 off)
 785 {
 786     PERL_ARGS_ASSERT_UTF8_HOP;
 787
 788     PERL_UNUSED_CONTEXT;
 789     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
 790      * the bitops (especially ~) can create illegal UTF-8.
 791      * In other words: in Perl UTF-8 is not just for Unicode. */
 792
 793     if (off >= 0) {
 794         while (off--)
 795             s += UTF8SKIP(s);
 796     }
 797     else {
 798         while (off++) {
 799             s--;
 800             while (UTF8_IS_CONTINUATION(*s))
 801                 s--;
 802         }
 803     }
 804     return (U8 *)s;
 805 }
 806
 807 /*
 808 =for apidoc bytes_cmp_utf8
 809
 810 Compares the sequence of characters (stored as octets) in b, blen with the
 811 sequence of characters (stored as UTF-8) in u, ulen. Returns 0 if they are
 812 equal, -1 or -2 if the first string is less than the second string, +1 or +2
 813 if the first string is greater than the second string.
 814
 815 -1 or +1 is returned if the shorter string was identical to the start of the
 816 longer string. -2 or +2 is returned if the was a difference between characters
 817 within the strings.
 818
 819 =cut
 820 */
 821
 822 int
 823 Perl_bytes_cmp_utf8(pTHX_ const U8 *b, STRLEN blen, const U8 *u, STRLEN ulen)
 824 {
 825     const U8 *const bend = b + blen;
 826     const U8 *const uend = u + ulen;
 827
 828     PERL_ARGS_ASSERT_BYTES_CMP_UTF8;
 829
 830     PERL_UNUSED_CONTEXT;
 831
 832     while (b < bend && u < uend) {
 833         U8 c = *u++;
 834         if (!UTF8_IS_INVARIANT(c)) {
 835             if (UTF8_IS_DOWNGRADEABLE_START(c)) {
 836                 if (u < uend) {
 837                     U8 c1 = *u++;
 838                     if (UTF8_IS_CONTINUATION(c1)) {
 839                         c = UTF8_ACCUMULATE(NATIVE_TO_UTF(c), c1);
 840                         c = ASCII_TO_NATIVE(c);
 841                     } else {
 842                         Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
 843                                          "Malformed UTF-8 character "
 844                                          "(unexpected non-continuation byte 0x%02x"
 845                                          ", immediately after start byte 0x%02x)"
 846                                          /* Dear diag.t, it's in the pod.  */
 847                                          "%s%s", c1, c,
 848                                          PL_op ? " in " : "",
 849                                          PL_op ? OP_DESC(PL_op) : "");
 850                         return -2;
 851                     }
 852                 } else {
 853                     if (PL_op)
 854                         Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
 855                                          "%s in %s", unees, OP_DESC(PL_op));
 856                     else
 857                         Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), unees);
 858                     return -2; /* Really want to return undef :-)  */
 859                 }
 860             } else {
 861                 return -2;
 862             }
 863         }
 864         if (*b != c) {
 865             return *b < c ? -2 : +2;
 866         }
 867         ++b;
 868     }
 869
 870     if (b == bend && u == uend)
 871         return 0;
 872
 873     return b < bend ? +1 : -1;
 874 }
 875
 876 /*
 877 =for apidoc utf8_to_bytes
 878
 879 Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
 880 Unlike C<bytes_to_utf8>, this over-writes the original string, and
 881 updates len to contain the new length.
 882 Returns zero on failure, setting C<len> to -1.
 883
 884 If you need a copy of the string, see C<bytes_from_utf8>.
 885
 886 =cut
 887 */
 888
 889 U8 *
 890 Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
 891 {
 892     U8 * const save = s;
 893     U8 * const send = s + *len;
 894     U8 *d;
 895
 896     PERL_ARGS_ASSERT_UTF8_TO_BYTES;
 897
 898     /* ensure valid UTF-8 and chars < 256 before updating string */
 899     while (s < send) {
 900         U8 c = *s++;
 901
 902         if (!UTF8_IS_INVARIANT(c) &&
 903             (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
 904              || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
 905             *len = ((STRLEN) -1);
 906             return 0;
 907         }
 908     }
 909
 910     d = s = save;
 911     while (s < send) {
 912         STRLEN ulen;
 913         *d++ = (U8)utf8_to_uvchr(s, &ulen);
 914         s += ulen;
 915     }
 916     *d = '\0';
 917     *len = d - save;
 918     return save;
 919 }
 920
 921 /*
 922 =for apidoc bytes_from_utf8
 923
 924 Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
 925 Unlike C<utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
 926 the newly-created string, and updates C<len> to contain the new
 927 length.  Returns the original string if no conversion occurs, C<len>
 928 is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
 929 0 if C<s> is converted or consisted entirely of characters that are invariant
 930 in utf8 (i.e., US-ASCII on non-EBCDIC machines).
 931
 932 =cut
 933 */
 934
 935 U8 *
 936 Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8)
 937 {
 938     U8 *d;
 939     const U8 *start = s;
 940     const U8 *send;
 941     I32 count = 0;
 942
 943     PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
 944
 945     PERL_UNUSED_CONTEXT;
 946     if (!*is_utf8)
 947         return (U8 *)start;
 948
 949     /* ensure valid UTF-8 and chars < 256 before converting string */
 950     for (send = s + *len; s < send;) {
 951         U8 c = *s++;
 952         if (!UTF8_IS_INVARIANT(c)) {
 953             if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
 954                 (c = *s++) && UTF8_IS_CONTINUATION(c))
 955                 count++;
 956             else
 957                 return (U8 *)start;
 958         }
 959     }
 960
 961     *is_utf8 = FALSE;
 962
 963     Newx(d, (*len) - count + 1, U8);
 964     s = start; start = d;
 965     while (s < send) {
 966         U8 c = *s++;
 967         if (!UTF8_IS_INVARIANT(c)) {
 968             /* Then it is two-byte encoded */
 969             c = UTF8_ACCUMULATE(NATIVE_TO_UTF(c), *s++);
 970             c = ASCII_TO_NATIVE(c);
 971         }
 972         *d++ = c;
 973     }
 974     *d = '\0';
 975     *len = d - start;
 976     return (U8 *)start;
 977 }
 978
 979 /*
 980 =for apidoc bytes_to_utf8
 981
 982 Converts a string C<s> of length C<len> from the native encoding into UTF-8.
 983 Returns a pointer to the newly-created string, and sets C<len> to
 984 reflect the new length.
 985
 986 A NUL character will be written after the end of the string.
 987
 988 If you want to convert to UTF-8 from encodings other than
 989 the native (Latin1 or EBCDIC),
 990 see sv_recode_to_utf8().
 991
 992 =cut
 993 */
 994
 995 U8*
 996 Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len)
 997 {
 998     const U8 * const send = s + (*len);
 999     U8 *d;
1000     U8 *dst;
1001
1002     PERL_ARGS_ASSERT_BYTES_TO_UTF8;
1003     PERL_UNUSED_CONTEXT;
1004
1005     Newx(d, (*len) * 2 + 1, U8);
1006     dst = d;
1007
1008     while (s < send) {
1009         const UV uv = NATIVE_TO_ASCII(*s++);
1010         if (UNI_IS_INVARIANT(uv))
1011             *d++ = (U8)UTF_TO_NATIVE(uv);
1012         else {
1013             *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
1014             *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
1015         }
1016     }
1017     *d = '\0';
1018     *len = d-dst;
1019     return dst;
1020 }
1021
1022 /*
1023  * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
1024  *
1025  * Destination must be pre-extended to 3/2 source.  Do not use in-place.
1026  * We optimize for native, for obvious reasons. */
1027
1028 U8*
1029 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
1030 {
1031     U8* pend;
1032     U8* dstart = d;
1033
1034     PERL_ARGS_ASSERT_UTF16_TO_UTF8;
1035
1036     if (bytelen & 1)
1037         Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %"UVuf, (UV)bytelen);
1038
1039     pend = p + bytelen;
1040
1041     while (p < pend) {
1042         UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
1043         p += 2;
1044         if (uv < 0x80) {
1045 #ifdef EBCDIC
1046             *d++ = UNI_TO_NATIVE(uv);
1047 #else
1048             *d++ = (U8)uv;
1049 #endif
1050             continue;
1051         }
1052         if (uv < 0x800) {
1053             *d++ = (U8)(( uv >>  6)         | 0xc0);
1054             *d++ = (U8)(( uv        & 0x3f) | 0x80);
1055             continue;
1056         }
1057         if (uv >= 0xd800 && uv <= 0xdbff) {     /* surrogates */
1058             if (p >= pend) {
1059                 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
1060             } else {
1061                 UV low = (p[0] << 8) + p[1];
1062                 p += 2;
1063                 if (low < 0xdc00 || low > 0xdfff)
1064                     Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
1065                 uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
1066             }
1067         } else if (uv >= 0xdc00 && uv <= 0xdfff) {
1068             Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
1069         }
1070         if (uv < 0x10000) {
1071             *d++ = (U8)(( uv >> 12)         | 0xe0);
1072             *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
1073             *d++ = (U8)(( uv        & 0x3f) | 0x80);
1074             continue;
1075         }
1076         else {
1077             *d++ = (U8)(( uv >> 18)         | 0xf0);
1078             *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
1079             *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
1080             *d++ = (U8)(( uv        & 0x3f) | 0x80);
1081             continue;
1082         }
1083     }
1084     *newlen = d - dstart;
1085     return d;
1086 }
1087
1088 /* Note: this one is slightly destructive of the source. */
1089
1090 U8*
1091 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
1092 {
1093     U8* s = (U8*)p;
1094     U8* const send = s + bytelen;
1095
1096     PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED;
1097
1098     if (bytelen & 1)
1099         Perl_croak(aTHX_ "panic: utf16_to_utf8_reversed: odd bytelen %"UVuf,
1100                    (UV)bytelen);
1101
1102     while (s < send) {
1103         const U8 tmp = s[0];
1104         s[0] = s[1];
1105         s[1] = tmp;
1106         s += 2;
1107     }
1108     return utf16_to_utf8(p, d, bytelen, newlen);
1109 }
1110
1111 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
1112
1113 bool
1114 Perl_is_uni_alnum(pTHX_ UV c)
1115 {
1116     U8 tmpbuf[UTF8_MAXBYTES+1];
1117     uvchr_to_utf8(tmpbuf, c);
1118     return is_utf8_alnum(tmpbuf);
1119 }
1120
1121 bool
1122 Perl_is_uni_idfirst(pTHX_ UV c)
1123 {
1124     U8 tmpbuf[UTF8_MAXBYTES+1];
1125     uvchr_to_utf8(tmpbuf, c);
1126     return is_utf8_idfirst(tmpbuf);
1127 }
1128
1129 bool
1130 Perl_is_uni_alpha(pTHX_ UV c)
1131 {
1132     U8 tmpbuf[UTF8_MAXBYTES+1];
1133     uvchr_to_utf8(tmpbuf, c);
1134     return is_utf8_alpha(tmpbuf);
1135 }
1136
1137 bool
1138 Perl_is_uni_ascii(pTHX_ UV c)
1139 {
1140     U8 tmpbuf[UTF8_MAXBYTES+1];
1141     uvchr_to_utf8(tmpbuf, c);
1142     return is_utf8_ascii(tmpbuf);
1143 }
1144
1145 bool
1146 Perl_is_uni_space(pTHX_ UV c)
1147 {
1148     U8 tmpbuf[UTF8_MAXBYTES+1];
1149     uvchr_to_utf8(tmpbuf, c);
1150     return is_utf8_space(tmpbuf);
1151 }
1152
1153 bool
1154 Perl_is_uni_digit(pTHX_ UV c)
1155 {
1156     U8 tmpbuf[UTF8_MAXBYTES+1];
1157     uvchr_to_utf8(tmpbuf, c);
1158     return is_utf8_digit(tmpbuf);
1159 }
1160
1161 bool
1162 Perl_is_uni_upper(pTHX_ UV c)
1163 {
1164     U8 tmpbuf[UTF8_MAXBYTES+1];
1165     uvchr_to_utf8(tmpbuf, c);
1166     return is_utf8_upper(tmpbuf);
1167 }
1168
1169 bool
1170 Perl_is_uni_lower(pTHX_ UV c)
1171 {
1172     U8 tmpbuf[UTF8_MAXBYTES+1];
1173     uvchr_to_utf8(tmpbuf, c);
1174     return is_utf8_lower(tmpbuf);
1175 }
1176
1177 bool
1178 Perl_is_uni_cntrl(pTHX_ UV c)
1179 {
1180     U8 tmpbuf[UTF8_MAXBYTES+1];
1181     uvchr_to_utf8(tmpbuf, c);
1182     return is_utf8_cntrl(tmpbuf);
1183 }
1184
1185 bool
1186 Perl_is_uni_graph(pTHX_ UV c)
1187 {
1188     U8 tmpbuf[UTF8_MAXBYTES+1];
1189     uvchr_to_utf8(tmpbuf, c);
1190     return is_utf8_graph(tmpbuf);
1191 }
1192
1193 bool
1194 Perl_is_uni_print(pTHX_ UV c)
1195 {
1196     U8 tmpbuf[UTF8_MAXBYTES+1];
1197     uvchr_to_utf8(tmpbuf, c);
1198     return is_utf8_print(tmpbuf);
1199 }
1200
1201 bool
1202 Perl_is_uni_punct(pTHX_ UV c)
1203 {
1204     U8 tmpbuf[UTF8_MAXBYTES+1];
1205     uvchr_to_utf8(tmpbuf, c);
1206     return is_utf8_punct(tmpbuf);
1207 }
1208
1209 bool
1210 Perl_is_uni_xdigit(pTHX_ UV c)
1211 {
1212     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1213     uvchr_to_utf8(tmpbuf, c);
1214     return is_utf8_xdigit(tmpbuf);
1215 }
1216
1217 UV
1218 Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
1219 {
1220     PERL_ARGS_ASSERT_TO_UNI_UPPER;
1221
1222     uvchr_to_utf8(p, c);
1223     return to_utf8_upper(p, p, lenp);
1224 }
1225
1226 UV
1227 Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
1228 {
1229     PERL_ARGS_ASSERT_TO_UNI_TITLE;
1230
1231     uvchr_to_utf8(p, c);
1232     return to_utf8_title(p, p, lenp);
1233 }
1234
1235 UV
1236 Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
1237 {
1238     PERL_ARGS_ASSERT_TO_UNI_LOWER;
1239
1240     uvchr_to_utf8(p, c);
1241     return to_utf8_lower(p, p, lenp);
1242 }
1243
1244 UV
1245 Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
1246 {
1247     PERL_ARGS_ASSERT_TO_UNI_FOLD;
1248
1249     uvchr_to_utf8(p, c);
1250     return to_utf8_fold(p, p, lenp);
1251 }
1252
1253 /* for now these all assume no locale info available for Unicode > 255 */
1254
1255 bool
1256 Perl_is_uni_alnum_lc(pTHX_ UV c)
1257 {
1258     return is_uni_alnum(c);     /* XXX no locale support yet */
1259 }
1260
1261 bool
1262 Perl_is_uni_idfirst_lc(pTHX_ UV c)
1263 {
1264     return is_uni_idfirst(c);   /* XXX no locale support yet */
1265 }
1266
1267 bool
1268 Perl_is_uni_alpha_lc(pTHX_ UV c)
1269 {
1270     return is_uni_alpha(c);     /* XXX no locale support yet */
1271 }
1272
1273 bool
1274 Perl_is_uni_ascii_lc(pTHX_ UV c)
1275 {
1276     return is_uni_ascii(c);     /* XXX no locale support yet */
1277 }
1278
1279 bool
1280 Perl_is_uni_space_lc(pTHX_ UV c)
1281 {
1282     return is_uni_space(c);     /* XXX no locale support yet */
1283 }
1284
1285 bool
1286 Perl_is_uni_digit_lc(pTHX_ UV c)
1287 {
1288     return is_uni_digit(c);     /* XXX no locale support yet */
1289 }
1290
1291 bool
1292 Perl_is_uni_upper_lc(pTHX_ UV c)
1293 {
1294     return is_uni_upper(c);     /* XXX no locale support yet */
1295 }
1296
1297 bool
1298 Perl_is_uni_lower_lc(pTHX_ UV c)
1299 {
1300     return is_uni_lower(c);     /* XXX no locale support yet */
1301 }
1302
1303 bool
1304 Perl_is_uni_cntrl_lc(pTHX_ UV c)
1305 {
1306     return is_uni_cntrl(c);     /* XXX no locale support yet */
1307 }
1308
1309 bool
1310 Perl_is_uni_graph_lc(pTHX_ UV c)
1311 {
1312     return is_uni_graph(c);     /* XXX no locale support yet */
1313 }
1314
1315 bool
1316 Perl_is_uni_print_lc(pTHX_ UV c)
1317 {
1318     return is_uni_print(c);     /* XXX no locale support yet */
1319 }
1320
1321 bool
1322 Perl_is_uni_punct_lc(pTHX_ UV c)
1323 {
1324     return is_uni_punct(c);     /* XXX no locale support yet */
1325 }
1326
1327 bool
1328 Perl_is_uni_xdigit_lc(pTHX_ UV c)
1329 {
1330     return is_uni_xdigit(c);    /* XXX no locale support yet */
1331 }
1332
1333 U32
1334 Perl_to_uni_upper_lc(pTHX_ U32 c)
1335 {
1336     /* XXX returns only the first character -- do not use XXX */
1337     /* XXX no locale support yet */
1338     STRLEN len;
1339     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1340     return (U32)to_uni_upper(c, tmpbuf, &len);
1341 }
1342
1343 U32
1344 Perl_to_uni_title_lc(pTHX_ U32 c)
1345 {
1346     /* XXX returns only the first character XXX -- do not use XXX */
1347     /* XXX no locale support yet */
1348     STRLEN len;
1349     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1350     return (U32)to_uni_title(c, tmpbuf, &len);
1351 }
1352
1353 U32
1354 Perl_to_uni_lower_lc(pTHX_ U32 c)
1355 {
1356     /* XXX returns only the first character -- do not use XXX */
1357     /* XXX no locale support yet */
1358     STRLEN len;
1359     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1360     return (U32)to_uni_lower(c, tmpbuf, &len);
1361 }
1362
1363 static bool
1364 S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
1365                  const char *const swashname)
1366 {
1367     dVAR;
1368
1369     PERL_ARGS_ASSERT_IS_UTF8_COMMON;
1370
1371     if (!is_utf8_char(p))
1372         return FALSE;
1373     if (!*swash)
1374         *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0);
1375     return swash_fetch(*swash, p, TRUE) != 0;
1376 }
1377
1378 bool
1379 Perl_is_utf8_alnum(pTHX_ const U8 *p)
1380 {
1381     dVAR;
1382
1383     PERL_ARGS_ASSERT_IS_UTF8_ALNUM;
1384
1385     /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1386      * descendant of isalnum(3), in other words, it doesn't
1387      * contain the '_'. --jhi */
1388     return is_utf8_common(p, &PL_utf8_alnum, "IsWord");
1389 }
1390
1391 bool
1392 Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
1393 {
1394     dVAR;
1395
1396     PERL_ARGS_ASSERT_IS_UTF8_IDFIRST;
1397
1398     if (*p == '_')
1399         return TRUE;
1400     /* is_utf8_idstart would be more logical. */
1401     return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
1402 }
1403
1404 bool
1405 Perl_is_utf8_idcont(pTHX_ const U8 *p)
1406 {
1407     dVAR;
1408
1409     PERL_ARGS_ASSERT_IS_UTF8_IDCONT;
1410
1411     if (*p == '_')
1412         return TRUE;
1413     return is_utf8_common(p, &PL_utf8_idcont, "IdContinue");
1414 }
1415
1416 bool
1417 Perl_is_utf8_alpha(pTHX_ const U8 *p)
1418 {
1419     dVAR;
1420
1421     PERL_ARGS_ASSERT_IS_UTF8_ALPHA;
1422
1423     return is_utf8_common(p, &PL_utf8_alpha, "IsAlpha");
1424 }
1425
1426 bool
1427 Perl_is_utf8_ascii(pTHX_ const U8 *p)
1428 {
1429     dVAR;
1430
1431     PERL_ARGS_ASSERT_IS_UTF8_ASCII;
1432
1433     return is_utf8_common(p, &PL_utf8_ascii, "IsAscii");
1434 }
1435
1436 bool
1437 Perl_is_utf8_space(pTHX_ const U8 *p)
1438 {
1439     dVAR;
1440
1441     PERL_ARGS_ASSERT_IS_UTF8_SPACE;
1442
1443     return is_utf8_common(p, &PL_utf8_space, "IsSpacePerl");
1444 }
1445
1446 bool
1447 Perl_is_utf8_perl_space(pTHX_ const U8 *p)
1448 {
1449     dVAR;
1450
1451     PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE;
1452
1453     return is_utf8_common(p, &PL_utf8_perl_space, "IsPerlSpace");
1454 }
1455
1456 bool
1457 Perl_is_utf8_perl_word(pTHX_ const U8 *p)
1458 {
1459     dVAR;
1460
1461     PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD;
1462
1463     return is_utf8_common(p, &PL_utf8_perl_word, "IsPerlWord");
1464 }
1465
1466 bool
1467 Perl_is_utf8_digit(pTHX_ const U8 *p)
1468 {
1469     dVAR;
1470
1471     PERL_ARGS_ASSERT_IS_UTF8_DIGIT;
1472
1473     return is_utf8_common(p, &PL_utf8_digit, "IsDigit");
1474 }
1475
1476 bool
1477 Perl_is_utf8_posix_digit(pTHX_ const U8 *p)
1478 {
1479     dVAR;
1480
1481     PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT;
1482
1483     return is_utf8_common(p, &PL_utf8_posix_digit, "IsPosixDigit");
1484 }
1485
1486 bool
1487 Perl_is_utf8_upper(pTHX_ const U8 *p)
1488 {
1489     dVAR;
1490
1491     PERL_ARGS_ASSERT_IS_UTF8_UPPER;
1492
1493     return is_utf8_common(p, &PL_utf8_upper, "IsUppercase");
1494 }
1495
1496 bool
1497 Perl_is_utf8_lower(pTHX_ const U8 *p)
1498 {
1499     dVAR;
1500
1501     PERL_ARGS_ASSERT_IS_UTF8_LOWER;
1502
1503     return is_utf8_common(p, &PL_utf8_lower, "IsLowercase");
1504 }
1505
1506 bool
1507 Perl_is_utf8_cntrl(pTHX_ const U8 *p)
1508 {
1509     dVAR;
1510
1511     PERL_ARGS_ASSERT_IS_UTF8_CNTRL;
1512
1513     return is_utf8_common(p, &PL_utf8_cntrl, "IsCntrl");
1514 }
1515
1516 bool
1517 Perl_is_utf8_graph(pTHX_ const U8 *p)
1518 {
1519     dVAR;
1520
1521     PERL_ARGS_ASSERT_IS_UTF8_GRAPH;
1522
1523     return is_utf8_common(p, &PL_utf8_graph, "IsGraph");
1524 }
1525
1526 bool
1527 Perl_is_utf8_print(pTHX_ const U8 *p)
1528 {
1529     dVAR;
1530
1531     PERL_ARGS_ASSERT_IS_UTF8_PRINT;
1532
1533     return is_utf8_common(p, &PL_utf8_print, "IsPrint");
1534 }
1535
1536 bool
1537 Perl_is_utf8_punct(pTHX_ const U8 *p)
1538 {
1539     dVAR;
1540
1541     PERL_ARGS_ASSERT_IS_UTF8_PUNCT;
1542
1543     return is_utf8_common(p, &PL_utf8_punct, "IsPunct");
1544 }
1545
1546 bool
1547 Perl_is_utf8_xdigit(pTHX_ const U8 *p)
1548 {
1549     dVAR;
1550
1551     PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
1552
1553     return is_utf8_common(p, &PL_utf8_xdigit, "IsXDigit");
1554 }
1555
1556 bool
1557 Perl_is_utf8_mark(pTHX_ const U8 *p)
1558 {
1559     dVAR;
1560
1561     PERL_ARGS_ASSERT_IS_UTF8_MARK;
1562
1563     return is_utf8_common(p, &PL_utf8_mark, "IsM");
1564 }
1565
1566 bool
1567 Perl_is_utf8_X_begin(pTHX_ const U8 *p)
1568 {
1569     dVAR;
1570
1571     PERL_ARGS_ASSERT_IS_UTF8_X_BEGIN;
1572
1573     return is_utf8_common(p, &PL_utf8_X_begin, "_X_Begin");
1574 }
1575
1576 bool
1577 Perl_is_utf8_X_extend(pTHX_ const U8 *p)
1578 {
1579     dVAR;
1580
1581     PERL_ARGS_ASSERT_IS_UTF8_X_EXTEND;
1582
1583     return is_utf8_common(p, &PL_utf8_X_extend, "_X_Extend");
1584 }
1585
1586 bool
1587 Perl_is_utf8_X_prepend(pTHX_ const U8 *p)
1588 {
1589     dVAR;
1590
1591     PERL_ARGS_ASSERT_IS_UTF8_X_PREPEND;
1592
1593     return is_utf8_common(p, &PL_utf8_X_prepend, "GCB=Prepend");
1594 }
1595
1596 bool
1597 Perl_is_utf8_X_non_hangul(pTHX_ const U8 *p)
1598 {
1599     dVAR;
1600
1601     PERL_ARGS_ASSERT_IS_UTF8_X_NON_HANGUL;
1602
1603     return is_utf8_common(p, &PL_utf8_X_non_hangul, "HST=Not_Applicable");
1604 }
1605
1606 bool
1607 Perl_is_utf8_X_L(pTHX_ const U8 *p)
1608 {
1609     dVAR;
1610
1611     PERL_ARGS_ASSERT_IS_UTF8_X_L;
1612
1613     return is_utf8_common(p, &PL_utf8_X_L, "GCB=L");
1614 }
1615
1616 bool
1617 Perl_is_utf8_X_LV(pTHX_ const U8 *p)
1618 {
1619     dVAR;
1620
1621     PERL_ARGS_ASSERT_IS_UTF8_X_LV;
1622
1623     return is_utf8_common(p, &PL_utf8_X_LV, "GCB=LV");
1624 }
1625
1626 bool
1627 Perl_is_utf8_X_LVT(pTHX_ const U8 *p)
1628 {
1629     dVAR;
1630
1631     PERL_ARGS_ASSERT_IS_UTF8_X_LVT;
1632
1633     return is_utf8_common(p, &PL_utf8_X_LVT, "GCB=LVT");
1634 }
1635
1636 bool
1637 Perl_is_utf8_X_T(pTHX_ const U8 *p)
1638 {
1639     dVAR;
1640
1641     PERL_ARGS_ASSERT_IS_UTF8_X_T;
1642
1643     return is_utf8_common(p, &PL_utf8_X_T, "GCB=T");
1644 }
1645
1646 bool
1647 Perl_is_utf8_X_V(pTHX_ const U8 *p)
1648 {
1649     dVAR;
1650
1651     PERL_ARGS_ASSERT_IS_UTF8_X_V;
1652
1653     return is_utf8_common(p, &PL_utf8_X_V, "GCB=V");
1654 }
1655
1656 bool
1657 Perl_is_utf8_X_LV_LVT_V(pTHX_ const U8 *p)
1658 {
1659     dVAR;
1660
1661     PERL_ARGS_ASSERT_IS_UTF8_X_LV_LVT_V;
1662
1663     return is_utf8_common(p, &PL_utf8_X_LV_LVT_V, "_X_LV_LVT_V");
1664 }
1665
1666 /*
1667 =for apidoc to_utf8_case
1668
1669 The "p" contains the pointer to the UTF-8 string encoding
1670 the character that is being converted.
1671
1672 The "ustrp" is a pointer to the character buffer to put the
1673 conversion result to.  The "lenp" is a pointer to the length
1674 of the result.
1675
1676 The "swashp" is a pointer to the swash to use.
1677
1678 Both the special and normal mappings are stored lib/unicore/To/Foo.pl,
1679 and loaded by SWASHNEW, using lib/utf8_heavy.pl.  The special (usually,
1680 but not always, a multicharacter mapping), is tried first.
1681
1682 The "special" is a string like "utf8::ToSpecLower", which means the
1683 hash %utf8::ToSpecLower.  The access to the hash is through
1684 Perl_to_utf8_case().
1685
1686 The "normal" is a string like "ToLower" which means the swash
1687 %utf8::ToLower.
1688
1689 =cut */
1690
1691 UV
1692 Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
1693                         SV **swashp, const char *normal, const char *special)
1694 {
1695     dVAR;
1696     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1697     STRLEN len = 0;
1698     const UV uv0 = utf8_to_uvchr(p, NULL);
1699     /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
1700      * are necessary in EBCDIC, they are redundant no-ops
1701      * in ASCII-ish platforms, and hopefully optimized away. */
1702     const UV uv1 = NATIVE_TO_UNI(uv0);
1703
1704     PERL_ARGS_ASSERT_TO_UTF8_CASE;
1705
1706     uvuni_to_utf8(tmpbuf, uv1);
1707
1708     if (!*swashp) /* load on-demand */
1709          *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1710     /* This is the beginnings of a skeleton of code to read the info section
1711      * that is in all the swashes in case we ever want to do that, so one can
1712      * read things whose maps aren't code points, and whose default if missing
1713      * is not to the code point itself.  This was just to see if it actually
1714      * worked.  Details on what the possibilities are are in perluniprops.pod
1715         HV * const hv = get_hv("utf8::SwashInfo", 0);
1716         if (hv) {
1717          SV **svp;
1718          svp = hv_fetch(hv, (const char*)normal, strlen(normal), FALSE);
1719              const char *s;
1720
1721               HV * const this_hash = SvRV(*svp);
1722                 svp = hv_fetch(this_hash, "type", strlen("type"), FALSE);
1723               s = SvPV_const(*svp, len);
1724         }
1725     }*/
1726
1727     if (special) {
1728          /* It might be "special" (sometimes, but not always,
1729           * a multicharacter mapping) */
1730          HV * const hv = get_hv(special, 0);
1731          SV **svp;
1732
1733          if (hv &&
1734              (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
1735              (*svp)) {
1736              const char *s;
1737
1738               s = SvPV_const(*svp, len);
1739               if (len == 1)
1740                    len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
1741               else {
1742 #ifdef EBCDIC
1743                    /* If we have EBCDIC we need to remap the characters
1744                     * since any characters in the low 256 are Unicode
1745                     * code points, not EBCDIC. */
1746                    U8 *t = (U8*)s, *tend = t + len, *d;
1747
1748                    d = tmpbuf;
1749                    if (SvUTF8(*svp)) {
1750                         STRLEN tlen = 0;
1751
1752                         while (t < tend) {
1753                              const UV c = utf8_to_uvchr(t, &tlen);
1754                              if (tlen > 0) {
1755                                   d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
1756                                   t += tlen;
1757                              }
1758                              else
1759                                   break;
1760                         }
1761                    }
1762                    else {
1763                         while (t < tend) {
1764                              d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
1765                              t++;
1766                         }
1767                    }
1768                    len = d - tmpbuf;
1769                    Copy(tmpbuf, ustrp, len, U8);
1770 #else
1771                    Copy(s, ustrp, len, U8);
1772 #endif
1773               }
1774          }
1775     }
1776
1777     if (!len && *swashp) {
1778         const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
1779
1780          if (uv2) {
1781               /* It was "normal" (a single character mapping). */
1782               const UV uv3 = UNI_TO_NATIVE(uv2);
1783               len = uvchr_to_utf8(ustrp, uv3) - ustrp;
1784          }
1785     }
1786
1787     if (!len) /* Neither: just copy.  In other words, there was no mapping
1788                  defined, which means that the code point maps to itself */
1789          len = uvchr_to_utf8(ustrp, uv0) - ustrp;
1790
1791     if (lenp)
1792          *lenp = len;
1793
1794     return len ? utf8_to_uvchr(ustrp, 0) : 0;
1795 }
1796
1797 /*
1798 =for apidoc to_utf8_upper
1799
1800 Convert the UTF-8 encoded character at p to its uppercase version and
1801 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1802 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
1803 the uppercase version may be longer than the original character.
1804
1805 The first character of the uppercased version is returned
1806 (but note, as explained above, that there may be more.)
1807
1808 =cut */
1809
1810 UV
1811 Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1812 {
1813     dVAR;
1814
1815     PERL_ARGS_ASSERT_TO_UTF8_UPPER;
1816
1817     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1818                              &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
1819 }
1820
1821 /*
1822 =for apidoc to_utf8_title
1823
1824 Convert the UTF-8 encoded character at p to its titlecase version and
1825 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1826 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1827 titlecase version may be longer than the original character.
1828
1829 The first character of the titlecased version is returned
1830 (but note, as explained above, that there may be more.)
1831
1832 =cut */
1833
1834 UV
1835 Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1836 {
1837     dVAR;
1838
1839     PERL_ARGS_ASSERT_TO_UTF8_TITLE;
1840
1841     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1842                              &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
1843 }
1844
1845 /*
1846 =for apidoc to_utf8_lower
1847
1848 Convert the UTF-8 encoded character at p to its lowercase version and
1849 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1850 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1851 lowercase version may be longer than the original character.
1852
1853 The first character of the lowercased version is returned
1854 (but note, as explained above, that there may be more.)
1855
1856 =cut */
1857
1858 UV
1859 Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1860 {
1861     dVAR;
1862
1863     PERL_ARGS_ASSERT_TO_UTF8_LOWER;
1864
1865     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1866                              &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
1867 }
1868
1869 /*
1870 =for apidoc to_utf8_fold
1871
1872 Convert the UTF-8 encoded character at p to its foldcase version and
1873 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1874 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1875 foldcase version may be longer than the original character (up to
1876 three characters).
1877
1878 The first character of the foldcased version is returned
1879 (but note, as explained above, that there may be more.)
1880
1881 =cut */
1882
1883 UV
1884 Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1885 {
1886     dVAR;
1887
1888     PERL_ARGS_ASSERT_TO_UTF8_FOLD;
1889
1890     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1891                              &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
1892 }
1893
1894 /* Note:
1895  * A "swash" is a swatch hash.
1896  * A "swatch" is a bit vector generated by utf8.c:S_swash_get().
1897  * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
1898  * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
1899  */
1900 SV*
1901 Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
1902 {
1903     dVAR;
1904     SV* retval;
1905     dSP;
1906     const size_t pkg_len = strlen(pkg);
1907     const size_t name_len = strlen(name);
1908     HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
1909     SV* errsv_save;
1910
1911     PERL_ARGS_ASSERT_SWASH_INIT;
1912
1913     PUSHSTACKi(PERLSI_MAGIC);
1914     ENTER;
1915     SAVEHINTS();
1916     save_re_context();
1917     if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) {      /* demand load utf8 */
1918         ENTER;
1919         errsv_save = newSVsv(ERRSV);
1920         /* It is assumed that callers of this routine are not passing in any
1921            user derived data.  */
1922         /* Need to do this after save_re_context() as it will set PL_tainted to
1923            1 while saving $1 etc (see the code after getrx: in Perl_magic_get).
1924            Even line to create errsv_save can turn on PL_tainted.  */
1925         SAVEBOOL(PL_tainted);
1926         PL_tainted = 0;
1927         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
1928                          NULL);
1929         if (!SvTRUE(ERRSV))
1930             sv_setsv(ERRSV, errsv_save);
1931         SvREFCNT_dec(errsv_save);
1932         LEAVE;
1933     }
1934     SPAGAIN;
1935     PUSHMARK(SP);
1936     EXTEND(SP,5);
1937     mPUSHp(pkg, pkg_len);
1938     mPUSHp(name, name_len);
1939     PUSHs(listsv);
1940     mPUSHi(minbits);
1941     mPUSHi(none);
1942     PUTBACK;
1943     errsv_save = newSVsv(ERRSV);
1944     if (call_method("SWASHNEW", G_SCALAR))
1945         retval = newSVsv(*PL_stack_sp--);
1946     else
1947         retval = &PL_sv_undef;
1948     if (!SvTRUE(ERRSV))
1949         sv_setsv(ERRSV, errsv_save);
1950     SvREFCNT_dec(errsv_save);
1951     LEAVE;
1952     POPSTACK;
1953     if (IN_PERL_COMPILETIME) {
1954         CopHINTS_set(PL_curcop, PL_hints);
1955     }
1956     if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
1957         if (SvPOK(retval))
1958             Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
1959                        SVfARG(retval));
1960         Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
1961     }
1962     return retval;
1963 }
1964
1965
1966 /* This API is wrong for special case conversions since we may need to
1967  * return several Unicode characters for a single Unicode character
1968  * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
1969  * the lower-level routine, and it is similarly broken for returning
1970  * multiple values.  --jhi */
1971 /* Now SWASHGET is recasted into S_swash_get in this file. */
1972
1973 /* Note:
1974  * Returns the value of property/mapping C<swash> for the first character
1975  * of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
1976  * assumed to be in utf8. If C<do_utf8> is false, the string C<ptr> is
1977  * assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
1978  */
1979 UV
1980 Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
1981 {
1982     dVAR;
1983     HV *const hv = MUTABLE_HV(SvRV(swash));
1984     U32 klen;
1985     U32 off;
1986     STRLEN slen;
1987     STRLEN needents;
1988     const U8 *tmps = NULL;
1989     U32 bit;
1990     SV *swatch;
1991     U8 tmputf8[2];
1992     const UV c = NATIVE_TO_ASCII(*ptr);
1993
1994     PERL_ARGS_ASSERT_SWASH_FETCH;
1995
1996     if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
1997         tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
1998         tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
1999         ptr = tmputf8;
2000     }
2001     /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
2002      * then the "swatch" is a vec() for all the chars which start
2003      * with 0xAA..0xYY
2004      * So the key in the hash (klen) is length of encoded char -1
2005      */
2006     klen = UTF8SKIP(ptr) - 1;
2007     off  = ptr[klen];
2008
2009     if (klen == 0) {
2010       /* If char is invariant then swatch is for all the invariant chars
2011        * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
2012        */
2013         needents = UTF_CONTINUATION_MARK;
2014         off      = NATIVE_TO_UTF(ptr[klen]);
2015     }
2016     else {
2017       /* If char is encoded then swatch is for the prefix */
2018         needents = (1 << UTF_ACCUMULATION_SHIFT);
2019         off      = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
2020     }
2021
2022     /*
2023      * This single-entry cache saves about 1/3 of the utf8 overhead in test
2024      * suite.  (That is, only 7-8% overall over just a hash cache.  Still,
2025      * it's nothing to sniff at.)  Pity we usually come through at least
2026      * two function calls to get here...
2027      *
2028      * NB: this code assumes that swatches are never modified, once generated!
2029      */
2030
2031     if (hv   == PL_last_swash_hv &&
2032         klen == PL_last_swash_klen &&
2033         (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
2034     {
2035         tmps = PL_last_swash_tmps;
2036         slen = PL_last_swash_slen;
2037     }
2038     else {
2039         /* Try our second-level swatch cache, kept in a hash. */
2040         SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE);
2041
2042         /* If not cached, generate it via swash_get */
2043         if (!svp || !SvPOK(*svp)
2044                  || !(tmps = (const U8*)SvPV_const(*svp, slen))) {
2045             /* We use utf8n_to_uvuni() as we want an index into
2046                Unicode tables, not a native character number.
2047              */
2048             const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
2049                                            ckWARN(WARN_UTF8) ?
2050                                            0 : UTF8_ALLOW_ANY);
2051             swatch = swash_get(swash,
2052                     /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
2053                                 (klen) ? (code_point & ~(needents - 1)) : 0,
2054                                 needents);
2055
2056             if (IN_PERL_COMPILETIME)
2057                 CopHINTS_set(PL_curcop, PL_hints);
2058
2059             svp = hv_store(hv, (const char *)ptr, klen, swatch, 0);
2060
2061             if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
2062                      || (slen << 3) < needents)
2063                 Perl_croak(aTHX_ "panic: swash_fetch got improper swatch");
2064         }
2065
2066         PL_last_swash_hv = hv;
2067         assert(klen <= sizeof(PL_last_swash_key));
2068         PL_last_swash_klen = (U8)klen;
2069         /* FIXME change interpvar.h?  */
2070         PL_last_swash_tmps = (U8 *) tmps;
2071         PL_last_swash_slen = slen;
2072         if (klen)
2073             Copy(ptr, PL_last_swash_key, klen, U8);
2074     }
2075
2076     switch ((int)((slen << 3) / needents)) {
2077     case 1:
2078         bit = 1 << (off & 7);
2079         off >>= 3;
2080         return (tmps[off] & bit) != 0;
2081     case 8:
2082         return tmps[off];
2083     case 16:
2084         off <<= 1;
2085         return (tmps[off] << 8) + tmps[off + 1] ;
2086     case 32:
2087         off <<= 2;
2088         return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
2089     }
2090     Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width");
2091     NORETURN_FUNCTION_END;
2092 }
2093
2094 /* Read a single line of the main body of the swash input text.  These are of
2095  * the form:
2096  * 0053 0056    0073
2097  * where each number is hex.  The first two numbers form the minimum and
2098  * maximum of a range, and the third is the value associated with the range.
2099  * Not all swashes should have a third number
2100  *
2101  * On input: l    points to the beginning of the line to be examined; it points
2102  *                to somewhere in the string of the whole input text, and is
2103  *                terminated by a \n or the null string terminator.
2104  *           lend   points to the null terminator of that string
2105  *           wants_value    is non-zero if the swash expects a third number
2106  *           typestr is the name of the swash's mapping, like 'ToLower'
2107  * On output: *min, *max, and *val are set to the values read from the line.
2108  *            returns a pointer just beyond the line examined.  If there was no
2109  *            valid min number on the line, returns lend+1
2110  */
2111
2112 STATIC U8*
2113 S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val,
2114                              const bool wants_value, const U8* const typestr)
2115 {
2116     const int  typeto  = typestr[0] == 'T' && typestr[1] == 'o';
2117     STRLEN numlen;          /* Length of the number */
2118     I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
2119
2120     /* nl points to the next \n in the scan */
2121     U8* const nl = (U8*)memchr(l, '\n', lend - l);
2122
2123     /* Get the first number on the line: the range minimum */
2124     numlen = lend - l;
2125     *min = grok_hex((char *)l, &numlen, &flags, NULL);
2126     if (numlen)     /* If found a hex number, position past it */
2127         l += numlen;
2128     else if (nl) {          /* Else, go handle next line, if any */
2129         return nl + 1;  /* 1 is length of "\n" */
2130     }
2131     else {              /* Else, no next line */
2132         return lend + 1;        /* to LIST's end at which \n is not found */
2133     }
2134
2135     /* The max range value follows, separated by a BLANK */
2136     if (isBLANK(*l)) {
2137         ++l;
2138         flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
2139         numlen = lend - l;
2140         *max = grok_hex((char *)l, &numlen, &flags, NULL);
2141         if (numlen)
2142             l += numlen;
2143         else    /* If no value here, it is a single element range */
2144             *max = *min;
2145
2146         /* Non-binary tables have a third entry: what the first element of the
2147          * range maps to */
2148         if (wants_value) {
2149             if (isBLANK(*l)) {
2150                 ++l;
2151                 flags = PERL_SCAN_SILENT_ILLDIGIT |
2152                         PERL_SCAN_DISALLOW_PREFIX;
2153                 numlen = lend - l;
2154                 *val = grok_hex((char *)l, &numlen, &flags, NULL);
2155                 if (numlen)
2156                     l += numlen;
2157                 else
2158                     *val = 0;
2159             }
2160             else {
2161                 *val = 0;
2162                 if (typeto) {
2163                     Perl_croak(aTHX_ "%s: illegal mapping '%s'",
2164                                      typestr, l);
2165                 }
2166             }
2167         }
2168         else
2169             *val = 0; /* bits == 1, then any val should be ignored */
2170     }
2171     else { /* Nothing following range min, should be single element with no
2172               mapping expected */
2173         *max = *min;
2174         if (wants_value) {
2175             *val = 0;
2176             if (typeto) {
2177                 Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
2178             }
2179         }
2180         else
2181             *val = 0; /* bits == 1, then val should be ignored */
2182     }
2183
2184     /* Position to next line if any, or EOF */
2185     if (nl)
2186         l = nl + 1;
2187     else
2188         l = lend;
2189
2190     return l;
2191 }
2192
2193 /* Note:
2194  * Returns a swatch (a bit vector string) for a code point sequence
2195  * that starts from the value C<start> and comprises the number C<span>.
2196  * A C<swash> must be an object created by SWASHNEW (see lib/utf8_heavy.pl).
2197  * Should be used via swash_fetch, which will cache the swatch in C<swash>.
2198  */
2199 STATIC SV*
2200 S_swash_get(pTHX_ SV* swash, UV start, UV span)
2201 {
2202     SV *swatch;
2203     U8 *l, *lend, *x, *xend, *s;
2204     STRLEN lcur, xcur, scur;
2205     HV *const hv = MUTABLE_HV(SvRV(swash));
2206
2207     /* The string containing the main body of the table */
2208     SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
2209
2210     SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
2211     SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
2212     SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
2213     SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
2214     const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
2215     const STRLEN bits  = SvUV(*bitssvp);
2216     const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
2217     const UV     none  = SvUV(*nonesvp);
2218     const UV     end   = start + span;
2219
2220     PERL_ARGS_ASSERT_SWASH_GET;
2221
2222     if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
2223         Perl_croak(aTHX_ "panic: swash_get doesn't expect bits %"UVuf,
2224                                                  (UV)bits);
2225     }
2226
2227     /* create and initialize $swatch */
2228     scur   = octets ? (span * octets) : (span + 7) / 8;
2229     swatch = newSV(scur);
2230     SvPOK_on(swatch);
2231     s = (U8*)SvPVX(swatch);
2232     if (octets && none) {
2233         const U8* const e = s + scur;
2234         while (s < e) {
2235             if (bits == 8)
2236                 *s++ = (U8)(none & 0xff);
2237             else if (bits == 16) {
2238                 *s++ = (U8)((none >>  8) & 0xff);
2239                 *s++ = (U8)( none        & 0xff);
2240             }
2241             else if (bits == 32) {
2242                 *s++ = (U8)((none >> 24) & 0xff);
2243                 *s++ = (U8)((none >> 16) & 0xff);
2244                 *s++ = (U8)((none >>  8) & 0xff);
2245                 *s++ = (U8)( none        & 0xff);
2246             }
2247         }
2248         *s = '\0';
2249     }
2250     else {
2251         (void)memzero((U8*)s, scur + 1);
2252     }
2253     SvCUR_set(swatch, scur);
2254     s = (U8*)SvPVX(swatch);
2255
2256     /* read $swash->{LIST} */
2257     l = (U8*)SvPV(*listsvp, lcur);
2258     lend = l + lcur;
2259     while (l < lend) {
2260         UV min, max, val;
2261         l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
2262                                          cBOOL(octets), typestr);
2263         if (l > lend) {
2264             break;
2265         }
2266
2267         /* If looking for something beyond this range, go try the next one */
2268         if (max < start)
2269             continue;
2270
2271         if (octets) {
2272             UV key;
2273             if (min < start) {
2274                 if (!none || val < none) {
2275                     val += start - min;
2276                 }
2277                 min = start;
2278             }
2279             for (key = min; key <= max; key++) {
2280                 STRLEN offset;
2281                 if (key >= end)
2282                     goto go_out_list;
2283                 /* offset must be non-negative (start <= min <= key < end) */
2284                 offset = octets * (key - start);
2285                 if (bits == 8)
2286                     s[offset] = (U8)(val & 0xff);
2287                 else if (bits == 16) {
2288                     s[offset    ] = (U8)((val >>  8) & 0xff);
2289                     s[offset + 1] = (U8)( val        & 0xff);
2290                 }
2291                 else if (bits == 32) {
2292                     s[offset    ] = (U8)((val >> 24) & 0xff);
2293                     s[offset + 1] = (U8)((val >> 16) & 0xff);
2294                     s[offset + 2] = (U8)((val >>  8) & 0xff);
2295                     s[offset + 3] = (U8)( val        & 0xff);
2296                 }
2297
2298                 if (!none || val < none)
2299                     ++val;
2300             }
2301         }
2302         else { /* bits == 1, then val should be ignored */
2303             UV key;
2304             if (min < start)
2305                 min = start;
2306             for (key = min; key <= max; key++) {
2307                 const STRLEN offset = (STRLEN)(key - start);
2308                 if (key >= end)
2309                     goto go_out_list;
2310                 s[offset >> 3] |= 1 << (offset & 7);
2311             }
2312         }
2313     } /* while */
2314   go_out_list:
2315
2316     /* read $swash->{EXTRAS} */
2317     x = (U8*)SvPV(*extssvp, xcur);
2318     xend = x + xcur;
2319     while (x < xend) {
2320         STRLEN namelen;
2321         U8 *namestr;
2322         SV** othersvp;
2323         HV* otherhv;
2324         STRLEN otherbits;
2325         SV **otherbitssvp, *other;
2326         U8 *s, *o, *nl;
2327         STRLEN slen, olen;
2328
2329         const U8 opc = *x++;
2330         if (opc == '\n')
2331             continue;
2332
2333         nl = (U8*)memchr(x, '\n', xend - x);
2334
2335         if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
2336             if (nl) {
2337                 x = nl + 1; /* 1 is length of "\n" */
2338                 continue;
2339             }
2340             else {
2341                 x = xend; /* to EXTRAS' end at which \n is not found */
2342                 break;
2343             }
2344         }
2345
2346         namestr = x;
2347         if (nl) {
2348             namelen = nl - namestr;
2349             x = nl + 1;
2350         }
2351         else {
2352             namelen = xend - namestr;
2353             x = xend;
2354         }
2355
2356         othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
2357         otherhv = MUTABLE_HV(SvRV(*othersvp));
2358         otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
2359         otherbits = (STRLEN)SvUV(*otherbitssvp);
2360         if (bits < otherbits)
2361             Perl_croak(aTHX_ "panic: swash_get found swatch size mismatch");
2362
2363         /* The "other" swatch must be destroyed after. */
2364         other = swash_get(*othersvp, start, span);
2365         o = (U8*)SvPV(other, olen);
2366
2367         if (!olen)
2368             Perl_croak(aTHX_ "panic: swash_get got improper swatch");
2369
2370         s = (U8*)SvPV(swatch, slen);
2371         if (bits == 1 && otherbits == 1) {
2372             if (slen != olen)
2373                 Perl_croak(aTHX_ "panic: swash_get found swatch length mismatch");
2374
2375             switch (opc) {
2376             case '+':
2377                 while (slen--)
2378                     *s++ |= *o++;
2379                 break;
2380             case '!':
2381                 while (slen--)
2382                     *s++ |= ~*o++;
2383                 break;
2384             case '-':
2385                 while (slen--)
2386                     *s++ &= ~*o++;
2387                 break;
2388             case '&':
2389                 while (slen--)
2390                     *s++ &= *o++;
2391                 break;
2392             default:
2393                 break;
2394             }
2395         }
2396         else {
2397             STRLEN otheroctets = otherbits >> 3;
2398             STRLEN offset = 0;
2399             U8* const send = s + slen;
2400
2401             while (s < send) {
2402                 UV otherval = 0;
2403
2404                 if (otherbits == 1) {
2405                     otherval = (o[offset >> 3] >> (offset & 7)) & 1;
2406                     ++offset;
2407                 }
2408                 else {
2409                     STRLEN vlen = otheroctets;
2410                     otherval = *o++;
2411                     while (--vlen) {
2412                         otherval <<= 8;
2413                         otherval |= *o++;
2414                     }
2415                 }
2416
2417                 if (opc == '+' && otherval)
2418                     NOOP;   /* replace with otherval */
2419                 else if (opc == '!' && !otherval)
2420                     otherval = 1;
2421                 else if (opc == '-' && otherval)
2422                     otherval = 0;
2423                 else if (opc == '&' && !otherval)
2424                     otherval = 0;
2425                 else {
2426                     s += octets; /* no replacement */
2427                     continue;
2428                 }
2429
2430                 if (bits == 8)
2431                     *s++ = (U8)( otherval & 0xff);
2432                 else if (bits == 16) {
2433                     *s++ = (U8)((otherval >>  8) & 0xff);
2434                     *s++ = (U8)( otherval        & 0xff);
2435                 }
2436                 else if (bits == 32) {
2437                     *s++ = (U8)((otherval >> 24) & 0xff);
2438                     *s++ = (U8)((otherval >> 16) & 0xff);
2439                     *s++ = (U8)((otherval >>  8) & 0xff);
2440                     *s++ = (U8)( otherval        & 0xff);
2441                 }
2442             }
2443         }
2444         sv_free(other); /* through with it! */
2445     } /* while */
2446     return swatch;
2447 }
2448
2449 HV*
2450 Perl__swash_inversion_hash(pTHX_ SV* swash)
2451 {
2452
2453    /* Subject to change or removal.  For use only in one place in regexec.c
2454     *
2455     * Returns a hash which is the inversion and closure of a swash mapping.
2456     * For example, consider the input lines:
2457     * 004B              006B
2458     * 004C              006C
2459     * 212A              006B
2460     *
2461     * The returned hash would have two keys, the utf8 for 006B and the utf8 for
2462     * 006C.  The value for each key is an array.  For 006C, the array would
2463     * have a two elements, the utf8 for itself, and for 004C.  For 006B, there
2464     * would be three elements in its array, the utf8 for 006B, 004B and 212A.
2465     *
2466     * Essentially, for any code point, it gives all the code points that map to
2467     * it, or the list of 'froms' for that point.
2468     *
2469     * Currently it only looks at the main body of the swash, and ignores any
2470     * additions or deletions from other swashes */
2471
2472     U8 *l, *lend;
2473     STRLEN lcur;
2474     HV *const hv = MUTABLE_HV(SvRV(swash));
2475
2476     /* The string containing the main body of the table */
2477     SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
2478
2479     SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
2480     SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
2481     SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
2482     /*SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);*/
2483     const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
2484     const STRLEN bits  = SvUV(*bitssvp);
2485     const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
2486     const UV     none  = SvUV(*nonesvp);
2487
2488     HV* ret = newHV();
2489
2490     PERL_ARGS_ASSERT__SWASH_INVERSION_HASH;
2491
2492     /* Must have at least 8 bits to get the mappings */
2493     if (bits != 8 && bits != 16 && bits != 32) {
2494         Perl_croak(aTHX_ "panic: swash_inversion_hash doesn't expect bits %"UVuf,
2495                                                  (UV)bits);
2496     }
2497
2498     /* read $swash->{LIST} */
2499     l = (U8*)SvPV(*listsvp, lcur);
2500     lend = l + lcur;
2501
2502     /* Go through each input line */
2503     while (l < lend) {
2504         UV min, max, val;
2505         UV inverse;
2506         l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
2507                                          cBOOL(octets), typestr);
2508         if (l > lend) {
2509             break;
2510         }
2511
2512         /* Each element in the range is to be inverted */
2513         for (inverse = min; inverse <= max; inverse++) {
2514             AV* list;
2515             SV* element;
2516             SV** listp;
2517             IV i;
2518             bool found_key = FALSE;
2519
2520             /* The key is the inverse mapping */
2521             char key[UTF8_MAXBYTES+1];
2522             char* key_end = (char *) uvuni_to_utf8((U8*) key, val);
2523             STRLEN key_len = key_end - key;
2524
2525             /* And the value is what the forward mapping is from. */
2526             char utf8_inverse[UTF8_MAXBYTES+1];
2527             char *utf8_inverse_end = (char *) uvuni_to_utf8((U8*) utf8_inverse, inverse);
2528
2529             /* Get the list for the map */
2530             if ((listp = hv_fetch(ret, key, key_len, FALSE))) {
2531                 list = (AV*) *listp;
2532             }
2533             else { /* No entry yet for it: create one */
2534                 list = newAV();
2535                 if (! hv_store(ret, key, key_len, (SV*) list, FALSE)) {
2536                     Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
2537                 }
2538             }
2539
2540             for (i = 0; i < av_len(list); i++) {
2541                 SV** entryp = av_fetch(list, i, FALSE);
2542                 SV* entry;
2543                 if (entryp == NULL) {
2544                     Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
2545                 }
2546                 entry = *entryp;
2547                 if (SvCUR(entry) != key_len) {
2548                     continue;
2549                 }
2550                 if (memEQ(key, SvPVX(entry), key_len)) {
2551                     found_key = TRUE;
2552                     break;
2553                 }
2554             }
2555             if (! found_key) {
2556                 element = newSVpvn_flags(key, key_len, SVf_UTF8);
2557                 av_push(list, element);
2558             }
2559
2560
2561             /* Simply add the value to the list */
2562             element = newSVpvn_flags(utf8_inverse, utf8_inverse_end - utf8_inverse, SVf_UTF8);
2563             av_push(list, element);
2564
2565             /* swash_get() increments the value of val for each element in the
2566              * range.  That makes more compact tables possible.  You can
2567              * express the capitalization, for example, of all consecutive
2568              * letters with a single line: 0061\t007A\t0041 This maps 0061 to
2569              * 0041, 0062 to 0042, etc.  I (khw) have never understood 'none',
2570              * and it's not documented, and perhaps not even currently used,
2571              * but I copied the semantics from swash_get(), just in case */
2572             if (!none || val < none) {
2573                 ++val;
2574             }
2575         }
2576     }
2577
2578     return ret;
2579 }
2580
2581 /*
2582 =for apidoc uvchr_to_utf8
2583
2584 Adds the UTF-8 representation of the Native codepoint C<uv> to the end
2585 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
2586 bytes available. The return value is the pointer to the byte after the
2587 end of the new character. In other words,
2588
2589     d = uvchr_to_utf8(d, uv);
2590
2591 is the recommended wide native character-aware way of saying
2592
2593     *(d++) = uv;
2594
2595 =cut
2596 */
2597
2598 /* On ASCII machines this is normally a macro but we want a
2599    real function in case XS code wants it
2600 */
2601 U8 *
2602 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
2603 {
2604     PERL_ARGS_ASSERT_UVCHR_TO_UTF8;
2605
2606     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
2607 }
2608
2609 U8 *
2610 Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
2611 {
2612     PERL_ARGS_ASSERT_UVCHR_TO_UTF8_FLAGS;
2613
2614     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
2615 }
2616
2617 /*
2618 =for apidoc utf8n_to_uvchr
2619 flags
2620
2621 Returns the native character value of the first character in the string
2622 C<s>
2623 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
2624 length, in bytes, of that character.
2625
2626 Allows length and flags to be passed to low level routine.
2627
2628 =cut
2629 */
2630 /* On ASCII machines this is normally a macro but we want
2631    a real function in case XS code wants it
2632 */
2633 UV
2634 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
2635 U32 flags)
2636 {
2637     const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
2638
2639     PERL_ARGS_ASSERT_UTF8N_TO_UVCHR;
2640
2641     return UNI_TO_NATIVE(uv);
2642 }
2643
2644 /*
2645 =for apidoc pv_uni_display
2646
2647 Build to the scalar dsv a displayable version of the string spv,
2648 length len, the displayable version being at most pvlim bytes long
2649 (if longer, the rest is truncated and "..." will be appended).
2650
2651 The flags argument can have UNI_DISPLAY_ISPRINT set to display
2652 isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
2653 to display the \\[nrfta\\] as the backslashed versions (like '\n')
2654 (UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
2655 UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
2656 UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
2657
2658 The pointer to the PV of the dsv is returned.
2659
2660 =cut */
2661 char *
2662 Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
2663 {
2664     int truncated = 0;
2665     const char *s, *e;
2666
2667     PERL_ARGS_ASSERT_PV_UNI_DISPLAY;
2668
2669     sv_setpvs(dsv, "");
2670     SvUTF8_off(dsv);
2671     for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
2672          UV u;
2673           /* This serves double duty as a flag and a character to print after
2674              a \ when flags & UNI_DISPLAY_BACKSLASH is true.
2675           */
2676          char ok = 0;
2677
2678          if (pvlim && SvCUR(dsv) >= pvlim) {
2679               truncated++;
2680               break;
2681          }
2682          u = utf8_to_uvchr((U8*)s, 0);
2683          if (u < 256) {
2684              const unsigned char c = (unsigned char)u & 0xFF;
2685              if (flags & UNI_DISPLAY_BACKSLASH) {
2686                  switch (c) {
2687                  case '\n':
2688                      ok = 'n'; break;
2689                  case '\r':
2690                      ok = 'r'; break;
2691                  case '\t':
2692                      ok = 't'; break;
2693                  case '\f':
2694                      ok = 'f'; break;
2695                  case '\a':
2696                      ok = 'a'; break;
2697                  case '\\':
2698                      ok = '\\'; break;
2699                  default: break;
2700                  }
2701                  if (ok) {
2702                      const char string = ok;
2703                      sv_catpvs(dsv, "\\");
2704                      sv_catpvn(dsv, &string, 1);
2705                  }
2706              }
2707              /* isPRINT() is the locale-blind version. */
2708              if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
2709                  const char string = c;
2710                  sv_catpvn(dsv, &string, 1);
2711                  ok = 1;
2712              }
2713          }
2714          if (!ok)
2715              Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
2716     }
2717     if (truncated)
2718          sv_catpvs(dsv, "...");
2719
2720     return SvPVX(dsv);
2721 }
2722
2723 /*
2724 =for apidoc sv_uni_display
2725
2726 Build to the scalar dsv a displayable version of the scalar sv,
2727 the displayable version being at most pvlim bytes long
2728 (if longer, the rest is truncated and "..." will be appended).
2729
2730 The flags argument is as in pv_uni_display().
2731
2732 The pointer to the PV of the dsv is returned.
2733
2734 =cut
2735 */
2736 char *
2737 Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
2738 {
2739     PERL_ARGS_ASSERT_SV_UNI_DISPLAY;
2740
2741      return Perl_pv_uni_display(aTHX_ dsv, (const U8*)SvPVX_const(ssv),
2742                                 SvCUR(ssv), pvlim, flags);
2743 }
2744
2745 /*
2746 =for apidoc foldEQ_utf8
2747
2748 Returns true if the leading portions of the strings s1 and s2 (either or both
2749 of which may be in UTF-8) are the same case-insensitively; false otherwise.
2750 How far into the strings to compare is determined by other input parameters.
2751
2752 If u1 is true, the string s1 is assumed to be in UTF-8-encoded Unicode;
2753 otherwise it is assumed to be in native 8-bit encoding.  Correspondingly for u2
2754 with respect to s2.
2755
2756 If the byte length l1 is non-zero, it says how far into s1 to check for fold
2757 equality.  In other words, s1+l1 will be used as a goal to reach.  The
2758 scan will not be considered to be a match unless the goal is reached, and
2759 scanning won't continue past that goal.  Correspondingly for l2 with respect to
2760 s2.
2761
2762 If pe1 is non-NULL and the pointer it points to is not NULL, that pointer is
2763 considered an end pointer beyond which scanning of s1 will not continue under
2764 any circumstances.  This means that if both l1 and pe1 are specified, and pe1
2765 is less than s1+l1, the match will never be successful because it can never
2766 get as far as its goal (and in fact is asserted against).  Correspondingly for
2767 pe2 with respect to s2.
2768
2769 At least one of s1 and s2 must have a goal (at least one of l1 and l2 must be
2770 non-zero), and if both do, both have to be
2771 reached for a successful match.   Also, if the fold of a character is multiple
2772 characters, all of them must be matched (see tr21 reference below for
2773 'folding').
2774
2775 Upon a successful match, if pe1 is non-NULL,
2776 it will be set to point to the beginning of the I<next> character of s1 beyond
2777 what was matched.  Correspondingly for pe2 and s2.
2778
2779 For case-insensitiveness, the "casefolding" of Unicode is used
2780 instead of upper/lowercasing both the characters, see
2781 http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
2782
2783 =cut */
2784 I32
2785 Perl_foldEQ_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
2786 {
2787     dVAR;
2788     register const U8 *p1  = (const U8*)s1; /* Point to current char */
2789     register const U8 *p2  = (const U8*)s2;
2790     register const U8 *g1 = NULL;       /* goal for s1 */
2791     register const U8 *g2 = NULL;
2792     register const U8 *e1 = NULL;       /* Don't scan s1 past this */
2793     register U8 *f1 = NULL;             /* Point to current folded */
2794     register const U8 *e2 = NULL;
2795     register U8 *f2 = NULL;
2796     STRLEN n1 = 0, n2 = 0;              /* Number of bytes in current char */
2797     U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
2798     U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
2799     U8 natbuf[2];               /* Holds native 8-bit char converted to utf8;
2800                                    these always fit in 2 bytes */
2801
2802     PERL_ARGS_ASSERT_FOLDEQ_UTF8;
2803
2804     if (pe1) {
2805         e1 = *(U8**)pe1;
2806     }
2807
2808     if (l1) {
2809         g1 = (const U8*)s1 + l1;
2810     }
2811
2812     if (pe2) {
2813         e2 = *(U8**)pe2;
2814     }
2815
2816     if (l2) {
2817         g2 = (const U8*)s2 + l2;
2818     }
2819
2820     /* Must have at least one goal */
2821     assert(g1 || g2);
2822
2823     if (g1) {
2824
2825         /* Will never match if goal is out-of-bounds */
2826         assert(! e1  || e1 >= g1);
2827
2828         /* Here, there isn't an end pointer, or it is beyond the goal.  We
2829         * only go as far as the goal */
2830         e1 = g1;
2831     }
2832     else {
2833         assert(e1);    /* Must have an end for looking at s1 */
2834     }
2835
2836     /* Same for goal for s2 */
2837     if (g2) {
2838         assert(! e2  || e2 >= g2);
2839         e2 = g2;
2840     }
2841     else {
2842         assert(e2);
2843     }
2844
2845     /* Look through both strings, a character at a time */
2846     while (p1 < e1 && p2 < e2) {
2847
2848         /* If at the beginning of a new character in s1, get its fold to use
2849          * and the length of the fold */
2850         if (n1 == 0) {
2851             if (u1) {
2852                 to_utf8_fold(p1, foldbuf1, &n1);
2853             }
2854             else {  /* Not utf8, convert to it first and then get fold */
2855                 uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p1)));
2856                 to_utf8_fold(natbuf, foldbuf1, &n1);
2857             }
2858             f1 = foldbuf1;
2859         }
2860
2861         if (n2 == 0) {    /* Same for s2 */
2862             if (u2) {
2863                 to_utf8_fold(p2, foldbuf2, &n2);
2864             }
2865             else {
2866                 uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p2)));
2867                 to_utf8_fold(natbuf, foldbuf2, &n2);
2868             }
2869             f2 = foldbuf2;
2870         }
2871
2872         /* While there is more to look for in both folds, see if they
2873         * continue to match */
2874         while (n1 && n2) {
2875             U8 fold_length = UTF8SKIP(f1);
2876             if (fold_length != UTF8SKIP(f2)
2877                 || (fold_length == 1 && *f1 != *f2) /* Short circuit memNE
2878                                                        function call for single
2879                                                        character */
2880                 || memNE((char*)f1, (char*)f2, fold_length))
2881             {
2882                 return 0; /* mismatch */
2883             }
2884
2885             /* Here, they matched, advance past them */
2886             n1 -= fold_length;
2887             f1 += fold_length;
2888             n2 -= fold_length;
2889             f2 += fold_length;
2890         }
2891
2892         /* When reach the end of any fold, advance the input past it */
2893         if (n1 == 0) {
2894             p1 += u1 ? UTF8SKIP(p1) : 1;
2895         }
2896         if (n2 == 0) {
2897             p2 += u2 ? UTF8SKIP(p2) : 1;
2898         }
2899     } /* End of loop through both strings */
2900
2901     /* A match is defined by each scan that specified an explicit length
2902     * reaching its final goal, and the other not having matched a partial
2903     * character (which can happen when the fold of a character is more than one
2904     * character). */
2905     if (! ((g1 == 0 || p1 == g1) && (g2 == 0 || p2 == g2)) || n1 || n2) {
2906         return 0;
2907     }
2908
2909     /* Successful match.  Set output pointers */
2910     if (pe1) {
2911         *pe1 = (char*)p1;
2912     }
2913     if (pe2) {
2914         *pe2 = (char*)p2;
2915     }
2916     return 1;
2917 }
2918
2919 /*
2920  * Local variables:
2921  * c-indentation-style: bsd
2922  * c-basic-offset: 4
2923  * indent-tabs-mode: t
2924  * End:
2925  *
2926  * ex: set ts=8 sts=4 sw=4 noet:
2927  */