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