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