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