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