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