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