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