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