utf8.c

   1 /*    utf8.c
   2  *
   3  *    Copyright (c) 1998-2000, 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)
  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 < 0x1000000000LL)
  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 int
 108 Perl_is_utf8_char(pTHX_ U8 *s)
 109 {
 110     U8 u = *s;
 111     int slen, len;
 112
 113     if (!(u & 0x80))
 114         return 1;
 115
 116     if (!(u & 0x40))
 117         return 0;
 118
 119     if      (!(u & 0x20))       { len = 2; }
 120     else if (!(u & 0x10))       { len = 3; }
 121     else if (!(u & 0x08))       { len = 4; }
 122     else if (!(u & 0x04))       { len = 5; }
 123     else if (!(u & 0x02))       { len = 6; }
 124     else if (!(u & 0x01))       { len = 7; }
 125     else                        { len = 13; } /* whoa! */
 126
 127     slen = len - 1;
 128     s++;
 129     while (slen--) {
 130         if ((*s & 0xc0) != 0x80)
 131             return 0;
 132         s++;
 133     }
 134     return len;
 135 }
 136
 137 /*
 138 =for apidoc Am|bool_utf8_string|U8 *s|STRLEN len
 139
 140 Returns true if first C<len> bytes of the given string form valid a UTF8
 141 string, false otherwise.
 142
 143 =cut
 144 */
 145
 146 bool
 147 Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len)
 148 {
 149     U8* x=s;
 150     U8* send=s+len;
 151     int c;
 152     while (x < send) {
 153         c = is_utf8_char(x);
 154         x += c;
 155         if (!c || x > send)
 156             return 0;
 157     }
 158     return 1;
 159 }
 160
 161 UV
 162 Perl_utf8_to_uv(pTHX_ U8* s, I32* retlen)
 163 {
 164     UV uv = *s;
 165     int len;
 166     if (!(uv & 0x80)) {
 167         if (retlen)
 168             *retlen = 1;
 169         return *s;
 170     }
 171     if (!(uv & 0x40)) {
 172         dTHR;
 173         if (ckWARN_d(WARN_UTF8))
 174             Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
 175         if (retlen)
 176             *retlen = 1;
 177         return *s;
 178     }
 179
 180     if      (!(uv & 0x20))      { len = 2; uv &= 0x1f; }
 181     else if (!(uv & 0x10))      { len = 3; uv &= 0x0f; }
 182     else if (!(uv & 0x08))      { len = 4; uv &= 0x07; }
 183     else if (!(uv & 0x04))      { len = 5; uv &= 0x03; }
 184     else if (!(uv & 0x02))      { len = 6; uv &= 0x01; }
 185     else if (!(uv & 0x01))      { len = 7;  uv = 0; }
 186     else                        { len = 13; uv = 0; } /* whoa! */
 187
 188     if (retlen)
 189         *retlen = len;
 190     --len;
 191     s++;
 192     while (len--) {
 193         if ((*s & 0xc0) != 0x80) {
 194             dTHR;
 195             if (ckWARN_d(WARN_UTF8))
 196                 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
 197             if (retlen)
 198                 *retlen -= len + 1;
 199             return 0xfffd;
 200         }
 201         else
 202             uv = (uv << 6) | (*s++ & 0x3f);
 203     }
 204     return uv;
 205 }
 206
 207 /* utf8_distance(a,b) returns the number of UTF8 characters between
 208    the pointers a and b                                                 */
 209
 210 I32
 211 Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
 212 {
 213     I32 off = 0;
 214     if (a < b) {
 215         while (a < b) {
 216             a += UTF8SKIP(a);
 217             off--;
 218         }
 219     }
 220     else {
 221         while (b < a) {
 222             b += UTF8SKIP(b);
 223             off++;
 224         }
 225     }
 226     return off;
 227 }
 228
 229 /* WARNING: do not use the following unless you *know* off is within bounds */
 230
 231 U8 *
 232 Perl_utf8_hop(pTHX_ U8 *s, I32 off)
 233 {
 234     if (off >= 0) {
 235         while (off--)
 236             s += UTF8SKIP(s);
 237     }
 238     else {
 239         while (off++) {
 240             s--;
 241             if (*s & 0x80) {
 242                 while ((*s & 0xc0) == 0x80)
 243                     s--;
 244             }
 245         }
 246     }
 247     return s;
 248 }
 249
 250 /*
 251 =for apidoc Am|U8 *|utf8_to_bytes|U8 *s|STRLEN *len
 252
 253 Converts a string C<s> of length C<len> from UTF8 into byte encoding.
 254 Unlike C<bytes_to_utf8>, this over-writes the original string, and
 255 updates len to contain the new length.
 256 Returns zero on failure leaving the string and len unchanged
 257
 258 =cut
 259 */
 260
 261 U8 *
 262 Perl_utf8_to_bytes(pTHX_ U8* s, STRLEN *len)
 263 {
 264     dTHR;
 265     U8 *send;
 266     U8 *d;
 267     U8 *save;
 268
 269     send = s + *len;
 270     d = save = s;
 271
 272     /* ensure valid UTF8 and chars < 256 before updating string */
 273     while (s < send) {
 274         U8 c = *s++;
 275         if (c >= 0x80 &&
 276             ( (s >= send) || ((*s++ & 0xc0) != 0x80) || ((c & 0xfe) != 0xc2)))
 277             return 0;
 278     }
 279     s = save;
 280     while (s < send) {
 281         if (*s < 0x80)
 282             *d++ = *s++;
 283         else {
 284             I32 ulen;
 285             *d++ = (U8)utf8_to_uv(s, &ulen);
 286             s += ulen;
 287         }
 288     }
 289     *d = '\0';
 290     *len = d - save;
 291     return save;
 292 }
 293
 294 /*
 295 =for apidoc Am|U8 *|bytes_to_utf8|U8 *s|STRLEN *len
 296
 297 Converts a string C<s> of length C<len> from ASCII into UTF8 encoding.
 298 Returns a pointer to the newly-created string, and sets C<len> to
 299 reflect the new length.
 300
 301 =cut
 302 */
 303
 304 U8*
 305 Perl_bytes_to_utf8(pTHX_ U8* s, STRLEN *len)
 306 {
 307     dTHR;
 308     U8 *send;
 309     U8 *d;
 310     U8 *dst;
 311     send = s + (*len);
 312
 313     Newz(801, d, (*len) * 2 + 1, U8);
 314     dst = d;
 315
 316     while (s < send) {
 317         if (*s < 0x80)
 318             *d++ = *s++;
 319         else {
 320             UV uv = *s++;
 321             *d++ = (( uv >>  6)         | 0xc0);
 322             *d++ = (( uv        & 0x3f) | 0x80);
 323         }
 324     }
 325     *d = '\0';
 326     *len = d-dst;
 327     return dst;
 328 }
 329
 330 /*
 331  * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
 332  *
 333  * Destination must be pre-extended to 3/2 source.  Do not use in-place.
 334  * We optimize for native, for obvious reasons. */
 335
 336 U8*
 337 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 338 {
 339     U8* pend;
 340     U8* dstart = d;
 341
 342     if (bytelen & 1)
 343         Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen");
 344
 345     pend = p + bytelen;
 346
 347     while (p < pend) {
 348         UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
 349         p += 2;
 350         if (uv < 0x80) {
 351             *d++ = uv;
 352             continue;
 353         }
 354         if (uv < 0x800) {
 355             *d++ = (( uv >>  6)         | 0xc0);
 356             *d++ = (( uv        & 0x3f) | 0x80);
 357             continue;
 358         }
 359         if (uv >= 0xd800 && uv < 0xdbff) {      /* surrogates */
 360             dTHR;
 361             UV low = *p++;
 362             if (low < 0xdc00 || low >= 0xdfff)
 363                 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
 364             uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
 365         }
 366         if (uv < 0x10000) {
 367             *d++ = (( uv >> 12)         | 0xe0);
 368             *d++ = (((uv >>  6) & 0x3f) | 0x80);
 369             *d++ = (( uv        & 0x3f) | 0x80);
 370             continue;
 371         }
 372         else {
 373             *d++ = (( uv >> 18)         | 0xf0);
 374             *d++ = (((uv >> 12) & 0x3f) | 0x80);
 375             *d++ = (((uv >>  6) & 0x3f) | 0x80);
 376             *d++ = (( uv        & 0x3f) | 0x80);
 377             continue;
 378         }
 379     }
 380     *newlen = d - dstart;
 381     return d;
 382 }
 383
 384 /* Note: this one is slightly destructive of the source. */
 385
 386 U8*
 387 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 388 {
 389     U8* s = (U8*)p;
 390     U8* send = s + bytelen;
 391     while (s < send) {
 392         U8 tmp = s[0];
 393         s[0] = s[1];
 394         s[1] = tmp;
 395         s += 2;
 396     }
 397     return utf16_to_utf8(p, d, bytelen, newlen);
 398 }
 399
 400 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
 401
 402 bool
 403 Perl_is_uni_alnum(pTHX_ U32 c)
 404 {
 405     U8 tmpbuf[UTF8_MAXLEN];
 406     uv_to_utf8(tmpbuf, (UV)c);
 407     return is_utf8_alnum(tmpbuf);
 408 }
 409
 410 bool
 411 Perl_is_uni_alnumc(pTHX_ U32 c)
 412 {
 413     U8 tmpbuf[UTF8_MAXLEN];
 414     uv_to_utf8(tmpbuf, (UV)c);
 415     return is_utf8_alnumc(tmpbuf);
 416 }
 417
 418 bool
 419 Perl_is_uni_idfirst(pTHX_ U32 c)
 420 {
 421     U8 tmpbuf[UTF8_MAXLEN];
 422     uv_to_utf8(tmpbuf, (UV)c);
 423     return is_utf8_idfirst(tmpbuf);
 424 }
 425
 426 bool
 427 Perl_is_uni_alpha(pTHX_ U32 c)
 428 {
 429     U8 tmpbuf[UTF8_MAXLEN];
 430     uv_to_utf8(tmpbuf, (UV)c);
 431     return is_utf8_alpha(tmpbuf);
 432 }
 433
 434 bool
 435 Perl_is_uni_ascii(pTHX_ U32 c)
 436 {
 437     U8 tmpbuf[UTF8_MAXLEN];
 438     uv_to_utf8(tmpbuf, (UV)c);
 439     return is_utf8_ascii(tmpbuf);
 440 }
 441
 442 bool
 443 Perl_is_uni_space(pTHX_ U32 c)
 444 {
 445     U8 tmpbuf[UTF8_MAXLEN];
 446     uv_to_utf8(tmpbuf, (UV)c);
 447     return is_utf8_space(tmpbuf);
 448 }
 449
 450 bool
 451 Perl_is_uni_digit(pTHX_ U32 c)
 452 {
 453     U8 tmpbuf[UTF8_MAXLEN];
 454     uv_to_utf8(tmpbuf, (UV)c);
 455     return is_utf8_digit(tmpbuf);
 456 }
 457
 458 bool
 459 Perl_is_uni_upper(pTHX_ U32 c)
 460 {
 461     U8 tmpbuf[UTF8_MAXLEN];
 462     uv_to_utf8(tmpbuf, (UV)c);
 463     return is_utf8_upper(tmpbuf);
 464 }
 465
 466 bool
 467 Perl_is_uni_lower(pTHX_ U32 c)
 468 {
 469     U8 tmpbuf[UTF8_MAXLEN];
 470     uv_to_utf8(tmpbuf, (UV)c);
 471     return is_utf8_lower(tmpbuf);
 472 }
 473
 474 bool
 475 Perl_is_uni_cntrl(pTHX_ U32 c)
 476 {
 477     U8 tmpbuf[UTF8_MAXLEN];
 478     uv_to_utf8(tmpbuf, (UV)c);
 479     return is_utf8_cntrl(tmpbuf);
 480 }
 481
 482 bool
 483 Perl_is_uni_graph(pTHX_ U32 c)
 484 {
 485     U8 tmpbuf[UTF8_MAXLEN];
 486     uv_to_utf8(tmpbuf, (UV)c);
 487     return is_utf8_graph(tmpbuf);
 488 }
 489
 490 bool
 491 Perl_is_uni_print(pTHX_ U32 c)
 492 {
 493     U8 tmpbuf[UTF8_MAXLEN];
 494     uv_to_utf8(tmpbuf, (UV)c);
 495     return is_utf8_print(tmpbuf);
 496 }
 497
 498 bool
 499 Perl_is_uni_punct(pTHX_ U32 c)
 500 {
 501     U8 tmpbuf[UTF8_MAXLEN];
 502     uv_to_utf8(tmpbuf, (UV)c);
 503     return is_utf8_punct(tmpbuf);
 504 }
 505
 506 bool
 507 Perl_is_uni_xdigit(pTHX_ U32 c)
 508 {
 509     U8 tmpbuf[UTF8_MAXLEN];
 510     uv_to_utf8(tmpbuf, (UV)c);
 511     return is_utf8_xdigit(tmpbuf);
 512 }
 513
 514 U32
 515 Perl_to_uni_upper(pTHX_ U32 c)
 516 {
 517     U8 tmpbuf[UTF8_MAXLEN];
 518     uv_to_utf8(tmpbuf, (UV)c);
 519     return to_utf8_upper(tmpbuf);
 520 }
 521
 522 U32
 523 Perl_to_uni_title(pTHX_ U32 c)
 524 {
 525     U8 tmpbuf[UTF8_MAXLEN];
 526     uv_to_utf8(tmpbuf, (UV)c);
 527     return to_utf8_title(tmpbuf);
 528 }
 529
 530 U32
 531 Perl_to_uni_lower(pTHX_ U32 c)
 532 {
 533     U8 tmpbuf[UTF8_MAXLEN];
 534     uv_to_utf8(tmpbuf, (UV)c);
 535     return to_utf8_lower(tmpbuf);
 536 }
 537
 538 /* for now these all assume no locale info available for Unicode > 255 */
 539
 540 bool
 541 Perl_is_uni_alnum_lc(pTHX_ U32 c)
 542 {
 543     return is_uni_alnum(c);     /* XXX no locale support yet */
 544 }
 545
 546 bool
 547 Perl_is_uni_alnumc_lc(pTHX_ U32 c)
 548 {
 549     return is_uni_alnumc(c);    /* XXX no locale support yet */
 550 }
 551
 552 bool
 553 Perl_is_uni_idfirst_lc(pTHX_ U32 c)
 554 {
 555     return is_uni_idfirst(c);   /* XXX no locale support yet */
 556 }
 557
 558 bool
 559 Perl_is_uni_alpha_lc(pTHX_ U32 c)
 560 {
 561     return is_uni_alpha(c);     /* XXX no locale support yet */
 562 }
 563
 564 bool
 565 Perl_is_uni_ascii_lc(pTHX_ U32 c)
 566 {
 567     return is_uni_ascii(c);     /* XXX no locale support yet */
 568 }
 569
 570 bool
 571 Perl_is_uni_space_lc(pTHX_ U32 c)
 572 {
 573     return is_uni_space(c);     /* XXX no locale support yet */
 574 }
 575
 576 bool
 577 Perl_is_uni_digit_lc(pTHX_ U32 c)
 578 {
 579     return is_uni_digit(c);     /* XXX no locale support yet */
 580 }
 581
 582 bool
 583 Perl_is_uni_upper_lc(pTHX_ U32 c)
 584 {
 585     return is_uni_upper(c);     /* XXX no locale support yet */
 586 }
 587
 588 bool
 589 Perl_is_uni_lower_lc(pTHX_ U32 c)
 590 {
 591     return is_uni_lower(c);     /* XXX no locale support yet */
 592 }
 593
 594 bool
 595 Perl_is_uni_cntrl_lc(pTHX_ U32 c)
 596 {
 597     return is_uni_cntrl(c);     /* XXX no locale support yet */
 598 }
 599
 600 bool
 601 Perl_is_uni_graph_lc(pTHX_ U32 c)
 602 {
 603     return is_uni_graph(c);     /* XXX no locale support yet */
 604 }
 605
 606 bool
 607 Perl_is_uni_print_lc(pTHX_ U32 c)
 608 {
 609     return is_uni_print(c);     /* XXX no locale support yet */
 610 }
 611
 612 bool
 613 Perl_is_uni_punct_lc(pTHX_ U32 c)
 614 {
 615     return is_uni_punct(c);     /* XXX no locale support yet */
 616 }
 617
 618 bool
 619 Perl_is_uni_xdigit_lc(pTHX_ U32 c)
 620 {
 621     return is_uni_xdigit(c);    /* XXX no locale support yet */
 622 }
 623
 624 U32
 625 Perl_to_uni_upper_lc(pTHX_ U32 c)
 626 {
 627     return to_uni_upper(c);     /* XXX no locale support yet */
 628 }
 629
 630 U32
 631 Perl_to_uni_title_lc(pTHX_ U32 c)
 632 {
 633     return to_uni_title(c);     /* XXX no locale support yet */
 634 }
 635
 636 U32
 637 Perl_to_uni_lower_lc(pTHX_ U32 c)
 638 {
 639     return to_uni_lower(c);     /* XXX no locale support yet */
 640 }
 641
 642 bool
 643 Perl_is_utf8_alnum(pTHX_ U8 *p)
 644 {
 645     if (!is_utf8_char(p))
 646         return FALSE;
 647     if (!PL_utf8_alnum)
 648         PL_utf8_alnum = swash_init("utf8", "IsAlnum", &PL_sv_undef, 0, 0);
 649     return swash_fetch(PL_utf8_alnum, p);
 650 /*    return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */
 651 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
 652     if (!PL_utf8_alnum)
 653         PL_utf8_alnum = swash_init("utf8", "",
 654             sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
 655     return swash_fetch(PL_utf8_alnum, p);
 656 #endif
 657 }
 658
 659 bool
 660 Perl_is_utf8_alnumc(pTHX_ U8 *p)
 661 {
 662     if (!is_utf8_char(p))
 663         return FALSE;
 664     if (!PL_utf8_alnum)
 665         PL_utf8_alnum = swash_init("utf8", "IsAlnumC", &PL_sv_undef, 0, 0);
 666     return swash_fetch(PL_utf8_alnum, p);
 667 /*    return is_utf8_alpha(p) || is_utf8_digit(p); */
 668 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
 669     if (!PL_utf8_alnum)
 670         PL_utf8_alnum = swash_init("utf8", "",
 671             sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
 672     return swash_fetch(PL_utf8_alnum, p);
 673 #endif
 674 }
 675
 676 bool
 677 Perl_is_utf8_idfirst(pTHX_ U8 *p)
 678 {
 679     return *p == '_' || is_utf8_alpha(p);
 680 }
 681
 682 bool
 683 Perl_is_utf8_alpha(pTHX_ U8 *p)
 684 {
 685     if (!is_utf8_char(p))
 686         return FALSE;
 687     if (!PL_utf8_alpha)
 688         PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0);
 689     return swash_fetch(PL_utf8_alpha, p);
 690 }
 691
 692 bool
 693 Perl_is_utf8_ascii(pTHX_ U8 *p)
 694 {
 695     if (!is_utf8_char(p))
 696         return FALSE;
 697     if (!PL_utf8_ascii)
 698         PL_utf8_ascii = swash_init("utf8", "IsAscii", &PL_sv_undef, 0, 0);
 699     return swash_fetch(PL_utf8_ascii, p);
 700 }
 701
 702 bool
 703 Perl_is_utf8_space(pTHX_ U8 *p)
 704 {
 705     if (!is_utf8_char(p))
 706         return FALSE;
 707     if (!PL_utf8_space)
 708         PL_utf8_space = swash_init("utf8", "IsSpace", &PL_sv_undef, 0, 0);
 709     return swash_fetch(PL_utf8_space, p);
 710 }
 711
 712 bool
 713 Perl_is_utf8_digit(pTHX_ U8 *p)
 714 {
 715     if (!is_utf8_char(p))
 716         return FALSE;
 717     if (!PL_utf8_digit)
 718         PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0);
 719     return swash_fetch(PL_utf8_digit, p);
 720 }
 721
 722 bool
 723 Perl_is_utf8_upper(pTHX_ U8 *p)
 724 {
 725     if (!is_utf8_char(p))
 726         return FALSE;
 727     if (!PL_utf8_upper)
 728         PL_utf8_upper = swash_init("utf8", "IsUpper", &PL_sv_undef, 0, 0);
 729     return swash_fetch(PL_utf8_upper, p);
 730 }
 731
 732 bool
 733 Perl_is_utf8_lower(pTHX_ U8 *p)
 734 {
 735     if (!is_utf8_char(p))
 736         return FALSE;
 737     if (!PL_utf8_lower)
 738         PL_utf8_lower = swash_init("utf8", "IsLower", &PL_sv_undef, 0, 0);
 739     return swash_fetch(PL_utf8_lower, p);
 740 }
 741
 742 bool
 743 Perl_is_utf8_cntrl(pTHX_ U8 *p)
 744 {
 745     if (!is_utf8_char(p))
 746         return FALSE;
 747     if (!PL_utf8_cntrl)
 748         PL_utf8_cntrl = swash_init("utf8", "IsCntrl", &PL_sv_undef, 0, 0);
 749     return swash_fetch(PL_utf8_cntrl, p);
 750 }
 751
 752 bool
 753 Perl_is_utf8_graph(pTHX_ U8 *p)
 754 {
 755     if (!is_utf8_char(p))
 756         return FALSE;
 757     if (!PL_utf8_graph)
 758         PL_utf8_graph = swash_init("utf8", "IsGraph", &PL_sv_undef, 0, 0);
 759     return swash_fetch(PL_utf8_graph, p);
 760 }
 761
 762 bool
 763 Perl_is_utf8_print(pTHX_ U8 *p)
 764 {
 765     if (!is_utf8_char(p))
 766         return FALSE;
 767     if (!PL_utf8_print)
 768         PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0);
 769     return swash_fetch(PL_utf8_print, p);
 770 }
 771
 772 bool
 773 Perl_is_utf8_punct(pTHX_ U8 *p)
 774 {
 775     if (!is_utf8_char(p))
 776         return FALSE;
 777     if (!PL_utf8_punct)
 778         PL_utf8_punct = swash_init("utf8", "IsPunct", &PL_sv_undef, 0, 0);
 779     return swash_fetch(PL_utf8_punct, p);
 780 }
 781
 782 bool
 783 Perl_is_utf8_xdigit(pTHX_ U8 *p)
 784 {
 785     if (!is_utf8_char(p))
 786         return FALSE;
 787     if (!PL_utf8_xdigit)
 788         PL_utf8_xdigit = swash_init("utf8", "IsXDigit", &PL_sv_undef, 0, 0);
 789     return swash_fetch(PL_utf8_xdigit, p);
 790 }
 791
 792 bool
 793 Perl_is_utf8_mark(pTHX_ U8 *p)
 794 {
 795     if (!is_utf8_char(p))
 796         return FALSE;
 797     if (!PL_utf8_mark)
 798         PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0);
 799     return swash_fetch(PL_utf8_mark, p);
 800 }
 801
 802 UV
 803 Perl_to_utf8_upper(pTHX_ U8 *p)
 804 {
 805     UV uv;
 806
 807     if (!PL_utf8_toupper)
 808         PL_utf8_toupper = swash_init("utf8", "ToUpper", &PL_sv_undef, 4, 0);
 809     uv = swash_fetch(PL_utf8_toupper, p);
 810     return uv ? uv : utf8_to_uv(p,0);
 811 }
 812
 813 UV
 814 Perl_to_utf8_title(pTHX_ U8 *p)
 815 {
 816     UV uv;
 817
 818     if (!PL_utf8_totitle)
 819         PL_utf8_totitle = swash_init("utf8", "ToTitle", &PL_sv_undef, 4, 0);
 820     uv = swash_fetch(PL_utf8_totitle, p);
 821     return uv ? uv : utf8_to_uv(p,0);
 822 }
 823
 824 UV
 825 Perl_to_utf8_lower(pTHX_ U8 *p)
 826 {
 827     UV uv;
 828
 829     if (!PL_utf8_tolower)
 830         PL_utf8_tolower = swash_init("utf8", "ToLower", &PL_sv_undef, 4, 0);
 831     uv = swash_fetch(PL_utf8_tolower, p);
 832     return uv ? uv : utf8_to_uv(p,0);
 833 }
 834
 835 /* a "swash" is a swatch hash */
 836
 837 SV*
 838 Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
 839 {
 840     SV* retval;
 841     char tmpbuf[256];
 842     dSP;
 843
 844     if (!gv_stashpv(pkg, 0)) {  /* demand load utf8 */
 845         ENTER;
 846         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpv(pkg,0), Nullsv);
 847         LEAVE;
 848     }
 849     SPAGAIN;
 850     PUSHSTACKi(PERLSI_MAGIC);
 851     PUSHMARK(SP);
 852     EXTEND(SP,5);
 853     PUSHs(sv_2mortal(newSVpvn(pkg, strlen(pkg))));
 854     PUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
 855     PUSHs(listsv);
 856     PUSHs(sv_2mortal(newSViv(minbits)));
 857     PUSHs(sv_2mortal(newSViv(none)));
 858     PUTBACK;
 859     ENTER;
 860     SAVEI32(PL_hints);
 861     PL_hints = 0;
 862     save_re_context();
 863     if (PL_curcop == &PL_compiling)     /* XXX ought to be handled by lex_start */
 864         strncpy(tmpbuf, PL_tokenbuf, sizeof tmpbuf);
 865     if (call_method("SWASHNEW", G_SCALAR))
 866         retval = newSVsv(*PL_stack_sp--);
 867     else
 868         retval = &PL_sv_undef;
 869     LEAVE;
 870     POPSTACK;
 871     if (PL_curcop == &PL_compiling) {
 872         strncpy(PL_tokenbuf, tmpbuf, sizeof tmpbuf);
 873         PL_curcop->op_private = PL_hints;
 874     }
 875     if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV)
 876         Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
 877     return retval;
 878 }
 879
 880 UV
 881 Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr)
 882 {
 883     HV* hv = (HV*)SvRV(sv);
 884     U32 klen = UTF8SKIP(ptr) - 1;
 885     U32 off = ptr[klen] & 127;  /* NB: 64 bit always 0 when len > 1 */
 886     STRLEN slen;
 887     STRLEN needents = (klen ? 64 : 128);
 888     U8 *tmps;
 889     U32 bit;
 890     SV *retval;
 891
 892     /*
 893      * This single-entry cache saves about 1/3 of the utf8 overhead in test
 894      * suite.  (That is, only 7-8% overall over just a hash cache.  Still,
 895      * it's nothing to sniff at.)  Pity we usually come through at least
 896      * two function calls to get here...
 897      *
 898      * NB: this code assumes that swatches are never modified, once generated!
 899      */
 900
 901     if (hv == PL_last_swash_hv &&
 902         klen == PL_last_swash_klen &&
 903         (!klen || memEQ((char *)ptr,(char *)PL_last_swash_key,klen)) )
 904     {
 905         tmps = PL_last_swash_tmps;
 906         slen = PL_last_swash_slen;
 907     }
 908     else {
 909         /* Try our second-level swatch cache, kept in a hash. */
 910         SV** svp = hv_fetch(hv, (char*)ptr, klen, FALSE);
 911
 912         /* If not cached, generate it via utf8::SWASHGET */
 913         if (!svp || !SvPOK(*svp) || !(tmps = (U8*)SvPV(*svp, slen))) {
 914             dSP;
 915             ENTER;
 916             SAVETMPS;
 917             save_re_context();
 918             PUSHSTACKi(PERLSI_MAGIC);
 919             PUSHMARK(SP);
 920             EXTEND(SP,3);
 921             PUSHs((SV*)sv);
 922             PUSHs(sv_2mortal(newSViv(utf8_to_uv(ptr, 0) & ~(needents - 1))));
 923             PUSHs(sv_2mortal(newSViv(needents)));
 924             PUTBACK;
 925             if (call_method("SWASHGET", G_SCALAR))
 926                 retval = newSVsv(*PL_stack_sp--);
 927             else
 928                 retval = &PL_sv_undef;
 929             POPSTACK;
 930             FREETMPS;
 931             LEAVE;
 932             if (PL_curcop == &PL_compiling)
 933                 PL_curcop->op_private = PL_hints;
 934
 935             svp = hv_store(hv, (char*)ptr, klen, retval, 0);
 936
 937             if (!svp || !(tmps = (U8*)SvPV(*svp, slen)) || slen < 8)
 938                 Perl_croak(aTHX_ "SWASHGET didn't return result of proper length");
 939         }
 940
 941         PL_last_swash_hv = hv;
 942         PL_last_swash_klen = klen;
 943         PL_last_swash_tmps = tmps;
 944         PL_last_swash_slen = slen;
 945         if (klen)
 946             Copy(ptr, PL_last_swash_key, klen, U8);
 947     }
 948
 949     switch ((slen << 3) / needents) {
 950     case 1:
 951         bit = 1 << (off & 7);
 952         off >>= 3;
 953         return (tmps[off] & bit) != 0;
 954     case 8:
 955         return tmps[off];
 956     case 16:
 957         off <<= 1;
 958         return (tmps[off] << 8) + tmps[off + 1] ;
 959     case 32:
 960         off <<= 2;
 961         return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
 962     }
 963     Perl_croak(aTHX_ "panic: swash_fetch");
 964     return 0;
 965 }