utf8.c

   1 /*    utf8.c
   2  *
   3  *    Copyright (c) 1998-2001, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * 'What a fix!' said Sam. 'That's the one place in all the lands we've ever
  12  * heard of that we don't want to see any closer; and that's the one place
  13  * we're trying to get to!  And that's just where we can't get, nohow.'
  14  *
  15  * 'Well do I understand your speech,' he answered in the same language;
  16  * 'yet few strangers do so.  Why then do you not speak in the Common Tongue,
  17  * as is the custom in the West, if you wish to be answered?'
  18  *
  19  * ...the travellers perceived that the floor was paved with stones of many
  20  * hues; branching runes and strange devices intertwined beneath their feet.
  21  */
  22
  23 #include "EXTERN.h"
  24 #define PERL_IN_UTF8_C
  25 #include "perl.h"
  26
  27 /* Unicode support */
  28
  29 U8 *
  30 Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* the d must be UTF8_MAXLEN+1 deep */
  31 {
  32     if (uv < 0x80) {
  33         *d++ = uv;
  34         return d;
  35     }
  36     if (uv < 0x800) {
  37         *d++ = (( uv >>  6)         | 0xc0);
  38         *d++ = (( uv        & 0x3f) | 0x80);
  39         return d;
  40     }
  41     if (uv < 0x10000) {
  42         *d++ = (( uv >> 12)         | 0xe0);
  43         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  44         *d++ = (( uv        & 0x3f) | 0x80);
  45         return d;
  46     }
  47     if (uv < 0x200000) {
  48         *d++ = (( uv >> 18)         | 0xf0);
  49         *d++ = (((uv >> 12) & 0x3f) | 0x80);
  50         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  51         *d++ = (( uv        & 0x3f) | 0x80);
  52         return d;
  53     }
  54     if (uv < 0x4000000) {
  55         *d++ = (( uv >> 24)         | 0xf8);
  56         *d++ = (((uv >> 18) & 0x3f) | 0x80);
  57         *d++ = (((uv >> 12) & 0x3f) | 0x80);
  58         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  59         *d++ = (( uv        & 0x3f) | 0x80);
  60         return d;
  61     }
  62     if (uv < 0x80000000) {
  63         *d++ = (( uv >> 30)         | 0xfc);
  64         *d++ = (((uv >> 24) & 0x3f) | 0x80);
  65         *d++ = (((uv >> 18) & 0x3f) | 0x80);
  66         *d++ = (((uv >> 12) & 0x3f) | 0x80);
  67         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  68         *d++ = (( uv        & 0x3f) | 0x80);
  69         return d;
  70     }
  71 #ifdef HAS_QUAD
  72     if (uv < UTF8_QUAD_MAX)
  73 #endif
  74     {
  75         *d++ =                        0xfe;     /* Can't match U+FEFF! */
  76         *d++ = (((uv >> 30) & 0x3f) | 0x80);
  77         *d++ = (((uv >> 24) & 0x3f) | 0x80);
  78         *d++ = (((uv >> 18) & 0x3f) | 0x80);
  79         *d++ = (((uv >> 12) & 0x3f) | 0x80);
  80         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  81         *d++ = (( uv        & 0x3f) | 0x80);
  82         return d;
  83     }
  84 #ifdef HAS_QUAD
  85     {
  86         *d++ =                        0xff;     /* Can't match U+FFFE! */
  87         *d++ =                        0x80;     /* 6 Reserved bits */
  88         *d++ = (((uv >> 60) & 0x0f) | 0x80);    /* 2 Reserved bits */
  89         *d++ = (((uv >> 54) & 0x3f) | 0x80);
  90         *d++ = (((uv >> 48) & 0x3f) | 0x80);
  91         *d++ = (((uv >> 42) & 0x3f) | 0x80);
  92         *d++ = (((uv >> 36) & 0x3f) | 0x80);
  93         *d++ = (((uv >> 30) & 0x3f) | 0x80);
  94         *d++ = (((uv >> 24) & 0x3f) | 0x80);
  95         *d++ = (((uv >> 18) & 0x3f) | 0x80);
  96         *d++ = (((uv >> 12) & 0x3f) | 0x80);
  97         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  98         *d++ = (( uv        & 0x3f) | 0x80);
  99         return d;
 100     }
 101 #endif
 102 }
 103
 104 /* Tests if some arbitrary number of bytes begins in a valid UTF-8 character.
 105  * The actual number of bytes in the UTF-8 character will be returned if it
 106  * is valid, otherwise 0. */
 107 STRLEN
 108 Perl_is_utf8_char(pTHX_ U8 *s)
 109 {
 110     U8 u = *s;
 111     STRLEN slen, len;
 112     UV uv, ouv;
 113
 114     if (UTF8_IS_ASCII(u))
 115         return 1;
 116
 117     if (!UTF8_IS_START(u))
 118         return 0;
 119
 120     len = UTF8SKIP(s);
 121
 122     if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
 123         return 0;
 124
 125     slen = len - 1;
 126     s++;
 127     uv = u;
 128     ouv = uv;
 129     while (slen--) {
 130         if (!UTF8_IS_CONTINUATION(*s))
 131             return 0;
 132         uv = UTF8_ACCUMULATE(uv, *s);
 133         if (uv < ouv)
 134             return 0;
 135         ouv = uv;
 136         s++;
 137     }
 138
 139     if (UNISKIP(uv) < len)
 140         return 0;
 141
 142     return len;
 143 }
 144
 145 /*
 146 =for apidoc Am|is_utf8_string|U8 *s|STRLEN len
 147
 148 Returns true if first C<len> bytes of the given string form valid a UTF8
 149 string, false otherwise.
 150
 151 =cut
 152 */
 153
 154 bool
 155 Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len)
 156 {
 157     U8* x = s;
 158     U8* send;
 159     STRLEN c;
 160
 161     if (!len)
 162         len = strlen((char *)s);
 163     send = s + len;
 164
 165     while (x < send) {
 166         c = is_utf8_char(x);
 167         if (!c)
 168             return FALSE;
 169         x += c;
 170     }
 171     if (x != send)
 172         return FALSE;
 173
 174     return TRUE;
 175 }
 176
 177 /*
 178 =for apidoc Am|U8* s|utf8_to_uv|STRLEN curlen|STRLEN *retlen|U32 flags
 179
 180 Returns the character value of the first character in the string C<s>
 181 which is assumed to be in UTF8 encoding and no longer than C<curlen>;
 182 C<retlen> will be set to the length, in bytes, of that character.
 183
 184 If C<s> does not point to a well-formed UTF8 character, the behaviour
 185 is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
 186 it is assumed that the caller will raise a warning, and this function
 187 will silently just set C<retlen> to C<-1> and return zero.  If the
 188 C<flags> does not contain UTF8_CHECK_ONLY, warnings about
 189 malformations will be given, C<retlen> will be set to the expected
 190 length of the UTF-8 character in bytes, and zero will be returned.
 191
 192 The C<flags> can also contain various flags to allow deviations from
 193 the strict UTF-8 encoding (see F<utf8.h>).
 194
 195 =cut */
 196
 197 UV
 198 Perl_utf8_to_uv(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags)
 199 {
 200     UV uv = *s, ouv;
 201     STRLEN len = 1;
 202 #ifdef EBCDIC
 203     bool dowarn = 0;
 204 #else
 205     bool dowarn = ckWARN_d(WARN_UTF8);
 206 #endif
 207     STRLEN expectlen = 0;
 208     U32 warning = 0;
 209
 210 /* This list is a superset of the UTF8_ALLOW_XXX. */
 211
 212 #define UTF8_WARN_EMPTY                          1
 213 #define UTF8_WARN_CONTINUATION                   2
 214 #define UTF8_WARN_NON_CONTINUATION               3
 215 #define UTF8_WARN_FE_FF                          4
 216 #define UTF8_WARN_SHORT                          5
 217 #define UTF8_WARN_OVERFLOW                       6
 218 #define UTF8_WARN_SURROGATE                      7
 219 #define UTF8_WARN_BOM                            8
 220 #define UTF8_WARN_LONG                           9
 221 #define UTF8_WARN_FFFF                          10
 222
 223     if (curlen == 0 &&
 224         !(flags & UTF8_ALLOW_EMPTY)) {
 225         warning = UTF8_WARN_EMPTY;
 226         goto malformed;
 227     }
 228
 229     if (UTF8_IS_ASCII(uv)) {
 230         if (retlen)
 231             *retlen = 1;
 232         return *s;
 233     }
 234
 235     if (UTF8_IS_CONTINUATION(uv) &&
 236         !(flags & UTF8_ALLOW_CONTINUATION)) {
 237         warning = UTF8_WARN_CONTINUATION;
 238         goto malformed;
 239     }
 240
 241     if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
 242         !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
 243         warning = UTF8_WARN_NON_CONTINUATION;
 244         goto malformed;
 245     }
 246
 247     if ((uv == 0xfe || uv == 0xff) &&
 248         !(flags & UTF8_ALLOW_FE_FF)) {
 249         warning = UTF8_WARN_FE_FF;
 250         goto malformed;
 251     }
 252
 253     if      (!(uv & 0x20))      { len =  2; uv &= 0x1f; }
 254     else if (!(uv & 0x10))      { len =  3; uv &= 0x0f; }
 255     else if (!(uv & 0x08))      { len =  4; uv &= 0x07; }
 256     else if (!(uv & 0x04))      { len =  5; uv &= 0x03; }
 257     else if (!(uv & 0x02))      { len =  6; uv &= 0x01; }
 258     else if (!(uv & 0x01))      { len =  7; uv = 0; }
 259     else                        { len = 13; uv = 0; } /* whoa! */
 260
 261     if (retlen)
 262         *retlen = len;
 263
 264     expectlen = len;
 265
 266     if ((curlen < expectlen) &&
 267         !(flags & UTF8_ALLOW_SHORT)) {
 268         warning = UTF8_WARN_SHORT;
 269         goto malformed;
 270     }
 271
 272     len--;
 273     s++;
 274     ouv = uv;
 275
 276     while (len--) {
 277         if (!UTF8_IS_CONTINUATION(*s) &&
 278             !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
 279             s--;
 280             warning = UTF8_WARN_NON_CONTINUATION;
 281             goto malformed;
 282         }
 283         else
 284             uv = UTF8_ACCUMULATE(uv, *s);
 285         if (!(uv > ouv)) {
 286             /* These cannot be allowed. */
 287             if (uv == ouv) {
 288                 if (!(flags & UTF8_ALLOW_LONG)) {
 289                     warning = UTF8_WARN_LONG;
 290                     goto malformed;
 291                 }
 292             }
 293             else { /* uv < ouv */
 294                 /* This cannot be allowed. */
 295                 warning = UTF8_WARN_OVERFLOW;
 296                 goto malformed;
 297             }
 298         }
 299         s++;
 300         ouv = uv;
 301     }
 302
 303     if (UNICODE_IS_SURROGATE(uv) &&
 304         !(flags & UTF8_ALLOW_SURROGATE)) {
 305         warning = UTF8_WARN_SURROGATE;
 306         goto malformed;
 307     } else if (UNICODE_IS_BYTE_ORDER_MARK(uv) &&
 308                !(flags & UTF8_ALLOW_BOM)) {
 309         warning = UTF8_WARN_BOM;
 310         goto malformed;
 311     } else if ((expectlen > UNISKIP(uv)) &&
 312                !(flags & UTF8_ALLOW_LONG)) {
 313         warning = UTF8_WARN_LONG;
 314         goto malformed;
 315     } else if (UNICODE_IS_ILLEGAL(uv) &&
 316                !(flags & UTF8_ALLOW_FFFF)) {
 317         warning = UTF8_WARN_FFFF;
 318         goto malformed;
 319     }
 320
 321     return uv;
 322
 323 malformed:
 324
 325     if (flags & UTF8_CHECK_ONLY) {
 326         if (retlen)
 327             *retlen = -1;
 328         return 0;
 329     }
 330
 331     if (dowarn) {
 332         SV* sv = sv_2mortal(newSVpv("Malformed UTF-8 character ", 0));
 333
 334         switch (warning) {
 335         case 0: /* Intentionally empty. */ break;
 336         case UTF8_WARN_EMPTY:
 337             Perl_sv_catpvf(aTHX_ sv, "(empty string)");
 338             break;
 339         case UTF8_WARN_CONTINUATION:
 340             Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf")", uv);
 341             break;
 342         case UTF8_WARN_NON_CONTINUATION:
 343             Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf" after start byte 0x%02"UVxf")",
 344                            (UV)s[1], uv);
 345             break;
 346         case UTF8_WARN_FE_FF:
 347             Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
 348             break;
 349         case UTF8_WARN_SHORT:
 350             Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d)",
 351                            curlen, curlen == 1 ? "" : "s", expectlen);
 352             break;
 353         case UTF8_WARN_OVERFLOW:
 354             Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x)",
 355                            ouv, *s);
 356             break;
 357         case UTF8_WARN_SURROGATE:
 358             Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
 359             break;
 360         case UTF8_WARN_BOM:
 361             Perl_sv_catpvf(aTHX_ sv, "(byte order mark 0x%04"UVxf")", uv);
 362             break;
 363         case UTF8_WARN_LONG:
 364             Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d)",
 365                            expectlen, expectlen == 1 ? "": "s", UNISKIP(uv));
 366             break;
 367         case UTF8_WARN_FFFF:
 368             Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
 369             break;
 370         default:
 371             Perl_sv_catpvf(aTHX_ sv, "(unknown reason)");
 372             break;
 373         }
 374
 375         if (warning) {
 376             char *s = SvPVX(sv);
 377
 378             if (PL_op)
 379                 Perl_warner(aTHX_ WARN_UTF8,
 380                             "%s in %s", s,  PL_op_desc[PL_op->op_type]);
 381             else
 382                 Perl_warner(aTHX_ WARN_UTF8, "%s", s);
 383         }
 384     }
 385
 386     if (retlen)
 387         *retlen = expectlen ? expectlen : len;
 388
 389     return 0;
 390 }
 391
 392 /*
 393 =for apidoc Am|U8* s|utf8_to_uv_simple|STRLEN *retlen
 394
 395 Returns the character value of the first character in the string C<s>
 396 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
 397 length, in bytes, of that character.
 398
 399 If C<s> does not point to a well-formed UTF8 character, zero is
 400 returned and retlen is set, if possible, to -1.
 401
 402 =cut
 403 */
 404
 405 UV
 406 Perl_utf8_to_uv_simple(pTHX_ U8* s, STRLEN* retlen)
 407 {
 408     return Perl_utf8_to_uv(aTHX_ s, UTF8_MAXLEN, retlen, 0);
 409 }
 410
 411 /*
 412 =for apidoc Am|STRLEN|utf8_length|U8* s|U8 *e
 413
 414 Return the length of the UTF-8 char encoded string C<s> in characters.
 415 Stops at C<e> (inclusive).  If C<e E<lt> s> or if the scan would end
 416 up past C<e>, croaks.
 417
 418 =cut
 419 */
 420
 421 STRLEN
 422 Perl_utf8_length(pTHX_ U8* s, U8* e)
 423 {
 424     STRLEN len = 0;
 425
 426     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
 427      * the bitops (especially ~) can create illegal UTF-8.
 428      * In other words: in Perl UTF-8 is not just for Unicode. */
 429
 430     if (e < s)
 431         Perl_croak(aTHX_ "panic: utf8_length: unexpected end");
 432     while (s < e) {
 433         U8 t = UTF8SKIP(s);
 434
 435         if (e - s < t)
 436             Perl_croak(aTHX_ "panic: utf8_length: unaligned end");
 437         s += t;
 438         len++;
 439     }
 440
 441     return len;
 442 }
 443
 444 /*
 445 =for apidoc Am|IV|utf8_distance|U8 *a|U8 *b
 446
 447 Returns the number of UTF8 characters between the UTF-8 pointers C<a>
 448 and C<b>.
 449
 450 WARNING: use only if you *know* that the pointers point inside the
 451 same UTF-8 buffer.
 452
 453 =cut */
 454
 455 IV
 456 Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
 457 {
 458     IV off = 0;
 459
 460     /* Note: cannot use UTF8_IS_...() too eagerly here since  e.g.
 461      * the bitops (especially ~) can create illegal UTF-8.
 462      * In other words: in Perl UTF-8 is not just for Unicode. */
 463
 464     if (a < b) {
 465         while (a < b) {
 466             U8 c = UTF8SKIP(a);
 467
 468             if (b - a < c)
 469                 Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
 470             a += c;
 471             off--;
 472         }
 473     }
 474     else {
 475         while (b < a) {
 476             U8 c = UTF8SKIP(b);
 477
 478             if (a - b < c)
 479                 Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
 480             b += c;
 481             off++;
 482         }
 483     }
 484
 485     return off;
 486 }
 487
 488 /*
 489 =for apidoc Am|U8*|utf8_hop|U8 *s|I32 off
 490
 491 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
 492 forward or backward.
 493
 494 WARNING: do not use the following unless you *know* C<off> is within
 495 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
 496 on the first byte of character or just after the last byte of a character.
 497
 498 =cut */
 499
 500 U8 *
 501 Perl_utf8_hop(pTHX_ U8 *s, I32 off)
 502 {
 503     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
 504      * the bitops (especially ~) can create illegal UTF-8.
 505      * In other words: in Perl UTF-8 is not just for Unicode. */
 506
 507     if (off >= 0) {
 508         while (off--)
 509             s += UTF8SKIP(s);
 510     }
 511     else {
 512         while (off++) {
 513             s--;
 514             while (UTF8_IS_CONTINUATION(*s))
 515                 s--;
 516         }
 517     }
 518     return s;
 519 }
 520
 521 /*
 522 =for apidoc Am|U8 *|utf8_to_bytes|U8 *s|STRLEN *len
 523
 524 Converts a string C<s> of length C<len> from UTF8 into byte encoding.
 525 Unlike C<bytes_to_utf8>, this over-writes the original string, and
 526 updates len to contain the new length.
 527 Returns zero on failure, setting C<len> to -1.
 528
 529 =cut
 530 */
 531
 532 U8 *
 533 Perl_utf8_to_bytes(pTHX_ U8* s, STRLEN *len)
 534 {
 535     U8 *send;
 536     U8 *d;
 537     U8 *save = s;
 538
 539     /* ensure valid UTF8 and chars < 256 before updating string */
 540     for (send = s + *len; s < send; ) {
 541         U8 c = *s++;
 542
 543         if (c >= 0x80 &&
 544             ((s >= send) ||
 545              ((*s++ & 0xc0) != 0x80) || ((c & 0xfe) != 0xc2))) {
 546             *len = -1;
 547             return 0;
 548         }
 549     }
 550
 551     d = s = save;
 552     while (s < send) {
 553         STRLEN ulen;
 554         *d++ = (U8)utf8_to_uv_simple(s, &ulen);
 555         s += ulen;
 556     }
 557     *d = '\0';
 558     *len = d - save;
 559     return save;
 560 }
 561
 562 /*
 563 =for apidoc Am|U8 *|bytes_to_utf8|U8 *s|STRLEN *len
 564
 565 Converts a string C<s> of length C<len> from ASCII into UTF8 encoding.
 566 Returns a pointer to the newly-created string, and sets C<len> to
 567 reflect the new length.
 568
 569 =cut
 570 */
 571
 572 U8*
 573 Perl_bytes_to_utf8(pTHX_ U8* s, STRLEN *len)
 574 {
 575     U8 *send;
 576     U8 *d;
 577     U8 *dst;
 578     send = s + (*len);
 579
 580     Newz(801, d, (*len) * 2 + 1, U8);
 581     dst = d;
 582
 583     while (s < send) {
 584         if (*s < 0x80)
 585             *d++ = *s++;
 586         else {
 587             UV uv = *s++;
 588             *d++ = (( uv >>  6)         | 0xc0);
 589             *d++ = (( uv        & 0x3f) | 0x80);
 590         }
 591     }
 592     *d = '\0';
 593     *len = d-dst;
 594     return dst;
 595 }
 596
 597 /*
 598  * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
 599  *
 600  * Destination must be pre-extended to 3/2 source.  Do not use in-place.
 601  * We optimize for native, for obvious reasons. */
 602
 603 U8*
 604 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 605 {
 606     U8* pend;
 607     U8* dstart = d;
 608
 609     if (bytelen & 1)
 610         Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen");
 611
 612     pend = p + bytelen;
 613
 614     while (p < pend) {
 615         UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
 616         p += 2;
 617         if (uv < 0x80) {
 618             *d++ = uv;
 619             continue;
 620         }
 621         if (uv < 0x800) {
 622             *d++ = (( uv >>  6)         | 0xc0);
 623             *d++ = (( uv        & 0x3f) | 0x80);
 624             continue;
 625         }
 626         if (uv >= 0xd800 && uv < 0xdbff) {      /* surrogates */
 627             UV low = *p++;
 628             if (low < 0xdc00 || low >= 0xdfff)
 629                 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
 630             uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
 631         }
 632         if (uv < 0x10000) {
 633             *d++ = (( uv >> 12)         | 0xe0);
 634             *d++ = (((uv >>  6) & 0x3f) | 0x80);
 635             *d++ = (( uv        & 0x3f) | 0x80);
 636             continue;
 637         }
 638         else {
 639             *d++ = (( uv >> 18)         | 0xf0);
 640             *d++ = (((uv >> 12) & 0x3f) | 0x80);
 641             *d++ = (((uv >>  6) & 0x3f) | 0x80);
 642             *d++ = (( uv        & 0x3f) | 0x80);
 643             continue;
 644         }
 645     }
 646     *newlen = d - dstart;
 647     return d;
 648 }
 649
 650 /* Note: this one is slightly destructive of the source. */
 651
 652 U8*
 653 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 654 {
 655     U8* s = (U8*)p;
 656     U8* send = s + bytelen;
 657     while (s < send) {
 658         U8 tmp = s[0];
 659         s[0] = s[1];
 660         s[1] = tmp;
 661         s += 2;
 662     }
 663     return utf16_to_utf8(p, d, bytelen, newlen);
 664 }
 665
 666 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
 667
 668 bool
 669 Perl_is_uni_alnum(pTHX_ U32 c)
 670 {
 671     U8 tmpbuf[UTF8_MAXLEN+1];
 672     uv_to_utf8(tmpbuf, (UV)c);
 673     return is_utf8_alnum(tmpbuf);
 674 }
 675
 676 bool
 677 Perl_is_uni_alnumc(pTHX_ U32 c)
 678 {
 679     U8 tmpbuf[UTF8_MAXLEN+1];
 680     uv_to_utf8(tmpbuf, (UV)c);
 681     return is_utf8_alnumc(tmpbuf);
 682 }
 683
 684 bool
 685 Perl_is_uni_idfirst(pTHX_ U32 c)
 686 {
 687     U8 tmpbuf[UTF8_MAXLEN+1];
 688     uv_to_utf8(tmpbuf, (UV)c);
 689     return is_utf8_idfirst(tmpbuf);
 690 }
 691
 692 bool
 693 Perl_is_uni_alpha(pTHX_ U32 c)
 694 {
 695     U8 tmpbuf[UTF8_MAXLEN+1];
 696     uv_to_utf8(tmpbuf, (UV)c);
 697     return is_utf8_alpha(tmpbuf);
 698 }
 699
 700 bool
 701 Perl_is_uni_ascii(pTHX_ U32 c)
 702 {
 703     U8 tmpbuf[UTF8_MAXLEN+1];
 704     uv_to_utf8(tmpbuf, (UV)c);
 705     return is_utf8_ascii(tmpbuf);
 706 }
 707
 708 bool
 709 Perl_is_uni_space(pTHX_ U32 c)
 710 {
 711     U8 tmpbuf[UTF8_MAXLEN+1];
 712     uv_to_utf8(tmpbuf, (UV)c);
 713     return is_utf8_space(tmpbuf);
 714 }
 715
 716 bool
 717 Perl_is_uni_digit(pTHX_ U32 c)
 718 {
 719     U8 tmpbuf[UTF8_MAXLEN+1];
 720     uv_to_utf8(tmpbuf, (UV)c);
 721     return is_utf8_digit(tmpbuf);
 722 }
 723
 724 bool
 725 Perl_is_uni_upper(pTHX_ U32 c)
 726 {
 727     U8 tmpbuf[UTF8_MAXLEN+1];
 728     uv_to_utf8(tmpbuf, (UV)c);
 729     return is_utf8_upper(tmpbuf);
 730 }
 731
 732 bool
 733 Perl_is_uni_lower(pTHX_ U32 c)
 734 {
 735     U8 tmpbuf[UTF8_MAXLEN+1];
 736     uv_to_utf8(tmpbuf, (UV)c);
 737     return is_utf8_lower(tmpbuf);
 738 }
 739
 740 bool
 741 Perl_is_uni_cntrl(pTHX_ U32 c)
 742 {
 743     U8 tmpbuf[UTF8_MAXLEN+1];
 744     uv_to_utf8(tmpbuf, (UV)c);
 745     return is_utf8_cntrl(tmpbuf);
 746 }
 747
 748 bool
 749 Perl_is_uni_graph(pTHX_ U32 c)
 750 {
 751     U8 tmpbuf[UTF8_MAXLEN+1];
 752     uv_to_utf8(tmpbuf, (UV)c);
 753     return is_utf8_graph(tmpbuf);
 754 }
 755
 756 bool
 757 Perl_is_uni_print(pTHX_ U32 c)
 758 {
 759     U8 tmpbuf[UTF8_MAXLEN+1];
 760     uv_to_utf8(tmpbuf, (UV)c);
 761     return is_utf8_print(tmpbuf);
 762 }
 763
 764 bool
 765 Perl_is_uni_punct(pTHX_ U32 c)
 766 {
 767     U8 tmpbuf[UTF8_MAXLEN+1];
 768     uv_to_utf8(tmpbuf, (UV)c);
 769     return is_utf8_punct(tmpbuf);
 770 }
 771
 772 bool
 773 Perl_is_uni_xdigit(pTHX_ U32 c)
 774 {
 775     U8 tmpbuf[UTF8_MAXLEN+1];
 776     uv_to_utf8(tmpbuf, (UV)c);
 777     return is_utf8_xdigit(tmpbuf);
 778 }
 779
 780 U32
 781 Perl_to_uni_upper(pTHX_ U32 c)
 782 {
 783     U8 tmpbuf[UTF8_MAXLEN+1];
 784     uv_to_utf8(tmpbuf, (UV)c);
 785     return to_utf8_upper(tmpbuf);
 786 }
 787
 788 U32
 789 Perl_to_uni_title(pTHX_ U32 c)
 790 {
 791     U8 tmpbuf[UTF8_MAXLEN+1];
 792     uv_to_utf8(tmpbuf, (UV)c);
 793     return to_utf8_title(tmpbuf);
 794 }
 795
 796 U32
 797 Perl_to_uni_lower(pTHX_ U32 c)
 798 {
 799     U8 tmpbuf[UTF8_MAXLEN+1];
 800     uv_to_utf8(tmpbuf, (UV)c);
 801     return to_utf8_lower(tmpbuf);
 802 }
 803
 804 /* for now these all assume no locale info available for Unicode > 255 */
 805
 806 bool
 807 Perl_is_uni_alnum_lc(pTHX_ U32 c)
 808 {
 809     return is_uni_alnum(c);     /* XXX no locale support yet */
 810 }
 811
 812 bool
 813 Perl_is_uni_alnumc_lc(pTHX_ U32 c)
 814 {
 815     return is_uni_alnumc(c);    /* XXX no locale support yet */
 816 }
 817
 818 bool
 819 Perl_is_uni_idfirst_lc(pTHX_ U32 c)
 820 {
 821     return is_uni_idfirst(c);   /* XXX no locale support yet */
 822 }
 823
 824 bool
 825 Perl_is_uni_alpha_lc(pTHX_ U32 c)
 826 {
 827     return is_uni_alpha(c);     /* XXX no locale support yet */
 828 }
 829
 830 bool
 831 Perl_is_uni_ascii_lc(pTHX_ U32 c)
 832 {
 833     return is_uni_ascii(c);     /* XXX no locale support yet */
 834 }
 835
 836 bool
 837 Perl_is_uni_space_lc(pTHX_ U32 c)
 838 {
 839     return is_uni_space(c);     /* XXX no locale support yet */
 840 }
 841
 842 bool
 843 Perl_is_uni_digit_lc(pTHX_ U32 c)
 844 {
 845     return is_uni_digit(c);     /* XXX no locale support yet */
 846 }
 847
 848 bool
 849 Perl_is_uni_upper_lc(pTHX_ U32 c)
 850 {
 851     return is_uni_upper(c);     /* XXX no locale support yet */
 852 }
 853
 854 bool
 855 Perl_is_uni_lower_lc(pTHX_ U32 c)
 856 {
 857     return is_uni_lower(c);     /* XXX no locale support yet */
 858 }
 859
 860 bool
 861 Perl_is_uni_cntrl_lc(pTHX_ U32 c)
 862 {
 863     return is_uni_cntrl(c);     /* XXX no locale support yet */
 864 }
 865
 866 bool
 867 Perl_is_uni_graph_lc(pTHX_ U32 c)
 868 {
 869     return is_uni_graph(c);     /* XXX no locale support yet */
 870 }
 871
 872 bool
 873 Perl_is_uni_print_lc(pTHX_ U32 c)
 874 {
 875     return is_uni_print(c);     /* XXX no locale support yet */
 876 }
 877
 878 bool
 879 Perl_is_uni_punct_lc(pTHX_ U32 c)
 880 {
 881     return is_uni_punct(c);     /* XXX no locale support yet */
 882 }
 883
 884 bool
 885 Perl_is_uni_xdigit_lc(pTHX_ U32 c)
 886 {
 887     return is_uni_xdigit(c);    /* XXX no locale support yet */
 888 }
 889
 890 U32
 891 Perl_to_uni_upper_lc(pTHX_ U32 c)
 892 {
 893     return to_uni_upper(c);     /* XXX no locale support yet */
 894 }
 895
 896 U32
 897 Perl_to_uni_title_lc(pTHX_ U32 c)
 898 {
 899     return to_uni_title(c);     /* XXX no locale support yet */
 900 }
 901
 902 U32
 903 Perl_to_uni_lower_lc(pTHX_ U32 c)
 904 {
 905     return to_uni_lower(c);     /* XXX no locale support yet */
 906 }
 907
 908 bool
 909 Perl_is_utf8_alnum(pTHX_ U8 *p)
 910 {
 911     if (!is_utf8_char(p))
 912         return FALSE;
 913     if (!PL_utf8_alnum)
 914         /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
 915          * descendant of isalnum(3), in other words, it doesn't
 916          * contain the '_'. --jhi */
 917         PL_utf8_alnum = swash_init("utf8", "IsWord", &PL_sv_undef, 0, 0);
 918     return swash_fetch(PL_utf8_alnum, p);
 919 /*    return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */
 920 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
 921     if (!PL_utf8_alnum)
 922         PL_utf8_alnum = swash_init("utf8", "",
 923             sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
 924     return swash_fetch(PL_utf8_alnum, p);
 925 #endif
 926 }
 927
 928 bool
 929 Perl_is_utf8_alnumc(pTHX_ U8 *p)
 930 {
 931     if (!is_utf8_char(p))
 932         return FALSE;
 933     if (!PL_utf8_alnum)
 934         PL_utf8_alnum = swash_init("utf8", "IsAlnumC", &PL_sv_undef, 0, 0);
 935     return swash_fetch(PL_utf8_alnum, p);
 936 /*    return is_utf8_alpha(p) || is_utf8_digit(p); */
 937 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
 938     if (!PL_utf8_alnum)
 939         PL_utf8_alnum = swash_init("utf8", "",
 940             sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
 941     return swash_fetch(PL_utf8_alnum, p);
 942 #endif
 943 }
 944
 945 bool
 946 Perl_is_utf8_idfirst(pTHX_ U8 *p)
 947 {
 948     return *p == '_' || is_utf8_alpha(p);
 949 }
 950
 951 bool
 952 Perl_is_utf8_alpha(pTHX_ U8 *p)
 953 {
 954     if (!is_utf8_char(p))
 955         return FALSE;
 956     if (!PL_utf8_alpha)
 957         PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0);
 958     return swash_fetch(PL_utf8_alpha, p);
 959 }
 960
 961 bool
 962 Perl_is_utf8_ascii(pTHX_ U8 *p)
 963 {
 964     if (!is_utf8_char(p))
 965         return FALSE;
 966     if (!PL_utf8_ascii)
 967         PL_utf8_ascii = swash_init("utf8", "IsAscii", &PL_sv_undef, 0, 0);
 968     return swash_fetch(PL_utf8_ascii, p);
 969 }
 970
 971 bool
 972 Perl_is_utf8_space(pTHX_ U8 *p)
 973 {
 974     if (!is_utf8_char(p))
 975         return FALSE;
 976     if (!PL_utf8_space)
 977         PL_utf8_space = swash_init("utf8", "IsSpacePerl", &PL_sv_undef, 0, 0);
 978     return swash_fetch(PL_utf8_space, p);
 979 }
 980
 981 bool
 982 Perl_is_utf8_digit(pTHX_ U8 *p)
 983 {
 984     if (!is_utf8_char(p))
 985         return FALSE;
 986     if (!PL_utf8_digit)
 987         PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0);
 988     return swash_fetch(PL_utf8_digit, p);
 989 }
 990
 991 bool
 992 Perl_is_utf8_upper(pTHX_ U8 *p)
 993 {
 994     if (!is_utf8_char(p))
 995         return FALSE;
 996     if (!PL_utf8_upper)
 997         PL_utf8_upper = swash_init("utf8", "IsUpper", &PL_sv_undef, 0, 0);
 998     return swash_fetch(PL_utf8_upper, p);
 999 }
