utf8.c

   1 /*    utf8.c
   2  *
   3  *    Copyright (c) 1998-2000, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * 'What a fix!' said Sam. 'That's the one place in all the lands we've ever
  12  * heard of that we don't want to see any closer; and that's the one place
  13  * we're trying to get to!  And that's just where we can't get, nohow.'
  14  *
  15  * 'Well do I understand your speech,' he answered in the same language;
  16  * 'yet few strangers do so.  Why then do you not speak in the Common Tongue,
  17  * as is the custom in the West, if you wish to be answered?'
  18  *
  19  * ...the travellers perceived that the floor was paved with stones of many
  20  * hues; branching runes and strange devices intertwined beneath their feet.
  21  */
  22
  23 #include "EXTERN.h"
  24 #define PERL_IN_UTF8_C
  25 #include "perl.h"
  26
  27 /* Unicode support */
  28
  29 U8 *
  30 Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
  31 {
  32     if (uv < 0x80) {
  33         *d++ = uv;
  34         return d;
  35     }
  36     if (uv < 0x800) {
  37         *d++ = (( uv >>  6)         | 0xc0);
  38         *d++ = (( uv        & 0x3f) | 0x80);
  39         return d;
  40     }
  41     if (uv < 0x10000) {
  42         *d++ = (( uv >> 12)         | 0xe0);
  43         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  44         *d++ = (( uv        & 0x3f) | 0x80);
  45         return d;
  46     }
  47     if (uv < 0x200000) {
  48         *d++ = (( uv >> 18)         | 0xf0);
  49         *d++ = (((uv >> 12) & 0x3f) | 0x80);
  50         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  51         *d++ = (( uv        & 0x3f) | 0x80);
  52         return d;
  53     }
  54     if (uv < 0x4000000) {
  55         *d++ = (( uv >> 24)         | 0xf8);
  56         *d++ = (((uv >> 18) & 0x3f) | 0x80);
  57         *d++ = (((uv >> 12) & 0x3f) | 0x80);
  58         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  59         *d++ = (( uv        & 0x3f) | 0x80);
  60         return d;
  61     }
  62     if (uv < 0x80000000) {
  63         *d++ = (( uv >> 30)         | 0xfc);
  64         *d++ = (((uv >> 24) & 0x3f) | 0x80);
  65         *d++ = (((uv >> 18) & 0x3f) | 0x80);
  66         *d++ = (((uv >> 12) & 0x3f) | 0x80);
  67         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  68         *d++ = (( uv        & 0x3f) | 0x80);
  69         return d;
  70     }
  71 #ifdef HAS_QUAD
  72     if (uv < 0x1000000000LL)
  73 #endif
  74     {
  75         *d++ =                        0xfe;     /* Can't match U+FEFF! */
  76         *d++ = (((uv >> 30) & 0x3f) | 0x80);
  77         *d++ = (((uv >> 24) & 0x3f) | 0x80);
  78         *d++ = (((uv >> 18) & 0x3f) | 0x80);
  79         *d++ = (((uv >> 12) & 0x3f) | 0x80);
  80         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  81         *d++ = (( uv        & 0x3f) | 0x80);
  82         return d;
  83     }
  84 #ifdef HAS_QUAD
  85     {
  86         *d++ =                        0xff;     /* Can't match U+FFFE! */
  87         *d++ =                        0x80;     /* 6 Reserved bits */
  88         *d++ = (((uv >> 60) & 0x0f) | 0x80);    /* 2 Reserved bits */
  89         *d++ = (((uv >> 54) & 0x3f) | 0x80);
  90         *d++ = (((uv >> 48) & 0x3f) | 0x80);
  91         *d++ = (((uv >> 42) & 0x3f) | 0x80);
  92         *d++ = (((uv >> 36) & 0x3f) | 0x80);
  93         *d++ = (((uv >> 30) & 0x3f) | 0x80);
  94         *d++ = (((uv >> 24) & 0x3f) | 0x80);
  95         *d++ = (((uv >> 18) & 0x3f) | 0x80);
  96         *d++ = (((uv >> 12) & 0x3f) | 0x80);
  97         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  98         *d++ = (( uv        & 0x3f) | 0x80);
  99         return d;
 100     }
 101 #endif
 102 }
 103
 104 /* Tests if some arbitrary number of bytes begins in a valid UTF-8 character.
 105  * The actual number of bytes in the UTF-8 character will be returned if it
 106  * is valid, otherwise 0. */
 107 int
 108 Perl_is_utf8_char(pTHX_ U8 *s)
 109 {
 110     U8 u = *s;
 111     int slen, len;
 112
 113     if (!(u & 0x80))
 114         return 1;
 115
 116     if (!(u & 0x40))
 117         return 0;
 118
 119     if      (!(u & 0x20))       { len = 2; }
 120     else if (!(u & 0x10))       { len = 3; }
 121     else if (!(u & 0x08))       { len = 4; }
 122     else if (!(u & 0x04))       { len = 5; }
 123     else if (!(u & 0x02))       { len = 6; }
 124     else if (!(u & 0x01))       { len = 7; }
 125     else                        { len = 13; } /* whoa! */
 126
 127     slen = len - 1;
 128     s++;
 129     while (slen--) {
 130         if ((*s & 0xc0) != 0x80)
 131             return 0;
 132         s++;
 133     }
 134     return len;
 135 }
 136
 137 /*
 138 =for apidoc Am|is_utf8_string|U8 *s|STRLEN len
 139
 140 Returns true if first C<len> bytes of the given string form valid a UTF8
 141 string, false otherwise.
 142
 143 =cut
 144 */
 145
 146 bool
 147 Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len)
 148 {
 149     U8* x=s;
 150     U8* send=s+len;
 151     int c;
 152     while (x < send) {
 153         c = is_utf8_char(x);
 154         x += c;
 155         if (!c || x > send)
 156             return 0;
 157     }
 158     return 1;
 159 }
 160
 161 /*
 162 =for apidoc Am|U8* s|utf8_to_uv_chk|I32 *retlen|I32 checking
 163
 164 Returns the character value of the first character in the string C<s>
 165 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
 166 length, in bytes, of that character, and the pointer C<s> will be
 167 advanced to the end of the character.
 168
 169 If C<s> does not point to a well-formed UTF8 character, the behaviour
 170 is dependent on the value of C<checking>: if this is true, it is
 171 assumed that the caller will raise a warning, and this function will
 172 set C<retlen> to C<-1> and return. If C<checking> is not true, an optional UTF8
 173 warning is produced.
 174
 175 =cut
 176 */
 177
 178 UV
 179 Perl_utf8_to_uv_chk(pTHX_ U8* s, I32* retlen, bool checking)
 180 {
 181     UV uv = *s;
 182     int len;
 183     if (!(uv & 0x80)) {
 184         if (retlen)
 185             *retlen = 1;
 186         return *s;
 187     }
 188     if (!(uv & 0x40)) {
 189         dTHR;
 190         if (checking && retlen) {
 191             *retlen = -1;
 192             return 0;
 193         }
 194
 195         if (ckWARN_d(WARN_UTF8))
 196             Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
 197         if (retlen)
 198             *retlen = 1;
 199         return *s;
 200     }
 201
 202     if      (!(uv & 0x20))      { len = 2; uv &= 0x1f; }
 203     else if (!(uv & 0x10))      { len = 3; uv &= 0x0f; }
 204     else if (!(uv & 0x08))      { len = 4; uv &= 0x07; }
 205     else if (!(uv & 0x04))      { len = 5; uv &= 0x03; }
 206     else if (!(uv & 0x02))      { len = 6; uv &= 0x01; }
 207     else if (!(uv & 0x01))      { len = 7;  uv = 0; }
 208     else                        { len = 13; uv = 0; } /* whoa! */
 209
 210     if (retlen)
 211         *retlen = len;
 212     --len;
 213     s++;
 214     while (len--) {
 215         if ((*s & 0xc0) != 0x80) {
 216             dTHR;
 217             if (checking && retlen) {
 218                 *retlen = -1;
 219                 return 0;
 220             }
 221
 222             if (ckWARN_d(WARN_UTF8))
 223                 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
 224             if (retlen)
 225                 *retlen -= len + 1;
 226             return 0xfffd;
 227         }
 228         else
 229             uv = (uv << 6) | (*s++ & 0x3f);
 230     }
 231     return uv;
 232 }
 233
 234 /*
 235 =for apidoc Am|U8* s|utf8_to_uv|I32 *retlen
 236
 237 Returns the character value of the first character in the string C<s>
 238 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
 239 length, in bytes, of that character, and the pointer C<s> will be
 240 advanced to the end of the character.
 241
 242 If C<s> does not point to a well-formed UTF8 character, an optional UTF8
 243 warning is produced.
 244
 245 =cut
 246 */
 247
 248 UV
 249 Perl_utf8_to_uv(pTHX_ U8* s, I32* retlen)
 250 {
 251  return Perl_utf8_to_uv_chk(aTHX_ s, retlen, 0);
 252 }
 253
 254 /* utf8_distance(a,b) returns the number of UTF8 characters between
 255    the pointers a and b                                                 */
 256
 257 I32
 258 Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
 259 {
 260     I32 off = 0;
 261     if (a < b) {
 262         while (a < b) {
 263             a += UTF8SKIP(a);
 264             off--;
 265         }
 266     }
 267     else {
 268         while (b < a) {
 269             b += UTF8SKIP(b);
 270             off++;
 271         }
 272     }
 273     return off;
 274 }
 275
 276 /* WARNING: do not use the following unless you *know* off is within bounds */
 277
 278 U8 *
 279 Perl_utf8_hop(pTHX_ U8 *s, I32 off)
 280 {
 281     if (off >= 0) {
 282         while (off--)
 283             s += UTF8SKIP(s);
 284     }
 285     else {
 286         while (off++) {
 287             s--;
 288             if (*s & 0x80) {
 289                 while ((*s & 0xc0) == 0x80)
 290                     s--;
 291             }
 292         }
 293     }
 294     return s;
 295 }
 296
 297 /*
 298 =for apidoc Am|U8 *|utf8_to_bytes|U8 *s|STRLEN *len
 299
 300 Converts a string C<s> of length C<len> from UTF8 into byte encoding.
 301 Unlike C<bytes_to_utf8>, this over-writes the original string, and
 302 updates len to contain the new length.
 303 Returns zero on failure, setting C<len> to -1.
 304
 305 =cut
 306 */
 307
 308 U8 *
 309 Perl_utf8_to_bytes(pTHX_ U8* s, STRLEN *len)
 310 {
 311     dTHR;
 312     U8 *send;
 313     U8 *d;
 314     U8 *save;
 315
 316     send = s + *len;
 317     d = save = s;
 318
 319     /* ensure valid UTF8 and chars < 256 before updating string */
 320     while (s < send) {
 321         U8 c = *s++;
 322         if (c >= 0x80 &&
 323             ( (s >= send) || ((*s++ & 0xc0) != 0x80) || ((c & 0xfe) != 0xc2))) {
 324             *len = -1;
 325             return 0;
 326         }
 327     }
 328     s = save;
 329     while (s < send) {
 330         if (*s < 0x80)
 331             *d++ = *s++;
 332         else {
 333             I32 ulen;
 334             *d++ = (U8)utf8_to_uv(s, &ulen);
 335             s += ulen;
 336         }
 337     }
 338     *d = '\0';
 339     *len = d - save;
 340     return save;
 341 }
 342
 343 /*
 344 =for apidoc Am|U8 *|bytes_to_utf8|U8 *s|STRLEN *len
 345
 346 Converts a string C<s> of length C<len> from ASCII into UTF8 encoding.
 347 Returns a pointer to the newly-created string, and sets C<len> to
 348 reflect the new length.
 349
 350 =cut
 351 */
 352
 353 U8*
 354 Perl_bytes_to_utf8(pTHX_ U8* s, STRLEN *len)
 355 {
 356     dTHR;
 357     U8 *send;
 358     U8 *d;
 359     U8 *dst;
 360     send = s + (*len);
 361
 362     Newz(801, d, (*len) * 2 + 1, U8);
 363     dst = d;
 364
 365     while (s < send) {
 366         if (*s < 0x80)
 367             *d++ = *s++;
 368         else {
 369             UV uv = *s++;
 370             *d++ = (( uv >>  6)         | 0xc0);
 371             *d++ = (( uv        & 0x3f) | 0x80);
 372         }
 373     }
 374     *d = '\0';
 375     *len = d-dst;
 376     return dst;
 377 }
 378
 379 /*
 380  * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
 381  *
 382  * Destination must be pre-extended to 3/2 source.  Do not use in-place.
 383  * We optimize for native, for obvious reasons. */
 384
 385 U8*
 386 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 387 {
 388     U8* pend;
 389     U8* dstart = d;
 390
 391     if (bytelen & 1)
 392         Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen");
 393
 394     pend = p + bytelen;
 395
 396     while (p < pend) {
 397         UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
 398         p += 2;
 399         if (uv < 0x80) {
 400             *d++ = uv;
 401             continue;
 402         }
 403         if (uv < 0x800) {
 404             *d++ = (( uv >>  6)         | 0xc0);
 405             *d++ = (( uv        & 0x3f) | 0x80);
 406             continue;
 407         }
 408         if (uv >= 0xd800 && uv < 0xdbff) {      /* surrogates */
 409             dTHR;
 410             UV low = *p++;
 411             if (low < 0xdc00 || low >= 0xdfff)
 412                 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
 413             uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
 414         }
 415         if (uv < 0x10000) {
 416             *d++ = (( uv >> 12)         | 0xe0);
 417             *d++ = (((uv >>  6) & 0x3f) | 0x80);
 418             *d++ = (( uv        & 0x3f) | 0x80);
 419             continue;
 420         }
 421         else {
 422             *d++ = (( uv >> 18)         | 0xf0);
 423             *d++ = (((uv >> 12) & 0x3f) | 0x80);
 424             *d++ = (((uv >>  6) & 0x3f) | 0x80);
 425             *d++ = (( uv        & 0x3f) | 0x80);
 426             continue;
 427         }
 428     }
 429     *newlen = d - dstart;
 430     return d;
 431 }
 432
 433 /* Note: this one is slightly destructive of the source. */
 434
 435 U8*
 436 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 437 {
 438     U8* s = (U8*)p;
 439     U8* send = s + bytelen;
 440     while (s < send) {
 441         U8 tmp = s[0];
 442         s[0] = s[1];
 443         s[1] = tmp;
 444         s += 2;
 445     }
 446     return utf16_to_utf8(p, d, bytelen, newlen);
 447 }
 448
 449 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
 450
 451 bool
 452 Perl_is_uni_alnum(pTHX_ U32 c)
 453 {
 454     U8 tmpbuf[UTF8_MAXLEN];
 455     uv_to_utf8(tmpbuf, (UV)c);
 456     return is_utf8_alnum(tmpbuf);
 457 }
 458
 459 bool
 460 Perl_is_uni_alnumc(pTHX_ U32 c)
 461 {
 462     U8 tmpbuf[UTF8_MAXLEN];
 463     uv_to_utf8(tmpbuf, (UV)c);
 464     return is_utf8_alnumc(tmpbuf);
 465 }
 466
 467 bool
 468 Perl_is_uni_idfirst(pTHX_ U32 c)
 469 {
 470     U8 tmpbuf[UTF8_MAXLEN];
 471     uv_to_utf8(tmpbuf, (UV)c);
 472     return is_utf8_idfirst(tmpbuf);
 473 }
 474
 475 bool
 476 Perl_is_uni_alpha(pTHX_ U32 c)
 477 {
 478     U8 tmpbuf[UTF8_MAXLEN];
 479     uv_to_utf8(tmpbuf, (UV)c);
 480     return is_utf8_alpha(tmpbuf);
 481 }
 482
 483 bool
 484 Perl_is_uni_ascii(pTHX_ U32 c)
 485 {
 486     U8 tmpbuf[UTF8_MAXLEN];
 487     uv_to_utf8(tmpbuf, (UV)c);
 488     return is_utf8_ascii(tmpbuf);
 489 }
 490
 491 bool
 492 Perl_is_uni_space(pTHX_ U32 c)
 493 {
 494     U8 tmpbuf[UTF8_MAXLEN];
 495     uv_to_utf8(tmpbuf, (UV)c);
 496     return is_utf8_space(tmpbuf);
 497 }
 498
 499 bool
 500 Perl_is_uni_digit(pTHX_ U32 c)
 501 {
 502     U8 tmpbuf[UTF8_MAXLEN];
 503     uv_to_utf8(tmpbuf, (UV)c);
 504     return is_utf8_digit(tmpbuf);
 505 }
 506
 507 bool
 508 Perl_is_uni_upper(pTHX_ U32 c)
 509 {
 510     U8 tmpbuf[UTF8_MAXLEN];
 511     uv_to_utf8(tmpbuf, (UV)c);
 512     return is_utf8_upper(tmpbuf);
 513 }
 514
 515 bool
 516 Perl_is_uni_lower(pTHX_ U32 c)
 517 {
 518     U8 tmpbuf[UTF8_MAXLEN];
 519     uv_to_utf8(tmpbuf, (UV)c);
 520     return is_utf8_lower(tmpbuf);
 521 }
 522
 523 bool
 524 Perl_is_uni_cntrl(pTHX_ U32 c)
 525 {
 526     U8 tmpbuf[UTF8_MAXLEN];
 527     uv_to_utf8(tmpbuf, (UV)c);
 528     return is_utf8_cntrl(tmpbuf);
 529 }
 530
 531 bool
 532 Perl_is_uni_graph(pTHX_ U32 c)
 533 {
 534     U8 tmpbuf[UTF8_MAXLEN];
 535     uv_to_utf8(tmpbuf, (UV)c);
 536     return is_utf8_graph(tmpbuf);
 537 }
 538
 539 bool
 540 Perl_is_uni_print(pTHX_ U32 c)
 541 {
 542     U8 tmpbuf[UTF8_MAXLEN];
 543     uv_to_utf8(tmpbuf, (UV)c);
 544     return is_utf8_print(tmpbuf);
 545 }
 546
 547 bool
 548 Perl_is_uni_punct(pTHX_ U32 c)
 549 {
 550     U8 tmpbuf[UTF8_MAXLEN];
 551     uv_to_utf8(tmpbuf, (UV)c);
 552     return is_utf8_punct(tmpbuf);
 553 }
 554
 555 bool
 556 Perl_is_uni_xdigit(pTHX_ U32 c)
 557 {
 558     U8 tmpbuf[UTF8_MAXLEN];
 559     uv_to_utf8(tmpbuf, (UV)c);
 560     return is_utf8_xdigit(tmpbuf);
 561 }
 562
 563 U32
 564 Perl_to_uni_upper(pTHX_ U32 c)
 565 {
 566     U8 tmpbuf[UTF8_MAXLEN];
 567     uv_to_utf8(tmpbuf, (UV)c);
 568     return to_utf8_upper(tmpbuf);
 569 }
 570
 571 U32
 572 Perl_to_uni_title(pTHX_ U32 c)
 573 {
 574     U8 tmpbuf[UTF8_MAXLEN];
 575     uv_to_utf8(tmpbuf, (UV)c);
 576     return to_utf8_title(tmpbuf);
 577 }
 578
 579 U32
 580 Perl_to_uni_lower(pTHX_ U32 c)
 581 {
 582     U8 tmpbuf[UTF8_MAXLEN];
 583     uv_to_utf8(tmpbuf, (UV)c);
 584     return to_utf8_lower(tmpbuf);
 585 }
 586
 587 /* for now these all assume no locale info available for Unicode > 255 */
 588
 589 bool
 590 Perl_is_uni_alnum_lc(pTHX_ U32 c)
 591 {
 592     return is_uni_alnum(c);     /* XXX no locale support yet */
 593 }
 594
 595 bool
 596 Perl_is_uni_alnumc_lc(pTHX_ U32 c)
 597 {
 598     return is_uni_alnumc(c);    /* XXX no locale support yet */
 599 }
 600
 601 bool
 602 Perl_is_uni_idfirst_lc(pTHX_ U32 c)
 603 {
 604     return is_uni_idfirst(c);   /* XXX no locale support yet */
 605 }
 606
 607 bool
 608 Perl_is_uni_alpha_lc(pTHX_ U32 c)
 609 {
 610     return is_uni_alpha(c);     /* XXX no locale support yet */
 611 }
 612
 613 bool
 614 Perl_is_uni_ascii_lc(pTHX_ U32 c)
 615 {
 616     return is_uni_ascii(c);     /* XXX no locale support yet */
 617 }
 618
 619 bool
 620 Perl_is_uni_space_lc(pTHX_ U32 c)
 621 {
 622     return is_uni_space(c);     /* XXX no locale support yet */
 623 }
 624
 625 bool
 626 Perl_is_uni_digit_lc(pTHX_ U32 c)
 627 {
 628     return is_uni_digit(c);     /* XXX no locale support yet */
 629 }
 630
 631 bool
 632 Perl_is_uni_upper_lc(pTHX_ U32 c)
 633 {
 634     return is_uni_upper(c);     /* XXX no locale support yet */
 635 }
 636
 637 bool
 638 Perl_is_uni_lower_lc(pTHX_ U32 c)
 639 {
 640     return is_uni_lower(c);     /* XXX no locale support yet */
 641 }
 642
 643 bool
 644 Perl_is_uni_cntrl_lc(pTHX_ U32 c)
 645 {
 646     return is_uni_cntrl(c);     /* XXX no locale support yet */
 647 }
 648
 649 bool
 650 Perl_is_uni_graph_lc(pTHX_ U32 c)
 651 {
 652     return is_uni_graph(c);     /* XXX no locale support yet */
 653 }
 654
 655 bool
 656 Perl_is_uni_print_lc(pTHX_ U32 c)
 657 {
 658     return is_uni_print(c);     /* XXX no locale support yet */
 659 }
 660
 661 bool
 662 Perl_is_uni_punct_lc(pTHX_ U32 c)
 663 {
 664     return is_uni_punct(c);     /* XXX no locale support yet */
 665 }
 666
 667 bool
 668 Perl_is_uni_xdigit_lc(pTHX_ U32 c)
 669 {
 670     return is_uni_xdigit(c);    /* XXX no locale support yet */
 671 }
 672
 673 U32
 674 Perl_to_uni_upper_lc(pTHX_ U32 c)
 675 {
 676     return to_uni_upper(c);     /* XXX no locale support yet */
 677 }
 678
 679 U32
 680 Perl_to_uni_title_lc(pTHX_ U32 c)
 681 {
 682     return to_uni_title(c);     /* XXX no locale support yet */
 683 }
 684
 685 U32
 686 Perl_to_uni_lower_lc(pTHX_ U32 c)
 687 {
 688     return to_uni_lower(c);     /* XXX no locale support yet */
 689 }
 690
 691 bool
 692 Perl_is_utf8_alnum(pTHX_ U8 *p)
 693 {
 694     if (!is_utf8_char(p))
 695         return FALSE;
 696     if (!PL_utf8_alnum)
 697         /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
 698          * descendant of isalnum(3), in other words, it doesn't
 699          * contain the '_'. --jhi */
 700         PL_utf8_alnum = swash_init("utf8", "IsWord", &PL_sv_undef, 0, 0);
 701     return swash_fetch(PL_utf8_alnum, p);
 702 /*    return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */
 703 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
 704     if (!PL_utf8_alnum)
 705         PL_utf8_alnum = swash_init("utf8", "",
 706             sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
 707     return swash_fetch(PL_utf8_alnum, p);
 708 #endif
 709 }
 710
 711 bool
 712 Perl_is_utf8_alnumc(pTHX_ U8 *p)
 713 {
 714     if (!is_utf8_char(p))
 715         return FALSE;
 716     if (!PL_utf8_alnum)
 717         PL_utf8_alnum = swash_init("utf8", "IsAlnumC", &PL_sv_undef, 0, 0);
 718     return swash_fetch(PL_utf8_alnum, p);
 719 /*    return is_utf8_alpha(p) || is_utf8_digit(p); */
 720 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
 721     if (!PL_utf8_alnum)
 722         PL_utf8_alnum = swash_init("utf8", "",
 723             sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
 724     return swash_fetch(PL_utf8_alnum, p);
 725 #endif
 726 }
 727
 728 bool
 729 Perl_is_utf8_idfirst(pTHX_ U8 *p)
 730 {
 731     return *p == '_' || is_utf8_alpha(p);
 732 }
 733
 734 bool
 735 Perl_is_utf8_alpha(pTHX_ U8 *p)
 736 {
 737     if (!is_utf8_char(p))
 738         return FALSE;
 739     if (!PL_utf8_alpha)
 740         PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0);
 741     return swash_fetch(PL_utf8_alpha, p);
 742 }
 743
 744 bool
 745 Perl_is_utf8_ascii(pTHX_ U8 *p)
 746 {
 747     if (!is_utf8_char(p))
 748         return FALSE;
 749     if (!PL_utf8_ascii)
 750         PL_utf8_ascii = swash_init("utf8", "IsAscii", &PL_sv_undef, 0, 0);
 751     return swash_fetch(PL_utf8_ascii, p);
 752 }
 753
 754 bool
 755 Perl_is_utf8_space(pTHX_ U8 *p)
 756 {
 757     if (!is_utf8_char(p))
 758         return FALSE;
 759     if (!PL_utf8_space)
 760         PL_utf8_space = swash_init("utf8", "IsSpace", &PL_sv_undef, 0, 0);
 761     return swash_fetch(PL_utf8_space, p);
 762 }
 763
 764 bool
 765 Perl_is_utf8_digit(pTHX_ U8 *p)
 766 {
 767     if (!is_utf8_char(p))
 768         return FALSE;
 769     if (!PL_utf8_digit)
 770         PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0);
 771     return swash_fetch(PL_utf8_digit, p);
 772 }
 773
 774 bool
 775 Perl_is_utf8_upper(pTHX_ U8 *p)
 776 {
 777     if (!is_utf8_char(p))
 778         return FALSE;
 779     if (!PL_utf8_upper)
 780         PL_utf8_upper = swash_init("utf8", "IsUpper", &PL_sv_undef, 0, 0);
 781     return swash_fetch(PL_utf8_upper, p);
 782 }
 783
 784 bool
 785 Perl_is_utf8_lower(pTHX_ U8 *p)
 786 {
 787     if (!is_utf8_char(p))
 788         return FALSE;
 789     if (!PL_utf8_lower)
 790         PL_utf8_lower = swash_init("utf8", "IsLower", &PL_sv_undef, 0, 0);
 791     return swash_fetch(PL_utf8_lower, p);
 792 }
 793
 794 bool
 795 Perl_is_utf8_cntrl(pTHX_ U8 *p)
 796 {
 797     if (!is_utf8_char(p))
 798         return FALSE;
 799     if (!PL_utf8_cntrl)
 800         PL_utf8_cntrl = swash_init("utf8", "IsCntrl", &PL_sv_undef, 0, 0);
 801     return swash_fetch(PL_utf8_cntrl, p);
 802 }
 803
 804 bool
 805 Perl_is_utf8_graph(pTHX_ U8 *p)
 806 {
 807     if (!is_utf8_char(p))
 808         return FALSE;
 809     if (!PL_utf8_graph)
 810         PL_utf8_graph = swash_init("utf8", "IsGraph", &PL_sv_undef, 0, 0);
 811     return swash_fetch(PL_utf8_graph, p);
 812 }
 813
 814 bool
 815 Perl_is_utf8_print(pTHX_ U8 *p)
 816 {
 817     if (!is_utf8_char(p))
 818         return FALSE;
 819     if (!PL_utf8_print)
 820         PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0);
 821     return swash_fetch(PL_utf8_print, p);
 822 }
 823
 824 bool
 825 Perl_is_utf8_punct(pTHX_ U8 *p)
 826 {
 827     if (!is_utf8_char(p))
 828         return FALSE;
 829     if (!PL_utf8_punct)
 830         PL_utf8_punct = swash_init("utf8", "IsPunct", &PL_sv_undef, 0, 0);
 831     return swash_fetch(PL_utf8_punct, p);
 832 }
 833
 834 bool
 835 Perl_is_utf8_xdigit(pTHX_ U8 *p)
 836 {
 837     if (!is_utf8_char(p))
 838         return FALSE;
 839     if (!PL_utf8_xdigit)
 840         PL_utf8_xdigit = swash_init("utf8", "IsXDigit", &PL_sv_undef, 0, 0);
 841     return swash_fetch(PL_utf8_xdigit, p);
 842 }
 843
 844 bool
 845 Perl_is_utf8_mark(pTHX_ U8 *p)
 846 {
 847     if (!is_utf8_char(p))
 848         return FALSE;
 849     if (!PL_utf8_mark)
 850         PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0);
 851     return swash_fetch(PL_utf8_mark, p);
 852 }
 853
 854 UV
 855 Perl_to_utf8_upper(pTHX_ U8 *p)
 856 {
 857     UV uv;
 858
 859     if (!PL_utf8_toupper)
 860         PL_utf8_toupper = swash_init("utf8", "ToUpper", &PL_sv_undef, 4, 0);
 861     uv = swash_fetch(PL_utf8_toupper, p);
 862     return uv ? uv : utf8_to_uv_chk(p,0,0);
 863 }
 864
 865 UV
 866 Perl_to_utf8_title(pTHX_ U8 *p)
 867 {
 868     UV uv;
 869
 870     if (!PL_utf8_totitle)
 871         PL_utf8_totitle = swash_init("utf8", "ToTitle", &PL_sv_undef, 4, 0);
 872     uv = swash_fetch(PL_utf8_totitle, p);
 873     return uv ? uv : utf8_to_uv_chk(p,0,0);
 874 }
 875
 876 UV
 877 Perl_to_utf8_lower(pTHX_ U8 *p)
 878 {
 879     UV uv;
 880
 881     if (!PL_utf8_tolower)
 882         PL_utf8_tolower = swash_init("utf8", "ToLower", &PL_sv_undef, 4, 0);
 883     uv = swash_fetch(PL_utf8_tolower, p);
 884     return uv ? uv : utf8_to_uv_chk(p,0,0);
 885 }
 886
 887 /* a "swash" is a swatch hash */
 888
 889 SV*
 890 Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
 891 {
 892     SV* retval;
 893     char tmpbuf[256];
 894     dSP;
 895
 896     if (!gv_stashpv(pkg, 0)) {  /* demand load utf8 */
 897         ENTER;
 898         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpv(pkg,0), Nullsv);
 899         LEAVE;
 900     }
 901     SPAGAIN;
 902     PUSHSTACKi(PERLSI_MAGIC);
 903     PUSHMARK(SP);
 904     EXTEND(SP,5);
 905     PUSHs(sv_2mortal(newSVpvn(pkg, strlen(pkg))));
 906     PUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
 907     PUSHs(listsv);
 908     PUSHs(sv_2mortal(newSViv(minbits)));
 909     PUSHs(sv_2mortal(newSViv(none)));
 910     PUTBACK;
 911     ENTER;
 912     SAVEI32(PL_hints);
 913     PL_hints = 0;
 914     save_re_context();
 915     if (PL_curcop == &PL_compiling)     /* XXX ought to be handled by lex_start */
 916         strncpy(tmpbuf, PL_tokenbuf, sizeof tmpbuf);
 917     if (call_method("SWASHNEW", G_SCALAR))
 918         retval = newSVsv(*PL_stack_sp--);
 919     else
 920         retval = &PL_sv_undef;
 921     LEAVE;
 922     POPSTACK;
 923     if (PL_curcop == &PL_compiling) {
 924         strncpy(PL_tokenbuf, tmpbuf, sizeof tmpbuf);
 925         PL_curcop->op_private = PL_hints;
 926     }
 927     if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV)
 928         Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
 929     return retval;
 930 }
 931
 932 UV
 933 Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr)
 934 {
 935     HV* hv = (HV*)SvRV(sv);
 936     U32 klen = UTF8SKIP(ptr) - 1;
 937     U32 off = ptr[klen] & 127;  /* NB: 64 bit always 0 when len > 1 */
 938     STRLEN slen;
 939     STRLEN needents = (klen ? 64 : 128);
 940     U8 *tmps;
 941     U32 bit;
 942     SV *retval;
 943
 944     /*
 945      * This single-entry cache saves about 1/3 of the utf8 overhead in test
 946      * suite.  (That is, only 7-8% overall over just a hash cache.  Still,
 947      * it's nothing to sniff at.)  Pity we usually come through at least
 948      * two function calls to get here...
 949      *
 950      * NB: this code assumes that swatches are never modified, once generated!
 951      */
 952
 953     if (hv == PL_last_swash_hv &&
 954         klen == PL_last_swash_klen &&
 955         (!klen || memEQ((char *)ptr,(char *)PL_last_swash_key,klen)) )
 956     {
 957         tmps = PL_last_swash_tmps;
 958         slen = PL_last_swash_slen;
 959     }
 960     else {
 961         /* Try our second-level swatch cache, kept in a hash. */
 962         SV** svp = hv_fetch(hv, (char*)ptr, klen, FALSE);
 963
 964         /* If not cached, generate it via utf8::SWASHGET */
 965         if (!svp || !SvPOK(*svp) || !(tmps = (U8*)SvPV(*svp, slen))) {
 966             dSP;
 967             ENTER;
 968             SAVETMPS;
 969             save_re_context();
 970             PUSHSTACKi(PERLSI_MAGIC);
 971             PUSHMARK(SP);
 972             EXTEND(SP,3);
 973             PUSHs((SV*)sv);
 974             PUSHs(sv_2mortal(newSViv(utf8_to_uv_chk(ptr, 0, 0) & ~(needents - 1))));
 975             PUSHs(sv_2mortal(newSViv(needents)));
 976             PUTBACK;
 977             if (call_method("SWASHGET", G_SCALAR))
 978                 retval = newSVsv(*PL_stack_sp--);
 979             else
 980                 retval = &PL_sv_undef;
 981             POPSTACK;
 982             FREETMPS;
 983             LEAVE;
 984             if (PL_curcop == &PL_compiling)
 985                 PL_curcop->op_private = PL_hints;
 986
 987             svp = hv_store(hv, (char*)ptr, klen, retval, 0);
 988
 989             if (!svp || !(tmps = (U8*)SvPV(*svp, slen)) || slen < 8)
 990                 Perl_croak(aTHX_ "SWASHGET didn't return result of proper length");
 991         }
 992
 993         PL_last_swash_hv = hv;
 994         PL_last_swash_klen = klen;
 995         PL_last_swash_tmps = tmps;
 996         PL_last_swash_slen = slen;
 997         if (klen)
 998             Copy(ptr, PL_last_swash_key, klen, U8);
 999     }
1000
1001     switch ((slen << 3) / needents) {
1002     case 1:
1003         bit = 1 << (off & 7);
1004         off >>= 3;
1005         return (tmps[off] & bit) != 0;
1006     case 8:
1007         return tmps[off];
1008     case 16:
1009         off <<= 1;
1010         return (tmps[off] << 8) + tmps[off + 1] ;
1011     case 32:
1012         off <<= 2;
1013         return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1014     }
1015     Perl_croak(aTHX_ "panic: swash_fetch");
1016     return 0;
1017 }