utf8.c

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