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