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