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