utf8.c

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