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