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