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