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