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