1000
1001 bool
1002 Perl_is_utf8_lower(pTHX_ U8 *p)
1003 {
1004     if (!is_utf8_char(p))
1005         return FALSE;
1006     if (!PL_utf8_lower)
1007         PL_utf8_lower = swash_init("utf8", "IsLower", &PL_sv_undef, 0, 0);
1008     return swash_fetch(PL_utf8_lower, p);
1009 }
1010
1011 bool
1012 Perl_is_utf8_cntrl(pTHX_ U8 *p)
1013 {
1014     if (!is_utf8_char(p))
1015         return FALSE;
1016     if (!PL_utf8_cntrl)
1017         PL_utf8_cntrl = swash_init("utf8", "IsCntrl", &PL_sv_undef, 0, 0);
1018     return swash_fetch(PL_utf8_cntrl, p);
1019 }
1020
1021 bool
1022 Perl_is_utf8_graph(pTHX_ U8 *p)
1023 {
1024     if (!is_utf8_char(p))
1025         return FALSE;
1026     if (!PL_utf8_graph)
1027         PL_utf8_graph = swash_init("utf8", "IsGraph", &PL_sv_undef, 0, 0);
1028     return swash_fetch(PL_utf8_graph, p);
1029 }
1030
1031 bool
1032 Perl_is_utf8_print(pTHX_ U8 *p)
1033 {
1034     if (!is_utf8_char(p))
1035         return FALSE;
1036     if (!PL_utf8_print)
1037         PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0);
1038     return swash_fetch(PL_utf8_print, p);
1039 }
1040
1041 bool
1042 Perl_is_utf8_punct(pTHX_ U8 *p)
1043 {
1044     if (!is_utf8_char(p))
1045         return FALSE;
1046     if (!PL_utf8_punct)
1047         PL_utf8_punct = swash_init("utf8", "IsPunct", &PL_sv_undef, 0, 0);
1048     return swash_fetch(PL_utf8_punct, p);
1049 }
1050
1051 bool
1052 Perl_is_utf8_xdigit(pTHX_ U8 *p)
1053 {
1054     if (!is_utf8_char(p))
1055         return FALSE;
1056     if (!PL_utf8_xdigit)
1057         PL_utf8_xdigit = swash_init("utf8", "IsXDigit", &PL_sv_undef, 0, 0);
1058     return swash_fetch(PL_utf8_xdigit, p);
1059 }
1060
1061 bool
1062 Perl_is_utf8_mark(pTHX_ U8 *p)
1063 {
1064     if (!is_utf8_char(p))
1065         return FALSE;
1066     if (!PL_utf8_mark)
1067         PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0);
1068     return swash_fetch(PL_utf8_mark, p);
1069 }
1070
1071 UV
1072 Perl_to_utf8_upper(pTHX_ U8 *p)
1073 {
1074     UV uv;
1075
1076     if (!PL_utf8_toupper)
1077         PL_utf8_toupper = swash_init("utf8", "ToUpper", &PL_sv_undef, 4, 0);
1078     uv = swash_fetch(PL_utf8_toupper, p);
1079     return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0);
1080 }
1081
1082 UV
1083 Perl_to_utf8_title(pTHX_ U8 *p)
1084 {
1085     UV uv;
1086
1087     if (!PL_utf8_totitle)
1088         PL_utf8_totitle = swash_init("utf8", "ToTitle", &PL_sv_undef, 4, 0);
1089     uv = swash_fetch(PL_utf8_totitle, p);
1090     return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0);
1091 }
1092
1093 UV
1094 Perl_to_utf8_lower(pTHX_ U8 *p)
1095 {
1096     UV uv;
1097
1098     if (!PL_utf8_tolower)
1099         PL_utf8_tolower = swash_init("utf8", "ToLower", &PL_sv_undef, 4, 0);
1100     uv = swash_fetch(PL_utf8_tolower, p);
1101     return uv ? uv : utf8_to_uv(p,UTF8_MAXLEN,0,0);
1102 }
1103
1104 /* a "swash" is a swatch hash */
1105
1106 SV*
1107 Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
1108 {
1109     SV* retval;
1110     SV* tokenbufsv = sv_2mortal(NEWSV(0,0));
1111     dSP;
1112
1113     if (!gv_stashpv(pkg, 0)) {  /* demand load utf8 */
1114         ENTER;
1115         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpv(pkg,0), Nullsv);
1116         LEAVE;
1117     }
1118     SPAGAIN;
1119     PUSHSTACKi(PERLSI_MAGIC);
1120     PUSHMARK(SP);
1121     EXTEND(SP,5);
1122     PUSHs(sv_2mortal(newSVpvn(pkg, strlen(pkg))));
1123     PUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
1124     PUSHs(listsv);
1125     PUSHs(sv_2mortal(newSViv(minbits)));
1126     PUSHs(sv_2mortal(newSViv(none)));
1127     PUTBACK;
1128     ENTER;
1129     SAVEI32(PL_hints);
1130     PL_hints = 0;
1131     save_re_context();
1132     if (PL_curcop == &PL_compiling)
1133         /* XXX ought to be handled by lex_start */
1134         sv_setpv(tokenbufsv, PL_tokenbuf);
1135     if (call_method("SWASHNEW", G_SCALAR))
1136         retval = newSVsv(*PL_stack_sp--);
1137     else
1138         retval = &PL_sv_undef;
1139     LEAVE;
1140     POPSTACK;
1141     if (PL_curcop == &PL_compiling) {
1142         STRLEN len;
1143         char* pv = SvPV(tokenbufsv, len);
1144
1145         Copy(pv, PL_tokenbuf, len+1, char);
1146         PL_curcop->op_private = PL_hints;
1147     }
1148     if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV)
1149         Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
1150     return retval;
1151 }
1152
1153 UV
1154 Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr)
1155 {
1156     HV* hv = (HV*)SvRV(sv);
1157     U32 klen = UTF8SKIP(ptr) - 1;
1158     U32 off = ptr[klen] & 127;  /* NB: 64 bit always 0 when len > 1 */
1159     STRLEN slen;
1160     STRLEN needents = (klen ? 64 : 128);
1161     U8 *tmps;
1162     U32 bit;
1163     SV *retval;
1164
1165     /*
1166      * This single-entry cache saves about 1/3 of the utf8 overhead in test
1167      * suite.  (That is, only 7-8% overall over just a hash cache.  Still,
1168      * it's nothing to sniff at.)  Pity we usually come through at least
1169      * two function calls to get here...
1170      *
1171      * NB: this code assumes that swatches are never modified, once generated!
1172      */
1173
1174     if (hv == PL_last_swash_hv &&
1175         klen == PL_last_swash_klen &&
1176         (!klen || memEQ((char *)ptr,(char *)PL_last_swash_key,klen)) )
1177     {
1178         tmps = PL_last_swash_tmps;
1179         slen = PL_last_swash_slen;
1180     }
1181     else {
1182         /* Try our second-level swatch cache, kept in a hash. */
1183         SV** svp = hv_fetch(hv, (char*)ptr, klen, FALSE);
1184
1185         /* If not cached, generate it via utf8::SWASHGET */
1186         if (!svp || !SvPOK(*svp) || !(tmps = (U8*)SvPV(*svp, slen))) {
1187             dSP;
1188             ENTER;
1189             SAVETMPS;
1190             save_re_context();
1191             PUSHSTACKi(PERLSI_MAGIC);
1192             PUSHMARK(SP);
1193             EXTEND(SP,3);
1194             PUSHs((SV*)sv);
1195             PUSHs(sv_2mortal(newSViv(utf8_to_uv(ptr, UTF8_MAXLEN, 0, 0) & ~(needents - 1))));
1196             PUSHs(sv_2mortal(newSViv(needents)));
1197             PUTBACK;
1198             if (call_method("SWASHGET", G_SCALAR))
1199                 retval = newSVsv(*PL_stack_sp--);
1200             else
1201                 retval = &PL_sv_undef;
1202             POPSTACK;
1203             FREETMPS;
1204             LEAVE;
1205             if (PL_curcop == &PL_compiling)
1206                 PL_curcop->op_private = PL_hints;
1207
1208             svp = hv_store(hv, (char*)ptr, klen, retval, 0);
1209
1210             if (!svp || !(tmps = (U8*)SvPV(*svp, slen)) || slen < 8)
1211                 Perl_croak(aTHX_ "SWASHGET didn't return result of proper length");
1212         }
1213
1214         PL_last_swash_hv = hv;
1215         PL_last_swash_klen = klen;
1216         PL_last_swash_tmps = tmps;
1217         PL_last_swash_slen = slen;
1218         if (klen)
1219             Copy(ptr, PL_last_swash_key, klen, U8);
1220     }
1221
1222     switch ((int)((slen << 3) / needents)) {
1223     case 1:
1224         bit = 1 << (off & 7);
1225         off >>= 3;
1226         return (tmps[off] & bit) != 0;
1227     case 8:
1228         return tmps[off];
1229     case 16:
1230         off <<= 1;
1231         return (tmps[off] << 8) + tmps[off + 1] ;
1232     case 32:
1233         off <<= 2;
1234         return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1235     }
1236     Perl_croak(aTHX_ "panic: swash_fetch");
1237     return 0;
1238 }