utf8.c

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