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