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 = UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(c, c1));
 840                     } else {
 841                         Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
 842                                          "Malformed UTF-8 character "
 843                                          "(unexpected non-continuation byte 0x%02x"
 844                                          ", immediately after start byte 0x%02x)"
 845                                          /* Dear diag.t, it's in the pod.  */
 846                                          "%s%s", c1, c,
 847                                          PL_op ? " in " : "",
 848                                          PL_op ? OP_DESC(PL_op) : "");
 849                         return -2;
 850                     }
 851                 } else {
 852                     if (PL_op)
 853                         Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
 854                                          "%s in %s", unees, OP_DESC(PL_op));
 855                     else
 856                         Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), unees);
 857                     return -2; /* Really want to return undef :-)  */
 858                 }
 859             } else {
 860                 return -2;
 861             }
 862         }
 863         if (*b != c) {
 864             return *b < c ? -2 : +2;
 865         }
 866         ++b;
 867     }
 868
 869     if (b == bend && u == uend)
 870         return 0;
 871
 872     return b < bend ? +1 : -1;
 873 }
 874
 875 /*
 876 =for apidoc utf8_to_bytes
 877
 878 Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
 879 Unlike C<bytes_to_utf8>, this over-writes the original string, and
 880 updates len to contain the new length.
 881 Returns zero on failure, setting C<len> to -1.
 882
 883 If you need a copy of the string, see C<bytes_from_utf8>.
 884
 885 =cut
 886 */
 887
 888 U8 *
 889 Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
 890 {
 891     U8 * const save = s;
 892     U8 * const send = s + *len;
 893     U8 *d;
 894
 895     PERL_ARGS_ASSERT_UTF8_TO_BYTES;
 896
 897     /* ensure valid UTF-8 and chars < 256 before updating string */
 898     while (s < send) {
 899         U8 c = *s++;
 900
 901         if (!UTF8_IS_INVARIANT(c) &&
 902             (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
 903              || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
 904             *len = ((STRLEN) -1);
 905             return 0;
 906         }
 907     }
 908
 909     d = s = save;
 910     while (s < send) {
 911         STRLEN ulen;
 912         *d++ = (U8)utf8_to_uvchr(s, &ulen);
 913         s += ulen;
 914     }
 915     *d = '\0';
 916     *len = d - save;
 917     return save;
 918 }
 919
 920 /*
 921 =for apidoc bytes_from_utf8
 922
 923 Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
 924 Unlike C<utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
 925 the newly-created string, and updates C<len> to contain the new
 926 length.  Returns the original string if no conversion occurs, C<len>
 927 is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
 928 0 if C<s> is converted or consisted entirely of characters that are invariant
 929 in utf8 (i.e., US-ASCII on non-EBCDIC machines).
 930
 931 =cut
 932 */
 933
 934 U8 *
 935 Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8)
 936 {
 937     U8 *d;
 938     const U8 *start = s;
 939     const U8 *send;
 940     I32 count = 0;
 941
 942     PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
 943
 944     PERL_UNUSED_CONTEXT;
 945     if (!*is_utf8)
 946         return (U8 *)start;
 947
 948     /* ensure valid UTF-8 and chars < 256 before converting string */
 949     for (send = s + *len; s < send;) {
 950         U8 c = *s++;
 951         if (!UTF8_IS_INVARIANT(c)) {
 952             if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
 953                 (c = *s++) && UTF8_IS_CONTINUATION(c))
 954                 count++;
 955             else
 956                 return (U8 *)start;
 957         }
 958     }
 959
 960     *is_utf8 = FALSE;
 961
 962     Newx(d, (*len) - count + 1, U8);
 963     s = start; start = d;
 964     while (s < send) {
 965         U8 c = *s++;
 966         if (!UTF8_IS_INVARIANT(c)) {
 967             /* Then it is two-byte encoded */
 968             c = UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(c, *s++));
 969         }
 970         *d++ = c;
 971     }
 972     *d = '\0';
 973     *len = d - start;
 974     return (U8 *)start;
 975 }
 976
 977 /*
 978 =for apidoc bytes_to_utf8
 979
 980 Converts a string C<s> of length C<len> from the native encoding into UTF-8.
 981 Returns a pointer to the newly-created string, and sets C<len> to
 982 reflect the new length.
 983
 984 A NUL character will be written after the end of the string.
 985
 986 If you want to convert to UTF-8 from encodings other than
 987 the native (Latin1 or EBCDIC),
 988 see sv_recode_to_utf8().
 989
 990 =cut
 991 */
 992
 993 U8*
 994 Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len)
 995 {
 996     const U8 * const send = s + (*len);
 997     U8 *d;
 998     U8 *dst;
 999
1000     PERL_ARGS_ASSERT_BYTES_TO_UTF8;
1001     PERL_UNUSED_CONTEXT;
1002
1003     Newx(d, (*len) * 2 + 1, U8);
1004     dst = d;
1005
1006     while (s < send) {
1007         const UV uv = NATIVE_TO_ASCII(*s++);
1008         if (UNI_IS_INVARIANT(uv))
1009             *d++ = (U8)UTF_TO_NATIVE(uv);
1010         else {
1011             *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
1012             *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
1013         }
1014     }
1015     *d = '\0';
1016     *len = d-dst;
1017     return dst;
1018 }
1019
1020 /*
1021  * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
1022  *
1023  * Destination must be pre-extended to 3/2 source.  Do not use in-place.
1024  * We optimize for native, for obvious reasons. */
1025
1026 U8*
1027 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
1028 {
1029     U8* pend;
1030     U8* dstart = d;
1031
1032     PERL_ARGS_ASSERT_UTF16_TO_UTF8;
1033
1034     if (bytelen & 1)
1035         Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %"UVuf, (UV)bytelen);
1036
1037     pend = p + bytelen;
1038
1039     while (p < pend) {
1040         UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
1041         p += 2;
1042         if (uv < 0x80) {
1043 #ifdef EBCDIC
1044             *d++ = UNI_TO_NATIVE(uv);
1045 #else
1046             *d++ = (U8)uv;
1047 #endif
1048             continue;
1049         }
1050         if (uv < 0x800) {
1051             *d++ = (U8)(( uv >>  6)         | 0xc0);
1052             *d++ = (U8)(( uv        & 0x3f) | 0x80);
1053             continue;
1054         }
1055         if (uv >= 0xd800 && uv <= 0xdbff) {     /* surrogates */
1056             if (p >= pend) {
1057                 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
1058             } else {
1059                 UV low = (p[0] << 8) + p[1];
1060                 p += 2;
1061                 if (low < 0xdc00 || low > 0xdfff)
1062                     Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
1063                 uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
1064             }
1065         } else if (uv >= 0xdc00 && uv <= 0xdfff) {
1066             Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
1067         }
1068         if (uv < 0x10000) {
1069             *d++ = (U8)(( uv >> 12)         | 0xe0);
1070             *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
1071             *d++ = (U8)(( uv        & 0x3f) | 0x80);
1072             continue;
1073         }
1074         else {
1075             *d++ = (U8)(( uv >> 18)         | 0xf0);
1076             *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
1077             *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
1078             *d++ = (U8)(( uv        & 0x3f) | 0x80);
1079             continue;
1080         }
1081     }
1082     *newlen = d - dstart;
1083     return d;
1084 }
1085
1086 /* Note: this one is slightly destructive of the source. */
1087
1088 U8*
1089 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
1090 {
1091     U8* s = (U8*)p;
1092     U8* const send = s + bytelen;
1093
1094     PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED;
1095
1096     if (bytelen & 1)
1097         Perl_croak(aTHX_ "panic: utf16_to_utf8_reversed: odd bytelen %"UVuf,
1098                    (UV)bytelen);
1099
1100     while (s < send) {
1101         const U8 tmp = s[0];
1102         s[0] = s[1];
1103         s[1] = tmp;
1104         s += 2;
1105     }
1106     return utf16_to_utf8(p, d, bytelen, newlen);
1107 }
1108
1109 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
1110
1111 bool
1112 Perl_is_uni_alnum(pTHX_ UV c)
1113 {
1114     U8 tmpbuf[UTF8_MAXBYTES+1];
1115     uvchr_to_utf8(tmpbuf, c);
1116     return is_utf8_alnum(tmpbuf);
1117 }
1118
1119 bool
1120 Perl_is_uni_idfirst(pTHX_ UV c)
1121 {
1122     U8 tmpbuf[UTF8_MAXBYTES+1];
1123     uvchr_to_utf8(tmpbuf, c);
1124     return is_utf8_idfirst(tmpbuf);
1125 }
1126
1127 bool
1128 Perl_is_uni_alpha(pTHX_ UV c)
1129 {
1130     U8 tmpbuf[UTF8_MAXBYTES+1];
1131     uvchr_to_utf8(tmpbuf, c);
1132     return is_utf8_alpha(tmpbuf);
1133 }
1134
1135 bool
1136 Perl_is_uni_ascii(pTHX_ UV c)
1137 {
1138     U8 tmpbuf[UTF8_MAXBYTES+1];
1139     uvchr_to_utf8(tmpbuf, c);
1140     return is_utf8_ascii(tmpbuf);
1141 }
1142
1143 bool
1144 Perl_is_uni_space(pTHX_ UV c)
1145 {
1146     U8 tmpbuf[UTF8_MAXBYTES+1];
1147     uvchr_to_utf8(tmpbuf, c);
1148     return is_utf8_space(tmpbuf);
1149 }
1150
1151 bool
1152 Perl_is_uni_digit(pTHX_ UV c)
1153 {
1154     U8 tmpbuf[UTF8_MAXBYTES+1];
1155     uvchr_to_utf8(tmpbuf, c);
1156     return is_utf8_digit(tmpbuf);
1157 }
1158
1159 bool
1160 Perl_is_uni_upper(pTHX_ UV c)
1161 {
1162     U8 tmpbuf[UTF8_MAXBYTES+1];
1163     uvchr_to_utf8(tmpbuf, c);
1164     return is_utf8_upper(tmpbuf);
1165 }
1166
1167 bool
1168 Perl_is_uni_lower(pTHX_ UV c)
1169 {
1170     U8 tmpbuf[UTF8_MAXBYTES+1];
1171     uvchr_to_utf8(tmpbuf, c);
1172     return is_utf8_lower(tmpbuf);
1173 }
1174
1175 bool
1176 Perl_is_uni_cntrl(pTHX_ UV c)
1177 {
1178     U8 tmpbuf[UTF8_MAXBYTES+1];
1179     uvchr_to_utf8(tmpbuf, c);
1180     return is_utf8_cntrl(tmpbuf);
1181 }
1182
1183 bool
1184 Perl_is_uni_graph(pTHX_ UV c)
1185 {
1186     U8 tmpbuf[UTF8_MAXBYTES+1];
1187     uvchr_to_utf8(tmpbuf, c);
1188     return is_utf8_graph(tmpbuf);
1189 }
1190
1191 bool
1192 Perl_is_uni_print(pTHX_ UV c)
1193 {
1194     U8 tmpbuf[UTF8_MAXBYTES+1];
1195     uvchr_to_utf8(tmpbuf, c);
1196     return is_utf8_print(tmpbuf);
1197 }
1198
1199 bool
1200 Perl_is_uni_punct(pTHX_ UV c)
1201 {
1202     U8 tmpbuf[UTF8_MAXBYTES+1];
1203     uvchr_to_utf8(tmpbuf, c);
1204     return is_utf8_punct(tmpbuf);
1205 }
1206
1207 bool
1208 Perl_is_uni_xdigit(pTHX_ UV c)
1209 {
1210     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1211     uvchr_to_utf8(tmpbuf, c);
1212     return is_utf8_xdigit(tmpbuf);
1213 }
1214
1215 UV
1216 Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
1217 {
1218     PERL_ARGS_ASSERT_TO_UNI_UPPER;
1219
1220     uvchr_to_utf8(p, c);
1221     return to_utf8_upper(p, p, lenp);
1222 }
1223
1224 UV
1225 Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
1226 {
1227     PERL_ARGS_ASSERT_TO_UNI_TITLE;
1228
1229     uvchr_to_utf8(p, c);
1230     return to_utf8_title(p, p, lenp);
1231 }
1232
1233 UV
1234 Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
1235 {
1236     PERL_ARGS_ASSERT_TO_UNI_LOWER;
1237
1238     uvchr_to_utf8(p, c);
1239     return to_utf8_lower(p, p, lenp);
1240 }
1241
1242 UV
1243 Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
1244 {
1245     PERL_ARGS_ASSERT_TO_UNI_FOLD;
1246
1247     uvchr_to_utf8(p, c);
1248     return to_utf8_fold(p, p, lenp);
1249 }
1250
1251 /* for now these all assume no locale info available for Unicode > 255 */
1252
1253 bool
1254 Perl_is_uni_alnum_lc(pTHX_ UV c)
1255 {
1256     return is_uni_alnum(c);     /* XXX no locale support yet */
1257 }
1258
1259 bool
1260 Perl_is_uni_idfirst_lc(pTHX_ UV c)
1261 {
1262     return is_uni_idfirst(c);   /* XXX no locale support yet */
1263 }
1264
1265 bool
1266 Perl_is_uni_alpha_lc(pTHX_ UV c)
1267 {
1268     return is_uni_alpha(c);     /* XXX no locale support yet */
1269 }
1270
1271 bool
1272 Perl_is_uni_ascii_lc(pTHX_ UV c)
1273 {
1274     return is_uni_ascii(c);     /* XXX no locale support yet */
1275 }
1276
1277 bool
1278 Perl_is_uni_space_lc(pTHX_ UV c)
1279 {
1280     return is_uni_space(c);     /* XXX no locale support yet */
1281 }
1282
1283 bool
1284 Perl_is_uni_digit_lc(pTHX_ UV c)
1285 {
1286     return is_uni_digit(c);     /* XXX no locale support yet */
1287 }
1288
1289 bool
1290 Perl_is_uni_upper_lc(pTHX_ UV c)
1291 {
1292     return is_uni_upper(c);     /* XXX no locale support yet */
1293 }
1294
1295 bool
1296 Perl_is_uni_lower_lc(pTHX_ UV c)
1297 {
1298     return is_uni_lower(c);     /* XXX no locale support yet */
1299 }
1300
1301 bool
1302 Perl_is_uni_cntrl_lc(pTHX_ UV c)
1303 {
1304     return is_uni_cntrl(c);     /* XXX no locale support yet */
1305 }
1306
1307 bool
1308 Perl_is_uni_graph_lc(pTHX_ UV c)
1309 {
1310     return is_uni_graph(c);     /* XXX no locale support yet */
1311 }
1312
1313 bool
1314 Perl_is_uni_print_lc(pTHX_ UV c)
1315 {
1316     return is_uni_print(c);     /* XXX no locale support yet */
1317 }
1318
1319 bool
1320 Perl_is_uni_punct_lc(pTHX_ UV c)
1321 {
1322     return is_uni_punct(c);     /* XXX no locale support yet */
1323 }
1324
1325 bool
1326 Perl_is_uni_xdigit_lc(pTHX_ UV c)
1327 {
1328     return is_uni_xdigit(c);    /* XXX no locale support yet */
1329 }
1330
1331 U32
1332 Perl_to_uni_upper_lc(pTHX_ U32 c)
1333 {
1334     /* XXX returns only the first character -- do not use XXX */
1335     /* XXX no locale support yet */
1336     STRLEN len;
1337     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1338     return (U32)to_uni_upper(c, tmpbuf, &len);
1339 }
1340
1341 U32
1342 Perl_to_uni_title_lc(pTHX_ U32 c)
1343 {
1344     /* XXX returns only the first character XXX -- do not use XXX */
1345     /* XXX no locale support yet */
1346     STRLEN len;
1347     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1348     return (U32)to_uni_title(c, tmpbuf, &len);
1349 }
1350
1351 U32
1352 Perl_to_uni_lower_lc(pTHX_ U32 c)
1353 {
1354     /* XXX returns only the first character -- do not use XXX */
1355     /* XXX no locale support yet */
1356     STRLEN len;
1357     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1358     return (U32)to_uni_lower(c, tmpbuf, &len);
1359 }
1360
1361 static bool
1362 S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
1363                  const char *const swashname)
1364 {
1365     dVAR;
1366
1367     PERL_ARGS_ASSERT_IS_UTF8_COMMON;
1368
1369     if (!is_utf8_char(p))
1370         return FALSE;
1371     if (!*swash)
1372         *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0);
1373     return swash_fetch(*swash, p, TRUE) != 0;
1374 }
1375
1376 bool
1377 Perl_is_utf8_alnum(pTHX_ const U8 *p)
1378 {
1379     dVAR;
1380
1381     PERL_ARGS_ASSERT_IS_UTF8_ALNUM;
1382
1383     /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1384      * descendant of isalnum(3), in other words, it doesn't
1385      * contain the '_'. --jhi */
1386     return is_utf8_common(p, &PL_utf8_alnum, "IsWord");
1387 }
1388
1389 bool
1390 Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
1391 {
1392     dVAR;
1393
1394     PERL_ARGS_ASSERT_IS_UTF8_IDFIRST;
1395
1396     if (*p == '_')
1397         return TRUE;
1398     /* is_utf8_idstart would be more logical. */
1399     return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
1400 }
1401
1402 bool
1403 Perl_is_utf8_idcont(pTHX_ const U8 *p)
1404 {
1405     dVAR;
1406
1407     PERL_ARGS_ASSERT_IS_UTF8_IDCONT;
1408
1409     if (*p == '_')
1410         return TRUE;
1411     return is_utf8_common(p, &PL_utf8_idcont, "IdContinue");
1412 }
1413
1414 bool
1415 Perl_is_utf8_alpha(pTHX_ const U8 *p)
1416 {
1417     dVAR;
1418
1419     PERL_ARGS_ASSERT_IS_UTF8_ALPHA;
1420
1421     return is_utf8_common(p, &PL_utf8_alpha, "IsAlpha");
1422 }
1423
1424 bool
1425 Perl_is_utf8_ascii(pTHX_ const U8 *p)
1426 {
1427     dVAR;
1428
1429     PERL_ARGS_ASSERT_IS_UTF8_ASCII;
1430
1431     return is_utf8_common(p, &PL_utf8_ascii, "IsAscii");
1432 }
1433
1434 bool
1435 Perl_is_utf8_space(pTHX_ const U8 *p)
1436 {
1437     dVAR;
1438
1439     PERL_ARGS_ASSERT_IS_UTF8_SPACE;
1440
1441     return is_utf8_common(p, &PL_utf8_space, "IsSpacePerl");
1442 }
1443
1444 bool
1445 Perl_is_utf8_perl_space(pTHX_ const U8 *p)
1446 {
1447     dVAR;
1448
1449     PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE;
1450
1451     return is_utf8_common(p, &PL_utf8_perl_space, "IsPerlSpace");
1452 }
1453
1454 bool
1455 Perl_is_utf8_perl_word(pTHX_ const U8 *p)
1456 {
1457     dVAR;
1458
1459     PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD;
1460
1461     return is_utf8_common(p, &PL_utf8_perl_word, "IsPerlWord");
1462 }
1463
1464 bool
1465 Perl_is_utf8_digit(pTHX_ const U8 *p)
1466 {
1467     dVAR;
1468
1469     PERL_ARGS_ASSERT_IS_UTF8_DIGIT;
1470
1471     return is_utf8_common(p, &PL_utf8_digit, "IsDigit");
1472 }
1473
1474 bool
1475 Perl_is_utf8_posix_digit(pTHX_ const U8 *p)
1476 {
1477     dVAR;
1478
1479     PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT;
1480
1481     return is_utf8_common(p, &PL_utf8_posix_digit, "IsPosixDigit");
1482 }
1483
1484 bool
1485 Perl_is_utf8_upper(pTHX_ const U8 *p)
1486 {
1487     dVAR;
1488
1489     PERL_ARGS_ASSERT_IS_UTF8_UPPER;
1490
1491     return is_utf8_common(p, &PL_utf8_upper, "IsUppercase");
1492 }
1493
1494 bool
1495 Perl_is_utf8_lower(pTHX_ const U8 *p)
1496 {
1497     dVAR;
1498
1499     PERL_ARGS_ASSERT_IS_UTF8_LOWER;
1500
1501     return is_utf8_common(p, &PL_utf8_lower, "IsLowercase");
1502 }
1503
1504 bool
1505 Perl_is_utf8_cntrl(pTHX_ const U8 *p)
1506 {
1507     dVAR;
1508
1509     PERL_ARGS_ASSERT_IS_UTF8_CNTRL;
1510
1511     return is_utf8_common(p, &PL_utf8_cntrl, "IsCntrl");
1512 }
1513
1514 bool
1515 Perl_is_utf8_graph(pTHX_ const U8 *p)
1516 {
1517     dVAR;
1518
1519     PERL_ARGS_ASSERT_IS_UTF8_GRAPH;
1520
1521     return is_utf8_common(p, &PL_utf8_graph, "IsGraph");
1522 }
1523
1524 bool
1525 Perl_is_utf8_print(pTHX_ const U8 *p)
1526 {
1527     dVAR;
1528
1529     PERL_ARGS_ASSERT_IS_UTF8_PRINT;
1530
1531     return is_utf8_common(p, &PL_utf8_print, "IsPrint");
1532 }
1533
1534 bool
1535 Perl_is_utf8_punct(pTHX_ const U8 *p)
1536 {
1537     dVAR;
1538
1539     PERL_ARGS_ASSERT_IS_UTF8_PUNCT;
1540
1541     return is_utf8_common(p, &PL_utf8_punct, "IsPunct");
1542 }
1543
1544 bool
1545 Perl_is_utf8_xdigit(pTHX_ const U8 *p)
1546 {
1547     dVAR;
1548
1549     PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
1550
1551     return is_utf8_common(p, &PL_utf8_xdigit, "IsXDigit");
1552 }
1553
1554 bool
1555 Perl_is_utf8_mark(pTHX_ const U8 *p)
1556 {
1557     dVAR;
1558
1559     PERL_ARGS_ASSERT_IS_UTF8_MARK;
1560
1561     return is_utf8_common(p, &PL_utf8_mark, "IsM");
1562 }
1563
1564 bool
1565 Perl_is_utf8_X_begin(pTHX_ const U8 *p)
1566 {
1567     dVAR;
1568
1569     PERL_ARGS_ASSERT_IS_UTF8_X_BEGIN;
1570
1571     return is_utf8_common(p, &PL_utf8_X_begin, "_X_Begin");
1572 }
1573
1574 bool
1575 Perl_is_utf8_X_extend(pTHX_ const U8 *p)
1576 {
1577     dVAR;
1578
1579     PERL_ARGS_ASSERT_IS_UTF8_X_EXTEND;
1580
1581     return is_utf8_common(p, &PL_utf8_X_extend, "_X_Extend");
1582 }
1583
1584 bool
1585 Perl_is_utf8_X_prepend(pTHX_ const U8 *p)
1586 {
1587     dVAR;
1588
1589     PERL_ARGS_ASSERT_IS_UTF8_X_PREPEND;
1590
1591     return is_utf8_common(p, &PL_utf8_X_prepend, "GCB=Prepend");
1592 }
1593
1594 bool
1595 Perl_is_utf8_X_non_hangul(pTHX_ const U8 *p)
1596 {
1597     dVAR;
1598
1599     PERL_ARGS_ASSERT_IS_UTF8_X_NON_HANGUL;
1600
1601     return is_utf8_common(p, &PL_utf8_X_non_hangul, "HST=Not_Applicable");
1602 }
1603
1604 bool
1605 Perl_is_utf8_X_L(pTHX_ const U8 *p)
1606 {
1607     dVAR;
1608
1609     PERL_ARGS_ASSERT_IS_UTF8_X_L;
1610
1611     return is_utf8_common(p, &PL_utf8_X_L, "GCB=L");
1612 }
1613
1614 bool
1615 Perl_is_utf8_X_LV(pTHX_ const U8 *p)
1616 {
1617     dVAR;
1618
1619     PERL_ARGS_ASSERT_IS_UTF8_X_LV;
1620
1621     return is_utf8_common(p, &PL_utf8_X_LV, "GCB=LV");
1622 }
1623
1624 bool
1625 Perl_is_utf8_X_LVT(pTHX_ const U8 *p)
1626 {
1627     dVAR;
1628
1629     PERL_ARGS_ASSERT_IS_UTF8_X_LVT;
1630
1631     return is_utf8_common(p, &PL_utf8_X_LVT, "GCB=LVT");
1632 }
1633
1634 bool
1635 Perl_is_utf8_X_T(pTHX_ const U8 *p)
1636 {
1637     dVAR;
1638
1639     PERL_ARGS_ASSERT_IS_UTF8_X_T;
1640
1641     return is_utf8_common(p, &PL_utf8_X_T, "GCB=T");
1642 }
1643
1644 bool
1645 Perl_is_utf8_X_V(pTHX_ const U8 *p)
1646 {
1647     dVAR;
1648
1649     PERL_ARGS_ASSERT_IS_UTF8_X_V;
1650
1651     return is_utf8_common(p, &PL_utf8_X_V, "GCB=V");
1652 }
1653
1654 bool
1655 Perl_is_utf8_X_LV_LVT_V(pTHX_ const U8 *p)
1656 {
1657     dVAR;
1658
1659     PERL_ARGS_ASSERT_IS_UTF8_X_LV_LVT_V;
1660
1661     return is_utf8_common(p, &PL_utf8_X_LV_LVT_V, "_X_LV_LVT_V");
1662 }
1663
1664 /*
1665 =for apidoc to_utf8_case
1666
1667 The "p" contains the pointer to the UTF-8 string encoding
1668 the character that is being converted.
1669
1670 The "ustrp" is a pointer to the character buffer to put the
1671 conversion result to.  The "lenp" is a pointer to the length
1672 of the result.
1673
1674 The "swashp" is a pointer to the swash to use.
1675
1676 Both the special and normal mappings are stored lib/unicore/To/Foo.pl,
1677 and loaded by SWASHNEW, using lib/utf8_heavy.pl.  The special (usually,
1678 but not always, a multicharacter mapping), is tried first.
1679
1680 The "special" is a string like "utf8::ToSpecLower", which means the
1681 hash %utf8::ToSpecLower.  The access to the hash is through
1682 Perl_to_utf8_case().
1683
1684 The "normal" is a string like "ToLower" which means the swash
1685 %utf8::ToLower.
1686
1687 =cut */
1688
1689 UV
1690 Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
1691                         SV **swashp, const char *normal, const char *special)
1692 {
1693     dVAR;
1694     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1695     STRLEN len = 0;
1696     const UV uv0 = utf8_to_uvchr(p, NULL);
1697     /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
1698      * are necessary in EBCDIC, they are redundant no-ops
1699      * in ASCII-ish platforms, and hopefully optimized away. */
1700     const UV uv1 = NATIVE_TO_UNI(uv0);
1701
1702     PERL_ARGS_ASSERT_TO_UTF8_CASE;
1703
1704     uvuni_to_utf8(tmpbuf, uv1);
1705
1706     if (!*swashp) /* load on-demand */
1707          *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1708     /* This is the beginnings of a skeleton of code to read the info section
1709      * that is in all the swashes in case we ever want to do that, so one can
1710      * read things whose maps aren't code points, and whose default if missing
1711      * is not to the code point itself.  This was just to see if it actually
1712      * worked.  Details on what the possibilities are are in perluniprops.pod
1713         HV * const hv = get_hv("utf8::SwashInfo", 0);
1714         if (hv) {
1715          SV **svp;
1716          svp = hv_fetch(hv, (const char*)normal, strlen(normal), FALSE);
1717              const char *s;
1718
1719               HV * const this_hash = SvRV(*svp);
1720                 svp = hv_fetch(this_hash, "type", strlen("type"), FALSE);
1721               s = SvPV_const(*svp, len);
1722         }
1723     }*/
1724
1725     if (special) {
1726          /* It might be "special" (sometimes, but not always,
1727           * a multicharacter mapping) */
1728          HV * const hv = get_hv(special, 0);
1729          SV **svp;
1730
1731          if (hv &&
1732              (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
1733              (*svp)) {
1734              const char *s;
1735
1736               s = SvPV_const(*svp, len);
1737               if (len == 1)
1738                    len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
1739               else {
1740 #ifdef EBCDIC
1741                    /* If we have EBCDIC we need to remap the characters
1742                     * since any characters in the low 256 are Unicode
1743                     * code points, not EBCDIC. */
1744                    U8 *t = (U8*)s, *tend = t + len, *d;
1745
1746                    d = tmpbuf;
1747                    if (SvUTF8(*svp)) {
1748                         STRLEN tlen = 0;
1749
1750                         while (t < tend) {
1751                              const UV c = utf8_to_uvchr(t, &tlen);
1752                              if (tlen > 0) {
1753                                   d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
1754                                   t += tlen;
1755                              }
1756                              else
1757                                   break;
1758                         }
1759                    }
1760                    else {
1761                         while (t < tend) {
1762                              d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
1763                              t++;
1764                         }
1765                    }
1766                    len = d - tmpbuf;
1767                    Copy(tmpbuf, ustrp, len, U8);
1768 #else
1769                    Copy(s, ustrp, len, U8);
1770 #endif
1771               }
1772          }
1773     }
1774
1775     if (!len && *swashp) {
1776         const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
1777
1778          if (uv2) {
1779               /* It was "normal" (a single character mapping). */
1780               const UV uv3 = UNI_TO_NATIVE(uv2);
1781               len = uvchr_to_utf8(ustrp, uv3) - ustrp;
1782          }
1783     }
1784
1785     if (!len) /* Neither: just copy.  In other words, there was no mapping
1786                  defined, which means that the code point maps to itself */
1787          len = uvchr_to_utf8(ustrp, uv0) - ustrp;
1788
1789     if (lenp)
1790          *lenp = len;
1791
1792     return len ? utf8_to_uvchr(ustrp, 0) : 0;
1793 }
1794
1795 /*
1796 =for apidoc to_utf8_upper
1797
1798 Convert the UTF-8 encoded character at p to its uppercase version and
1799 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1800 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
1801 the uppercase version may be longer than the original character.
1802
1803 The first character of the uppercased version is returned
1804 (but note, as explained above, that there may be more.)
1805
1806 =cut */
1807
1808 UV
1809 Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1810 {
1811     dVAR;
1812
1813     PERL_ARGS_ASSERT_TO_UTF8_UPPER;
1814
1815     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1816                              &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
1817 }
1818
1819 /*
1820 =for apidoc to_utf8_title
1821
1822 Convert the UTF-8 encoded character at p to its titlecase version and
1823 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1824 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1825 titlecase version may be longer than the original character.
1826
1827 The first character of the titlecased version is returned
1828 (but note, as explained above, that there may be more.)
1829
1830 =cut */
1831
1832 UV
1833 Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1834 {
1835     dVAR;
1836
1837     PERL_ARGS_ASSERT_TO_UTF8_TITLE;
1838
1839     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1840                              &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
1841 }
1842
1843 /*
1844 =for apidoc to_utf8_lower
1845
1846 Convert the UTF-8 encoded character at p to its lowercase version and
1847 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1848 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1849 lowercase version may be longer than the original character.
1850
1851 The first character of the lowercased version is returned
1852 (but note, as explained above, that there may be more.)
1853
1854 =cut */
1855
1856 UV
1857 Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1858 {
1859     dVAR;
1860
1861     PERL_ARGS_ASSERT_TO_UTF8_LOWER;
1862
1863     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1864                              &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
1865 }
1866
1867 /*
1868 =for apidoc to_utf8_fold
1869
1870 Convert the UTF-8 encoded character at p to its foldcase version and
1871 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1872 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1873 foldcase version may be longer than the original character (up to
1874 three characters).
1875
1876 The first character of the foldcased version is returned
1877 (but note, as explained above, that there may be more.)
1878
1879 =cut */
1880
1881 UV
1882 Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1883 {
1884     dVAR;
1885
1886     PERL_ARGS_ASSERT_TO_UTF8_FOLD;
1887
1888     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1889                              &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
1890 }
1891
1892 /* Note:
1893  * A "swash" is a swatch hash.
1894  * A "swatch" is a bit vector generated by utf8.c:S_swash_get().
1895  * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
1896  * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
1897  */
1898 SV*
1899 Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
1900 {
1901     dVAR;
1902     SV* retval;
1903     dSP;
1904     const size_t pkg_len = strlen(pkg);
1905     const size_t name_len = strlen(name);
1906     HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
1907     SV* errsv_save;
1908
1909     PERL_ARGS_ASSERT_SWASH_INIT;
1910
1911     PUSHSTACKi(PERLSI_MAGIC);
1912     ENTER;
1913     SAVEHINTS();
1914     save_re_context();
1915     if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) {      /* demand load utf8 */
1916         ENTER;
1917         errsv_save = newSVsv(ERRSV);
1918         /* It is assumed that callers of this routine are not passing in any
1919            user derived data.  */
1920         /* Need to do this after save_re_context() as it will set PL_tainted to
1921            1 while saving $1 etc (see the code after getrx: in Perl_magic_get).
1922            Even line to create errsv_save can turn on PL_tainted.  */
1923         SAVEBOOL(PL_tainted);
1924         PL_tainted = 0;
1925         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
1926                          NULL);
1927         if (!SvTRUE(ERRSV))
1928             sv_setsv(ERRSV, errsv_save);
1929         SvREFCNT_dec(errsv_save);
1930         LEAVE;
1931     }
1932     SPAGAIN;
1933     PUSHMARK(SP);
1934     EXTEND(SP,5);
1935     mPUSHp(pkg, pkg_len);
1936     mPUSHp(name, name_len);
1937     PUSHs(listsv);
1938     mPUSHi(minbits);
1939     mPUSHi(none);
1940     PUTBACK;
1941     errsv_save = newSVsv(ERRSV);
1942     if (call_method("SWASHNEW", G_SCALAR))
1943         retval = newSVsv(*PL_stack_sp--);
1944     else
1945         retval = &PL_sv_undef;
1946     if (!SvTRUE(ERRSV))
1947         sv_setsv(ERRSV, errsv_save);
1948     SvREFCNT_dec(errsv_save);
1949     LEAVE;
1950     POPSTACK;
1951     if (IN_PERL_COMPILETIME) {
1952         CopHINTS_set(PL_curcop, PL_hints);
1953     }
1954     if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
1955         if (SvPOK(retval))
1956             Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
1957                        SVfARG(retval));
1958         Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
1959     }
1960     return retval;
1961 }
1962
1963
1964 /* This API is wrong for special case conversions since we may need to
1965  * return several Unicode characters for a single Unicode character
1966  * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
1967  * the lower-level routine, and it is similarly broken for returning
1968  * multiple values.  --jhi */
1969 /* Now SWASHGET is recasted into S_swash_get in this file. */
1970
1971 /* Note:
1972  * Returns the value of property/mapping C<swash> for the first character
1973  * of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
1974  * assumed to be in utf8. If C<do_utf8> is false, the string C<ptr> is
1975  * assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
1976  */
1977 UV
1978 Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
1979 {
1980     dVAR;
1981     HV *const hv = MUTABLE_HV(SvRV(swash));
1982     U32 klen;
1983     U32 off;
1984     STRLEN slen;
1985     STRLEN needents;
1986     const U8 *tmps = NULL;
1987     U32 bit;
1988     SV *swatch;
1989     U8 tmputf8[2];
1990     const UV c = NATIVE_TO_ASCII(*ptr);
1991
1992     PERL_ARGS_ASSERT_SWASH_FETCH;
1993
1994     if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
1995         tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
1996         tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
1997         ptr = tmputf8;
1998     }
1999     /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
2000      * then the "swatch" is a vec() for all the chars which start
2001      * with 0xAA..0xYY
2002      * So the key in the hash (klen) is length of encoded char -1
2003      */
2004     klen = UTF8SKIP(ptr) - 1;
2005     off  = ptr[klen];
2006
2007     if (klen == 0) {
2008       /* If char is invariant then swatch is for all the invariant chars
2009        * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
2010        */
2011         needents = UTF_CONTINUATION_MARK;
2012         off      = NATIVE_TO_UTF(ptr[klen]);
2013     }
2014     else {
2015       /* If char is encoded then swatch is for the prefix */
2016         needents = (1 << UTF_ACCUMULATION_SHIFT);
2017         off      = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
2018     }
2019
2020     /*
2021      * This single-entry cache saves about 1/3 of the utf8 overhead in test
2022      * suite.  (That is, only 7-8% overall over just a hash cache.  Still,
2023      * it's nothing to sniff at.)  Pity we usually come through at least
2024      * two function calls to get here...
2025      *
2026      * NB: this code assumes that swatches are never modified, once generated!
2027      */
2028
2029     if (hv   == PL_last_swash_hv &&
2030         klen == PL_last_swash_klen &&
2031         (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
2032     {
2033         tmps = PL_last_swash_tmps;
2034         slen = PL_last_swash_slen;
2035     }
2036     else {
2037         /* Try our second-level swatch cache, kept in a hash. */
2038         SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE);
2039
2040         /* If not cached, generate it via swash_get */
2041         if (!svp || !SvPOK(*svp)
2042                  || !(tmps = (const U8*)SvPV_const(*svp, slen))) {
2043             /* We use utf8n_to_uvuni() as we want an index into
2044                Unicode tables, not a native character number.
2045              */
2046             const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
2047                                            ckWARN(WARN_UTF8) ?
2048                                            0 : UTF8_ALLOW_ANY);
2049             swatch = swash_get(swash,
2050                     /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
2051                                 (klen) ? (code_point & ~(needents - 1)) : 0,
2052                                 needents);
2053
2054             if (IN_PERL_COMPILETIME)
2055                 CopHINTS_set(PL_curcop, PL_hints);
2056
2057             svp = hv_store(hv, (const char *)ptr, klen, swatch, 0);
2058
2059             if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
2060                      || (slen << 3) < needents)
2061                 Perl_croak(aTHX_ "panic: swash_fetch got improper swatch");
2062         }
2063
2064         PL_last_swash_hv = hv;
2065         assert(klen <= sizeof(PL_last_swash_key));
2066         PL_last_swash_klen = (U8)klen;
2067         /* FIXME change interpvar.h?  */
2068         PL_last_swash_tmps = (U8 *) tmps;
2069         PL_last_swash_slen = slen;
2070         if (klen)
2071             Copy(ptr, PL_last_swash_key, klen, U8);
2072     }
2073
2074     switch ((int)((slen << 3) / needents)) {
2075     case 1:
2076         bit = 1 << (off & 7);
2077         off >>= 3;
2078         return (tmps[off] & bit) != 0;
2079     case 8:
2080         return tmps[off];
2081     case 16:
2082         off <<= 1;
2083         return (tmps[off] << 8) + tmps[off + 1] ;
2084     case 32:
2085         off <<= 2;
2086         return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
2087     }
2088     Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width");
2089     NORETURN_FUNCTION_END;
2090 }
2091
2092 /* Read a single line of the main body of the swash input text.  These are of
2093  * the form:
2094  * 0053 0056    0073
2095  * where each number is hex.  The first two numbers form the minimum and
2096  * maximum of a range, and the third is the value associated with the range.
2097  * Not all swashes should have a third number
2098  *
2099  * On input: l    points to the beginning of the line to be examined; it points
2100  *                to somewhere in the string of the whole input text, and is
2101  *                terminated by a \n or the null string terminator.
2102  *           lend   points to the null terminator of that string
2103  *           wants_value    is non-zero if the swash expects a third number
2104  *           typestr is the name of the swash's mapping, like 'ToLower'
2105  * On output: *min, *max, and *val are set to the values read from the line.
2106  *            returns a pointer just beyond the line examined.  If there was no
2107  *            valid min number on the line, returns lend+1
2108  */
2109
2110 STATIC U8*
2111 S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val,
2112                              const bool wants_value, const U8* const typestr)
2113 {
2114     const int  typeto  = typestr[0] == 'T' && typestr[1] == 'o';
2115     STRLEN numlen;          /* Length of the number */
2116     I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
2117
2118     /* nl points to the next \n in the scan */
2119     U8* const nl = (U8*)memchr(l, '\n', lend - l);
2120
2121     /* Get the first number on the line: the range minimum */
2122     numlen = lend - l;
2123     *min = grok_hex((char *)l, &numlen, &flags, NULL);
2124     if (numlen)     /* If found a hex number, position past it */
2125         l += numlen;
2126     else if (nl) {          /* Else, go handle next line, if any */
2127         return nl + 1;  /* 1 is length of "\n" */
2128     }
2129     else {              /* Else, no next line */
2130         return lend + 1;        /* to LIST's end at which \n is not found */
2131     }
2132
2133     /* The max range value follows, separated by a BLANK */
2134     if (isBLANK(*l)) {
2135         ++l;
2136         flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
2137         numlen = lend - l;
2138         *max = grok_hex((char *)l, &numlen, &flags, NULL);
2139         if (numlen)
2140             l += numlen;
2141         else    /* If no value here, it is a single element range */
2142             *max = *min;
2143
2144         /* Non-binary tables have a third entry: what the first element of the
2145          * range maps to */
2146         if (wants_value) {
2147             if (isBLANK(*l)) {
2148                 ++l;
2149                 flags = PERL_SCAN_SILENT_ILLDIGIT |
2150                         PERL_SCAN_DISALLOW_PREFIX;
2151                 numlen = lend - l;
2152                 *val = grok_hex((char *)l, &numlen, &flags, NULL);
2153                 if (numlen)
2154                     l += numlen;
2155                 else
2156                     *val = 0;
2157             }
2158             else {
2159                 *val = 0;
2160                 if (typeto) {
2161                     Perl_croak(aTHX_ "%s: illegal mapping '%s'",
2162                                      typestr, l);
2163                 }
2164             }
2165         }
2166         else
2167             *val = 0; /* bits == 1, then any val should be ignored */
2168     }
2169     else { /* Nothing following range min, should be single element with no
2170               mapping expected */
2171         *max = *min;
2172         if (wants_value) {
2173             *val = 0;
2174             if (typeto) {
2175                 Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
2176             }
2177         }
2178         else
2179             *val = 0; /* bits == 1, then val should be ignored */
2180     }
2181
2182     /* Position to next line if any, or EOF */
2183     if (nl)
2184         l = nl + 1;
2185     else
2186         l = lend;
2187
2188     return l;
2189 }
2190
2191 /* Note:
2192  * Returns a swatch (a bit vector string) for a code point sequence
2193  * that starts from the value C<start> and comprises the number C<span>.
2194  * A C<swash> must be an object created by SWASHNEW (see lib/utf8_heavy.pl).
2195  * Should be used via swash_fetch, which will cache the swatch in C<swash>.
2196  */
2197 STATIC SV*
2198 S_swash_get(pTHX_ SV* swash, UV start, UV span)
2199 {
2200     SV *swatch;
2201     U8 *l, *lend, *x, *xend, *s;
2202     STRLEN lcur, xcur, scur;
2203     HV *const hv = MUTABLE_HV(SvRV(swash));
2204
2205     /* The string containing the main body of the table */
2206     SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
2207
2208     SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
2209     SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
2210     SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
2211     SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
2212     const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
2213     const STRLEN bits  = SvUV(*bitssvp);
2214     const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
2215     const UV     none  = SvUV(*nonesvp);
2216     const UV     end   = start + span;
2217
2218     PERL_ARGS_ASSERT_SWASH_GET;
2219
2220     if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
2221         Perl_croak(aTHX_ "panic: swash_get doesn't expect bits %"UVuf,
2222                                                  (UV)bits);
2223     }
2224
2225     /* create and initialize $swatch */
2226     scur   = octets ? (span * octets) : (span + 7) / 8;
2227     swatch = newSV(scur);
2228     SvPOK_on(swatch);
2229     s = (U8*)SvPVX(swatch);
2230     if (octets && none) {
2231         const U8* const e = s + scur;
2232         while (s < e) {
2233             if (bits == 8)
2234                 *s++ = (U8)(none & 0xff);
2235             else if (bits == 16) {
2236                 *s++ = (U8)((none >>  8) & 0xff);
2237                 *s++ = (U8)( none        & 0xff);
2238             }
2239             else if (bits == 32) {
2240                 *s++ = (U8)((none >> 24) & 0xff);
2241                 *s++ = (U8)((none >> 16) & 0xff);
2242                 *s++ = (U8)((none >>  8) & 0xff);
2243                 *s++ = (U8)( none        & 0xff);
2244             }
2245         }
2246         *s = '\0';
2247     }
2248     else {
2249         (void)memzero((U8*)s, scur + 1);
2250     }
2251     SvCUR_set(swatch, scur);
2252     s = (U8*)SvPVX(swatch);
2253
2254     /* read $swash->{LIST} */
2255     l = (U8*)SvPV(*listsvp, lcur);
2256     lend = l + lcur;
2257     while (l < lend) {
2258         UV min, max, val;
2259         l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
2260                                          cBOOL(octets), typestr);
2261         if (l > lend) {
2262             break;
2263         }
2264
2265         /* If looking for something beyond this range, go try the next one */
2266         if (max < start)
2267             continue;
2268
2269         if (octets) {
2270             UV key;
2271             if (min < start) {
2272                 if (!none || val < none) {
2273                     val += start - min;
2274                 }
2275                 min = start;
2276             }
2277             for (key = min; key <= max; key++) {
2278                 STRLEN offset;
2279                 if (key >= end)
2280                     goto go_out_list;
2281                 /* offset must be non-negative (start <= min <= key < end) */
2282                 offset = octets * (key - start);
2283                 if (bits == 8)
2284                     s[offset] = (U8)(val & 0xff);
2285                 else if (bits == 16) {
2286                     s[offset    ] = (U8)((val >>  8) & 0xff);
2287                     s[offset + 1] = (U8)( val        & 0xff);
2288                 }
2289                 else if (bits == 32) {
2290                     s[offset    ] = (U8)((val >> 24) & 0xff);
2291                     s[offset + 1] = (U8)((val >> 16) & 0xff);
2292                     s[offset + 2] = (U8)((val >>  8) & 0xff);
2293                     s[offset + 3] = (U8)( val        & 0xff);
2294                 }
2295
2296                 if (!none || val < none)
2297                     ++val;
2298             }
2299         }
2300         else { /* bits == 1, then val should be ignored */
2301             UV key;
2302             if (min < start)
2303                 min = start;
2304             for (key = min; key <= max; key++) {
2305                 const STRLEN offset = (STRLEN)(key - start);
2306                 if (key >= end)
2307                     goto go_out_list;
2308                 s[offset >> 3] |= 1 << (offset & 7);
2309             }
2310         }
2311     } /* while */
2312   go_out_list:
2313
2314     /* read $swash->{EXTRAS} */
2315     x = (U8*)SvPV(*extssvp, xcur);
2316     xend = x + xcur;
2317     while (x < xend) {
2318         STRLEN namelen;
2319         U8 *namestr;
2320         SV** othersvp;
2321         HV* otherhv;
2322         STRLEN otherbits;
2323         SV **otherbitssvp, *other;
2324         U8 *s, *o, *nl;
2325         STRLEN slen, olen;
2326
2327         const U8 opc = *x++;
2328         if (opc == '\n')
2329             continue;
2330
2331         nl = (U8*)memchr(x, '\n', xend - x);
2332
2333         if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
2334             if (nl) {
2335                 x = nl + 1; /* 1 is length of "\n" */
2336                 continue;
2337             }
2338             else {
2339                 x = xend; /* to EXTRAS' end at which \n is not found */
2340                 break;
2341             }
2342         }
2343
2344         namestr = x;
2345         if (nl) {
2346             namelen = nl - namestr;
2347             x = nl + 1;
2348         }
2349         else {
2350             namelen = xend - namestr;
2351             x = xend;
2352         }
2353
2354         othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
2355         otherhv = MUTABLE_HV(SvRV(*othersvp));
2356         otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
2357         otherbits = (STRLEN)SvUV(*otherbitssvp);
2358         if (bits < otherbits)
2359             Perl_croak(aTHX_ "panic: swash_get found swatch size mismatch");
2360
2361         /* The "other" swatch must be destroyed after. */
2362         other = swash_get(*othersvp, start, span);
2363         o = (U8*)SvPV(other, olen);
2364
2365         if (!olen)
2366             Perl_croak(aTHX_ "panic: swash_get got improper swatch");
2367
2368         s = (U8*)SvPV(swatch, slen);
2369         if (bits == 1 && otherbits == 1) {
2370             if (slen != olen)
2371                 Perl_croak(aTHX_ "panic: swash_get found swatch length mismatch");
2372
2373             switch (opc) {
2374             case '+':
2375                 while (slen--)
2376                     *s++ |= *o++;
2377                 break;
2378             case '!':
2379                 while (slen--)
2380                     *s++ |= ~*o++;
2381                 break;
2382             case '-':
2383                 while (slen--)
2384                     *s++ &= ~*o++;
2385                 break;
2386             case '&':
2387                 while (slen--)
2388                     *s++ &= *o++;
2389                 break;
2390             default:
2391                 break;
2392             }
2393         }
2394         else {
2395             STRLEN otheroctets = otherbits >> 3;
2396             STRLEN offset = 0;
2397             U8* const send = s + slen;
2398
2399             while (s < send) {
2400                 UV otherval = 0;
2401
2402                 if (otherbits == 1) {
2403                     otherval = (o[offset >> 3] >> (offset & 7)) & 1;
2404                     ++offset;
2405                 }
2406                 else {
2407                     STRLEN vlen = otheroctets;
2408                     otherval = *o++;
2409                     while (--vlen) {
2410                         otherval <<= 8;
2411                         otherval |= *o++;
2412                     }
2413                 }
2414
2415                 if (opc == '+' && otherval)
2416                     NOOP;   /* replace with otherval */
2417                 else if (opc == '!' && !otherval)
2418                     otherval = 1;
2419                 else if (opc == '-' && otherval)
2420                     otherval = 0;
2421                 else if (opc == '&' && !otherval)
2422                     otherval = 0;
2423                 else {
2424                     s += octets; /* no replacement */
2425                     continue;
2426                 }
2427
2428                 if (bits == 8)
2429                     *s++ = (U8)( otherval & 0xff);
2430                 else if (bits == 16) {
2431                     *s++ = (U8)((otherval >>  8) & 0xff);
2432                     *s++ = (U8)( otherval        & 0xff);
2433                 }
2434                 else if (bits == 32) {
2435                     *s++ = (U8)((otherval >> 24) & 0xff);
2436                     *s++ = (U8)((otherval >> 16) & 0xff);
2437                     *s++ = (U8)((otherval >>  8) & 0xff);
2438                     *s++ = (U8)( otherval        & 0xff);
2439                 }
2440             }
2441         }
2442         sv_free(other); /* through with it! */
2443     } /* while */
2444     return swatch;
2445 }
2446
2447 HV*
2448 Perl__swash_inversion_hash(pTHX_ SV* swash)
2449 {
2450
2451    /* Subject to change or removal.  For use only in one place in regexec.c
2452     *
2453     * Returns a hash which is the inversion and closure of a swash mapping.
2454     * For example, consider the input lines:
2455     * 004B              006B
2456     * 004C              006C
2457     * 212A              006B
2458     *
2459     * The returned hash would have two keys, the utf8 for 006B and the utf8 for
2460     * 006C.  The value for each key is an array.  For 006C, the array would
2461     * have a two elements, the utf8 for itself, and for 004C.  For 006B, there
2462     * would be three elements in its array, the utf8 for 006B, 004B and 212A.
2463     *
2464     * Essentially, for any code point, it gives all the code points that map to
2465     * it, or the list of 'froms' for that point.
2466     *
2467     * Currently it only looks at the main body of the swash, and ignores any
2468     * additions or deletions from other swashes */
2469
2470     U8 *l, *lend;
2471     STRLEN lcur;
2472     HV *const hv = MUTABLE_HV(SvRV(swash));
2473
2474     /* The string containing the main body of the table */
2475     SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
2476
2477     SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
2478     SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
2479     SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
2480     /*SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);*/
2481     const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
2482     const STRLEN bits  = SvUV(*bitssvp);
2483     const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
2484     const UV     none  = SvUV(*nonesvp);
2485
2486     HV* ret = newHV();
2487
2488     PERL_ARGS_ASSERT__SWASH_INVERSION_HASH;
2489
2490     /* Must have at least 8 bits to get the mappings */
2491     if (bits != 8 && bits != 16 && bits != 32) {
2492         Perl_croak(aTHX_ "panic: swash_inversion_hash doesn't expect bits %"UVuf,
2493                                                  (UV)bits);
2494     }
2495
2496     /* read $swash->{LIST} */
2497     l = (U8*)SvPV(*listsvp, lcur);
2498     lend = l + lcur;
2499
2500     /* Go through each input line */
2501     while (l < lend) {
2502         UV min, max, val;
2503         UV inverse;
2504         l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
2505                                          cBOOL(octets), typestr);
2506         if (l > lend) {
2507             break;
2508         }
2509
2510         /* Each element in the range is to be inverted */
2511         for (inverse = min; inverse <= max; inverse++) {
2512             AV* list;
2513             SV* element;
2514             SV** listp;
2515             IV i;
2516             bool found_key = FALSE;
2517
2518             /* The key is the inverse mapping */
2519             char key[UTF8_MAXBYTES+1];
2520             char* key_end = (char *) uvuni_to_utf8((U8*) key, val);
2521             STRLEN key_len = key_end - key;
2522
2523             /* And the value is what the forward mapping is from. */
2524             char utf8_inverse[UTF8_MAXBYTES+1];
2525             char *utf8_inverse_end = (char *) uvuni_to_utf8((U8*) utf8_inverse, inverse);
2526
2527             /* Get the list for the map */
2528             if ((listp = hv_fetch(ret, key, key_len, FALSE))) {
2529                 list = (AV*) *listp;
2530             }
2531             else { /* No entry yet for it: create one */
2532                 list = newAV();
2533                 if (! hv_store(ret, key, key_len, (SV*) list, FALSE)) {
2534                     Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
2535                 }
2536             }
2537
2538             for (i = 0; i < av_len(list); i++) {
2539                 SV** entryp = av_fetch(list, i, FALSE);
2540                 SV* entry;
2541                 if (entryp == NULL) {
2542                     Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
2543                 }
2544                 entry = *entryp;
2545                 if (SvCUR(entry) != key_len) {
2546                     continue;
2547                 }
2548                 if (memEQ(key, SvPVX(entry), key_len)) {
2549                     found_key = TRUE;
2550                     break;
2551                 }
2552             }
2553             if (! found_key) {
2554                 element = newSVpvn_flags(key, key_len, SVf_UTF8);
2555                 av_push(list, element);
2556             }
2557
2558
2559             /* Simply add the value to the list */
2560             element = newSVpvn_flags(utf8_inverse, utf8_inverse_end - utf8_inverse, SVf_UTF8);
2561             av_push(list, element);
2562
2563             /* swash_get() increments the value of val for each element in the
2564              * range.  That makes more compact tables possible.  You can
2565              * express the capitalization, for example, of all consecutive
2566              * letters with a single line: 0061\t007A\t0041 This maps 0061 to
2567              * 0041, 0062 to 0042, etc.  I (khw) have never understood 'none',
2568              * and it's not documented, and perhaps not even currently used,
2569              * but I copied the semantics from swash_get(), just in case */
2570             if (!none || val < none) {
2571                 ++val;
2572             }
2573         }
2574     }
2575
2576     return ret;
2577 }
2578
2579 /*
2580 =for apidoc uvchr_to_utf8
2581
2582 Adds the UTF-8 representation of the Native codepoint C<uv> to the end
2583 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
2584 bytes available. The return value is the pointer to the byte after the
2585 end of the new character. In other words,
2586
2587     d = uvchr_to_utf8(d, uv);
2588
2589 is the recommended wide native character-aware way of saying
2590
2591     *(d++) = uv;
2592
2593 =cut
2594 */
2595
2596 /* On ASCII machines this is normally a macro but we want a
2597    real function in case XS code wants it
2598 */
2599 U8 *
2600 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
2601 {
2602     PERL_ARGS_ASSERT_UVCHR_TO_UTF8;
2603
2604     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
2605 }
2606
2607 U8 *
2608 Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
2609 {
2610     PERL_ARGS_ASSERT_UVCHR_TO_UTF8_FLAGS;
2611
2612     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
2613 }
2614
2615 /*
2616 =for apidoc utf8n_to_uvchr
2617 flags
2618
2619 Returns the native character value of the first character in the string
2620 C<s>
2621 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
2622 length, in bytes, of that character.
2623
2624 Allows length and flags to be passed to low level routine.
2625
2626 =cut
2627 */
2628 /* On ASCII machines this is normally a macro but we want
2629    a real function in case XS code wants it
2630 */
2631 UV
2632 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
2633 U32 flags)
2634 {
2635     const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
2636
2637     PERL_ARGS_ASSERT_UTF8N_TO_UVCHR;
2638
2639     return UNI_TO_NATIVE(uv);
2640 }
2641
2642 /*
2643 =for apidoc pv_uni_display
2644
2645 Build to the scalar dsv a displayable version of the string spv,
2646 length len, the displayable version being at most pvlim bytes long
2647 (if longer, the rest is truncated and "..." will be appended).
2648
2649 The flags argument can have UNI_DISPLAY_ISPRINT set to display
2650 isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
2651 to display the \\[nrfta\\] as the backslashed versions (like '\n')
2652 (UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
2653 UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
2654 UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
2655
2656 The pointer to the PV of the dsv is returned.
2657
2658 =cut */
2659 char *
2660 Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
2661 {
2662     int truncated = 0;
2663     const char *s, *e;
2664
2665     PERL_ARGS_ASSERT_PV_UNI_DISPLAY;
2666
2667     sv_setpvs(dsv, "");
2668     SvUTF8_off(dsv);
2669     for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
2670          UV u;
2671           /* This serves double duty as a flag and a character to print after
2672              a \ when flags & UNI_DISPLAY_BACKSLASH is true.
2673           */
2674          char ok = 0;
2675
2676          if (pvlim && SvCUR(dsv) >= pvlim) {
2677               truncated++;
2678               break;
2679          }
2680          u = utf8_to_uvchr((U8*)s, 0);
2681          if (u < 256) {
2682              const unsigned char c = (unsigned char)u & 0xFF;
2683              if (flags & UNI_DISPLAY_BACKSLASH) {
2684                  switch (c) {
2685                  case '\n':
2686                      ok = 'n'; break;
2687                  case '\r':
2688                      ok = 'r'; break;
2689                  case '\t':
2690                      ok = 't'; break;
2691                  case '\f':
2692                      ok = 'f'; break;
2693                  case '\a':
2694                      ok = 'a'; break;
2695                  case '\\':
2696                      ok = '\\'; break;
2697                  default: break;
2698                  }
2699                  if (ok) {
2700                      const char string = ok;
2701                      sv_catpvs(dsv, "\\");
2702                      sv_catpvn(dsv, &string, 1);
2703                  }
2704              }
2705              /* isPRINT() is the locale-blind version. */
2706              if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
2707                  const char string = c;
2708                  sv_catpvn(dsv, &string, 1);
2709                  ok = 1;
2710              }
2711          }
2712          if (!ok)
2713              Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
2714     }
2715     if (truncated)
2716          sv_catpvs(dsv, "...");
2717
2718     return SvPVX(dsv);
2719 }
2720
2721 /*
2722 =for apidoc sv_uni_display
2723
2724 Build to the scalar dsv a displayable version of the scalar sv,
2725 the displayable version being at most pvlim bytes long
2726 (if longer, the rest is truncated and "..." will be appended).
2727
2728 The flags argument is as in pv_uni_display().
2729
2730 The pointer to the PV of the dsv is returned.
2731
2732 =cut
2733 */
2734 char *
2735 Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
2736 {
2737     PERL_ARGS_ASSERT_SV_UNI_DISPLAY;
2738
2739      return Perl_pv_uni_display(aTHX_ dsv, (const U8*)SvPVX_const(ssv),
2740                                 SvCUR(ssv), pvlim, flags);
2741 }
2742
2743 /*
2744 =for apidoc foldEQ_utf8
2745
2746 Returns true if the leading portions of the strings s1 and s2 (either or both
2747 of which may be in UTF-8) are the same case-insensitively; false otherwise.
2748 How far into the strings to compare is determined by other input parameters.
2749
2750 If u1 is true, the string s1 is assumed to be in UTF-8-encoded Unicode;
2751 otherwise it is assumed to be in native 8-bit encoding.  Correspondingly for u2
2752 with respect to s2.
2753
2754 If the byte length l1 is non-zero, it says how far into s1 to check for fold
2755 equality.  In other words, s1+l1 will be used as a goal to reach.  The
2756 scan will not be considered to be a match unless the goal is reached, and
2757 scanning won't continue past that goal.  Correspondingly for l2 with respect to
2758 s2.
2759
2760 If pe1 is non-NULL and the pointer it points to is not NULL, that pointer is
2761 considered an end pointer beyond which scanning of s1 will not continue under
2762 any circumstances.  This means that if both l1 and pe1 are specified, and pe1
2763 is less than s1+l1, the match will never be successful because it can never
2764 get as far as its goal (and in fact is asserted against).  Correspondingly for
2765 pe2 with respect to s2.
2766
2767 At least one of s1 and s2 must have a goal (at least one of l1 and l2 must be
2768 non-zero), and if both do, both have to be
2769 reached for a successful match.   Also, if the fold of a character is multiple
2770 characters, all of them must be matched (see tr21 reference below for
2771 'folding').
2772
2773 Upon a successful match, if pe1 is non-NULL,
2774 it will be set to point to the beginning of the I<next> character of s1 beyond
2775 what was matched.  Correspondingly for pe2 and s2.
2776
2777 For case-insensitiveness, the "casefolding" of Unicode is used
2778 instead of upper/lowercasing both the characters, see
2779 http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
2780
2781 =cut */
2782 I32
2783 Perl_foldEQ_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
2784 {
2785     dVAR;
2786     register const U8 *p1  = (const U8*)s1; /* Point to current char */
2787     register const U8 *p2  = (const U8*)s2;
2788     register const U8 *g1 = NULL;       /* goal for s1 */
2789     register const U8 *g2 = NULL;
2790     register const U8 *e1 = NULL;       /* Don't scan s1 past this */
2791     register U8 *f1 = NULL;             /* Point to current folded */
2792     register const U8 *e2 = NULL;
2793     register U8 *f2 = NULL;
2794     STRLEN n1 = 0, n2 = 0;              /* Number of bytes in current char */
2795     U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
2796     U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
2797     U8 natbuf[2];               /* Holds native 8-bit char converted to utf8;
2798                                    these always fit in 2 bytes */
2799
2800     PERL_ARGS_ASSERT_FOLDEQ_UTF8;
2801
2802     if (pe1) {
2803         e1 = *(U8**)pe1;
2804     }
2805
2806     if (l1) {
2807         g1 = (const U8*)s1 + l1;
2808     }
2809
2810     if (pe2) {
2811         e2 = *(U8**)pe2;
2812     }
2813
2814     if (l2) {
2815         g2 = (const U8*)s2 + l2;
2816     }
2817
2818     /* Must have at least one goal */
2819     assert(g1 || g2);
2820
2821     if (g1) {
2822
2823         /* Will never match if goal is out-of-bounds */
2824         assert(! e1  || e1 >= g1);
2825
2826         /* Here, there isn't an end pointer, or it is beyond the goal.  We
2827         * only go as far as the goal */
2828         e1 = g1;
2829     }
2830     else {
2831         assert(e1);    /* Must have an end for looking at s1 */
2832     }
2833
2834     /* Same for goal for s2 */
2835     if (g2) {
2836         assert(! e2  || e2 >= g2);
2837         e2 = g2;
2838     }
2839     else {
2840         assert(e2);
2841     }
2842
2843     /* Look through both strings, a character at a time */
2844     while (p1 < e1 && p2 < e2) {
2845
2846         /* If at the beginning of a new character in s1, get its fold to use
2847          * and the length of the fold */
2848         if (n1 == 0) {
2849             if (u1) {
2850                 to_utf8_fold(p1, foldbuf1, &n1);
2851             }
2852             else {  /* Not utf8, convert to it first and then get fold */
2853                 uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p1)));
2854                 to_utf8_fold(natbuf, foldbuf1, &n1);
2855             }
2856             f1 = foldbuf1;
2857         }
2858
2859         if (n2 == 0) {    /* Same for s2 */
2860             if (u2) {
2861                 to_utf8_fold(p2, foldbuf2, &n2);
2862             }
2863             else {
2864                 uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p2)));
2865                 to_utf8_fold(natbuf, foldbuf2, &n2);
2866             }
2867             f2 = foldbuf2;
2868         }
2869
2870         /* While there is more to look for in both folds, see if they
2871         * continue to match */
2872         while (n1 && n2) {
2873             U8 fold_length = UTF8SKIP(f1);
2874             if (fold_length != UTF8SKIP(f2)
2875                 || (fold_length == 1 && *f1 != *f2) /* Short circuit memNE
2876                                                        function call for single
2877                                                        character */
2878                 || memNE((char*)f1, (char*)f2, fold_length))
2879             {
2880                 return 0; /* mismatch */
2881             }
2882
2883             /* Here, they matched, advance past them */
2884             n1 -= fold_length;
2885             f1 += fold_length;
2886             n2 -= fold_length;
2887             f2 += fold_length;
2888         }
2889
2890         /* When reach the end of any fold, advance the input past it */
2891         if (n1 == 0) {
2892             p1 += u1 ? UTF8SKIP(p1) : 1;
2893         }
2894         if (n2 == 0) {
2895             p2 += u2 ? UTF8SKIP(p2) : 1;
2896         }
2897     } /* End of loop through both strings */
2898
2899     /* A match is defined by each scan that specified an explicit length
2900     * reaching its final goal, and the other not having matched a partial
2901     * character (which can happen when the fold of a character is more than one
2902     * character). */
2903     if (! ((g1 == 0 || p1 == g1) && (g2 == 0 || p2 == g2)) || n1 || n2) {
2904         return 0;
2905     }
2906
2907     /* Successful match.  Set output pointers */
2908     if (pe1) {
2909         *pe1 = (char*)p1;
2910     }
2911     if (pe2) {
2912         *pe2 = (char*)p2;
2913     }
2914     return 1;
2915 }
2916
2917 /*
2918  * Local variables:
2919  * c-indentation-style: bsd
2920  * c-basic-offset: 4
2921  * indent-tabs-mode: t
2922  * End:
2923  *
2924  * ex: set ts=8 sts=4 sw=4 noet:
2925  */