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 *|uvuni_to_utf8_flags|U8 *d|UV uv|UV flags
  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 = uvuni_to_utf8_flags(d, uv, flags);
  38
  39 or, in most cases,
  40
  41     d = uvuni_to_utf8(d, uv);
  42
  43 (which is equivalent to)
  44
  45     d = uvuni_to_utf8_flags(d, uv, 0);
  46
  47 is the recommended Unicode-aware way of saying
  48
  49     *(d++) = uv;
  50
  51 =cut
  52 */
  53
  54 U8 *
  55 Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
  56 {
  57     if (ckWARN_d(WARN_UTF8)) {
  58          if (UNICODE_IS_SURROGATE(uv) &&
  59              !(flags & UNICODE_ALLOW_SURROGATE))
  60               Perl_warner(aTHX_ WARN_UTF8, "UTF-16 surrogate 0x%04"UVxf, uv);
  61          else if (
  62                   ((uv >= 0xFDD0 && uv <= 0xFDEF &&
  63                     !(flags & UNICODE_ALLOW_FDD0))
  64                    ||
  65                    ((uv & 0xFFFF) == 0xFFFE &&
  66                     !(flags & UNICODE_ALLOW_FFFE))
  67                    ||
  68                    ((uv & 0xFFFF) == 0xFFFF &&
  69                     !(flags & UNICODE_ALLOW_FFFF))) &&
  70                   /* UNICODE_ALLOW_SUPER includes
  71                    * FFFEs and FFFFs beyond 0x10FFFF. */
  72                   ((uv <= PERL_UNICODE_MAX) ||
  73                    !(flags & UNICODE_ALLOW_SUPER))
  74                   )
  75               Perl_warner(aTHX_ WARN_UTF8,
  76                          "Unicode character 0x%04"UVxf" is illegal", uv);
  77     }
  78     if (UNI_IS_INVARIANT(uv)) {
  79         *d++ = UTF_TO_NATIVE(uv);
  80         return d;
  81     }
  82 #if defined(EBCDIC)
  83     else {
  84         STRLEN len  = UNISKIP(uv);
  85         U8 *p = d+len-1;
  86         while (p > d) {
  87             *p-- = UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
  88             uv >>= UTF_ACCUMULATION_SHIFT;
  89         }
  90         *p = UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
  91         return d+len;
  92     }
  93 #else /* Non loop style */
  94     if (uv < 0x800) {
  95         *d++ = (( uv >>  6)         | 0xc0);
  96         *d++ = (( uv        & 0x3f) | 0x80);
  97         return d;
  98     }
  99     if (uv < 0x10000) {
 100         *d++ = (( uv >> 12)         | 0xe0);
 101         *d++ = (((uv >>  6) & 0x3f) | 0x80);
 102         *d++ = (( uv        & 0x3f) | 0x80);
 103         return d;
 104     }
 105     if (uv < 0x200000) {
 106         *d++ = (( uv >> 18)         | 0xf0);
 107         *d++ = (((uv >> 12) & 0x3f) | 0x80);
 108         *d++ = (((uv >>  6) & 0x3f) | 0x80);
 109         *d++ = (( uv        & 0x3f) | 0x80);
 110         return d;
 111     }
 112     if (uv < 0x4000000) {
 113         *d++ = (( uv >> 24)         | 0xf8);
 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     if (uv < 0x80000000) {
 121         *d++ = (( uv >> 30)         | 0xfc);
 122         *d++ = (((uv >> 24) & 0x3f) | 0x80);
 123         *d++ = (((uv >> 18) & 0x3f) | 0x80);
 124         *d++ = (((uv >> 12) & 0x3f) | 0x80);
 125         *d++ = (((uv >>  6) & 0x3f) | 0x80);
 126         *d++ = (( uv        & 0x3f) | 0x80);
 127         return d;
 128     }
 129 #ifdef HAS_QUAD
 130     if (uv < UTF8_QUAD_MAX)
 131 #endif
 132     {
 133         *d++ =                        0xfe;     /* Can't match U+FEFF! */
 134         *d++ = (((uv >> 30) & 0x3f) | 0x80);
 135         *d++ = (((uv >> 24) & 0x3f) | 0x80);
 136         *d++ = (((uv >> 18) & 0x3f) | 0x80);
 137         *d++ = (((uv >> 12) & 0x3f) | 0x80);
 138         *d++ = (((uv >>  6) & 0x3f) | 0x80);
 139         *d++ = (( uv        & 0x3f) | 0x80);
 140         return d;
 141     }
 142 #ifdef HAS_QUAD
 143     {
 144         *d++ =                        0xff;     /* Can't match U+FFFE! */
 145         *d++ =                        0x80;     /* 6 Reserved bits */
 146         *d++ = (((uv >> 60) & 0x0f) | 0x80);    /* 2 Reserved bits */
 147         *d++ = (((uv >> 54) & 0x3f) | 0x80);
 148         *d++ = (((uv >> 48) & 0x3f) | 0x80);
 149         *d++ = (((uv >> 42) & 0x3f) | 0x80);
 150         *d++ = (((uv >> 36) & 0x3f) | 0x80);
 151         *d++ = (((uv >> 30) & 0x3f) | 0x80);
 152         *d++ = (((uv >> 24) & 0x3f) | 0x80);
 153         *d++ = (((uv >> 18) & 0x3f) | 0x80);
 154         *d++ = (((uv >> 12) & 0x3f) | 0x80);
 155         *d++ = (((uv >>  6) & 0x3f) | 0x80);
 156         *d++ = (( uv        & 0x3f) | 0x80);
 157         return d;
 158     }
 159 #endif
 160 #endif /* Loop style */
 161 }
 162
 163 U8 *
 164 Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
 165 {
 166     return Perl_uvuni_to_utf8_flags(aTHX_ d, uv, 0);
 167 }
 168
 169
 170 /*
 171 =for apidoc A|STRLEN|is_utf8_char|U8 *s
 172
 173 Tests if some arbitrary number of bytes begins in a valid UTF-8
 174 character.  Note that an INVARIANT (i.e. ASCII) character is a valid UTF-8 character.
 175 The actual number of bytes in the UTF-8 character will be returned if
 176 it is valid, otherwise 0.
 177
 178 =cut
 179 */
 180 STRLEN
 181 Perl_is_utf8_char(pTHX_ U8 *s)
 182 {
 183     U8 u = *s;
 184     STRLEN slen, len;
 185     UV uv, ouv;
 186
 187     if (UTF8_IS_INVARIANT(u))
 188         return 1;
 189
 190     if (!UTF8_IS_START(u))
 191         return 0;
 192
 193     len = UTF8SKIP(s);
 194
 195     if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
 196         return 0;
 197
 198     slen = len - 1;
 199     s++;
 200     u &= UTF_START_MASK(len);
 201     uv  = u;
 202     ouv = uv;
 203     while (slen--) {
 204         if (!UTF8_IS_CONTINUATION(*s))
 205             return 0;
 206         uv = UTF8_ACCUMULATE(uv, *s);
 207         if (uv < ouv)
 208             return 0;
 209         ouv = uv;
 210         s++;
 211     }
 212
 213     if (UNISKIP(uv) < len)
 214         return 0;
 215
 216     return len;
 217 }
 218
 219 /*
 220 =for apidoc A|bool|is_utf8_string|U8 *s|STRLEN len
 221
 222 Returns true if first C<len> bytes of the given string form a valid UTF8
 223 string, false otherwise.  Note that 'a valid UTF8 string' does not mean
 224 'a string that contains UTF8' because a valid ASCII string is a valid
 225 UTF8 string.
 226
 227 =cut
 228 */
 229
 230 bool
 231 Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len)
 232 {
 233     U8* x = s;
 234     U8* send;
 235     STRLEN c;
 236
 237     if (!len)
 238         len = strlen((char *)s);
 239     send = s + len;
 240
 241     while (x < send) {
 242         c = is_utf8_char(x);
 243         if (!c)
 244             return FALSE;
 245         x += c;
 246     }
 247     if (x != send)
 248         return FALSE;
 249
 250     return TRUE;
 251 }
 252
 253 /*
 254 =for apidoc A|UV|utf8n_to_uvuni|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
 255
 256 Bottom level UTF-8 decode routine.
 257 Returns the unicode code point value of the first character in the string C<s>
 258 which is assumed to be in UTF8 encoding and no longer than C<curlen>;
 259 C<retlen> will be set to the length, in bytes, of that character.
 260
 261 If C<s> does not point to a well-formed UTF8 character, the behaviour
 262 is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
 263 it is assumed that the caller will raise a warning, and this function
 264 will silently just set C<retlen> to C<-1> and return zero.  If the
 265 C<flags> does not contain UTF8_CHECK_ONLY, warnings about
 266 malformations will be given, C<retlen> will be set to the expected
 267 length of the UTF-8 character in bytes, and zero will be returned.
 268
 269 The C<flags> can also contain various flags to allow deviations from
 270 the strict UTF-8 encoding (see F<utf8.h>).
 271
 272 Most code should use utf8_to_uvchr() rather than call this directly.
 273
 274 =cut
 275 */
 276
 277 UV
 278 Perl_utf8n_to_uvuni(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
 279 {
 280     U8 *s0 = s;
 281     UV uv = *s, ouv = 0;
 282     STRLEN len = 1;
 283     bool dowarn = ckWARN_d(WARN_UTF8);
 284     UV startbyte = *s;
 285     STRLEN expectlen = 0;
 286     U32 warning = 0;
 287
 288 /* This list is a superset of the UTF8_ALLOW_XXX. */
 289
 290 #define UTF8_WARN_EMPTY                          1
 291 #define UTF8_WARN_CONTINUATION                   2
 292 #define UTF8_WARN_NON_CONTINUATION               3
 293 #define UTF8_WARN_FE_FF                          4
 294 #define UTF8_WARN_SHORT                          5
 295 #define UTF8_WARN_OVERFLOW                       6
 296 #define UTF8_WARN_SURROGATE                      7
 297 #define UTF8_WARN_BOM                            8
 298 #define UTF8_WARN_LONG                           9
 299 #define UTF8_WARN_FFFF                          10
 300
 301     if (curlen == 0 &&
 302         !(flags & UTF8_ALLOW_EMPTY)) {
 303         warning = UTF8_WARN_EMPTY;
 304         goto malformed;
 305     }
 306
 307     if (UTF8_IS_INVARIANT(uv)) {
 308         if (retlen)
 309             *retlen = 1;
 310         return (UV) (NATIVE_TO_UTF(*s));
 311     }
 312
 313     if (UTF8_IS_CONTINUATION(uv) &&
 314         !(flags & UTF8_ALLOW_CONTINUATION)) {
 315         warning = UTF8_WARN_CONTINUATION;
 316         goto malformed;
 317     }
 318
 319     if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
 320         !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
 321         warning = UTF8_WARN_NON_CONTINUATION;
 322         goto malformed;
 323     }
 324
 325 #ifdef EBCDIC
 326     uv = NATIVE_TO_UTF(uv);
 327 #else
 328     if ((uv == 0xfe || uv == 0xff) &&
 329         !(flags & UTF8_ALLOW_FE_FF)) {
 330         warning = UTF8_WARN_FE_FF;
 331         goto malformed;
 332     }
 333 #endif
 334
 335     if      (!(uv & 0x20))      { len =  2; uv &= 0x1f; }
 336     else if (!(uv & 0x10))      { len =  3; uv &= 0x0f; }
 337     else if (!(uv & 0x08))      { len =  4; uv &= 0x07; }
 338     else if (!(uv & 0x04))      { len =  5; uv &= 0x03; }
 339 #ifdef EBCDIC
 340     else if (!(uv & 0x02))      { len =  6; uv &= 0x01; }
 341     else                        { len =  7; uv &= 0x01; }
 342 #else
 343     else if (!(uv & 0x02))      { len =  6; uv &= 0x01; }
 344     else if (!(uv & 0x01))      { len =  7; uv = 0; }
 345     else                        { len = 13; uv = 0; } /* whoa! */
 346 #endif
 347
 348     if (retlen)
 349         *retlen = len;
 350
 351     expectlen = len;
 352
 353     if ((curlen < expectlen) &&
 354         !(flags & UTF8_ALLOW_SHORT)) {
 355         warning = UTF8_WARN_SHORT;
 356         goto malformed;
 357     }
 358
 359     len--;
 360     s++;
 361     ouv = uv;
 362
 363     while (len--) {
 364         if (!UTF8_IS_CONTINUATION(*s) &&
 365             !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
 366             s--;
 367             warning = UTF8_WARN_NON_CONTINUATION;
 368             goto malformed;
 369         }
 370         else
 371             uv = UTF8_ACCUMULATE(uv, *s);
 372         if (!(uv > ouv)) {
 373             /* These cannot be allowed. */
 374             if (uv == ouv) {
 375                 if (!(flags & UTF8_ALLOW_LONG)) {
 376                     warning = UTF8_WARN_LONG;
 377                     goto malformed;
 378                 }
 379             }
 380             else { /* uv < ouv */
 381                 /* This cannot be allowed. */
 382                 warning = UTF8_WARN_OVERFLOW;
 383                 goto malformed;
 384             }
 385         }
 386         s++;
 387         ouv = uv;
 388     }
 389
 390     if (UNICODE_IS_SURROGATE(uv) &&
 391         !(flags & UTF8_ALLOW_SURROGATE)) {
 392         warning = UTF8_WARN_SURROGATE;
 393         goto malformed;
 394     } else if (UNICODE_IS_BYTE_ORDER_MARK(uv) &&
 395                !(flags & UTF8_ALLOW_BOM)) {
 396         warning = UTF8_WARN_BOM;
 397         goto malformed;
 398     } else if ((expectlen > UNISKIP(uv)) &&
 399                !(flags & UTF8_ALLOW_LONG)) {
 400         warning = UTF8_WARN_LONG;
 401         goto malformed;
 402     } else if (UNICODE_IS_ILLEGAL(uv) &&
 403                !(flags & UTF8_ALLOW_FFFF)) {
 404         warning = UTF8_WARN_FFFF;
 405         goto malformed;
 406     }
 407
 408     return uv;
 409
 410 malformed:
 411
 412     if (flags & UTF8_CHECK_ONLY) {
 413         if (retlen)
 414             *retlen = -1;
 415         return 0;
 416     }
 417
 418     if (dowarn) {
 419         SV* sv = sv_2mortal(newSVpv("Malformed UTF-8 character ", 0));
 420
 421         switch (warning) {
 422         case 0: /* Intentionally empty. */ break;
 423         case UTF8_WARN_EMPTY:
 424             Perl_sv_catpvf(aTHX_ sv, "(empty string)");
 425             break;
 426         case UTF8_WARN_CONTINUATION:
 427             Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
 428             break;
 429         case UTF8_WARN_NON_CONTINUATION:
 430             if (s == s0)
 431                 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
 432                            (UV)s[1], startbyte);
 433             else
 434                 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
 435                            (UV)s[1], s - s0, s - s0 > 1 ? "s" : "", startbyte, expectlen);
 436
 437             break;
 438         case UTF8_WARN_FE_FF:
 439             Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
 440             break;
 441         case UTF8_WARN_SHORT:
 442             Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
 443                            curlen, curlen == 1 ? "" : "s", expectlen, startbyte);
 444             expectlen = curlen;         /* distance for caller to skip */
 445             break;
 446         case UTF8_WARN_OVERFLOW:
 447             Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
 448                            ouv, *s, startbyte);
 449             break;
 450         case UTF8_WARN_SURROGATE:
 451             Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
 452             break;
 453         case UTF8_WARN_BOM:
 454             Perl_sv_catpvf(aTHX_ sv, "(byte order mark 0x%04"UVxf")", uv);
 455             break;
 456         case UTF8_WARN_LONG:
 457             Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
 458                            expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
 459             break;
 460         case UTF8_WARN_FFFF:
 461             Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
 462             break;
 463         default:
 464             Perl_sv_catpvf(aTHX_ sv, "(unknown reason)");
 465             break;
 466         }
 467
 468         if (warning) {
 469             char *s = SvPVX(sv);
 470
 471             if (PL_op)
 472                 Perl_warner(aTHX_ WARN_UTF8,
 473                             "%s in %s", s,  OP_DESC(PL_op));
 474             else
 475                 Perl_warner(aTHX_ WARN_UTF8, "%s", s);
 476         }
 477     }
 478
 479     if (retlen)
 480         *retlen = expectlen ? expectlen : len;
 481
 482     return 0;
 483 }
 484
 485 /*
 486 =for apidoc A|UV|utf8_to_uvchr|U8 *s|STRLEN *retlen
 487
 488 Returns the native character value of the first character in the string C<s>
 489 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
 490 length, in bytes, of that character.
 491
 492 If C<s> does not point to a well-formed UTF8 character, zero is
 493 returned and retlen is set, if possible, to -1.
 494
 495 =cut
 496 */
 497
 498 UV
 499 Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
 500 {
 501     return Perl_utf8n_to_uvchr(aTHX_ s, UTF8_MAXLEN, retlen, 0);
 502 }
 503
 504 /*
 505 =for apidoc A|UV|utf8_to_uvuni|U8 *s|STRLEN *retlen
 506
 507 Returns the Unicode code point of the first character in the string C<s>
 508 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
 509 length, in bytes, of that character.
 510
 511 This function should only be used when returned UV is considered
 512 an index into the Unicode semantic tables (e.g. swashes).
 513
 514 If C<s> does not point to a well-formed UTF8 character, zero is
 515 returned and retlen is set, if possible, to -1.
 516
 517 =cut
 518 */
 519
 520 UV
 521 Perl_utf8_to_uvuni(pTHX_ U8 *s, STRLEN *retlen)
 522 {
 523     /* Call the low level routine asking for checks */
 524     return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXLEN, retlen, 0);
 525 }
 526
 527 /*
 528 =for apidoc A|STRLEN|utf8_length|U8 *s|U8 *e
 529
 530 Return the length of the UTF-8 char encoded string C<s> in characters.
 531 Stops at C<e> (inclusive).  If C<e E<lt> s> or if the scan would end
 532 up past C<e>, croaks.
 533
 534 =cut
 535 */
 536
 537 STRLEN
 538 Perl_utf8_length(pTHX_ U8 *s, U8 *e)
 539 {
 540     STRLEN len = 0;
 541
 542     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
 543      * the bitops (especially ~) can create illegal UTF-8.
 544      * In other words: in Perl UTF-8 is not just for Unicode. */
 545
 546     if (e < s)
 547         Perl_croak(aTHX_ "panic: utf8_length: unexpected end");
 548     while (s < e) {
 549         U8 t = UTF8SKIP(s);
 550
 551         if (e - s < t)
 552             Perl_croak(aTHX_ "panic: utf8_length: unaligned end");
 553         s += t;
 554         len++;
 555     }
 556
 557     return len;
 558 }
 559
 560 /*
 561 =for apidoc A|IV|utf8_distance|U8 *a|U8 *b
 562
 563 Returns the number of UTF8 characters between the UTF-8 pointers C<a>
 564 and C<b>.
 565
 566 WARNING: use only if you *know* that the pointers point inside the
 567 same UTF-8 buffer.
 568
 569 =cut
 570 */
 571
 572 IV
 573 Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
 574 {
 575     IV off = 0;
 576
 577     /* Note: cannot use UTF8_IS_...() too eagerly here since  e.g.
 578      * the bitops (especially ~) can create illegal UTF-8.
 579      * In other words: in Perl UTF-8 is not just for Unicode. */
 580
 581     if (a < b) {
 582         while (a < b) {
 583             U8 c = UTF8SKIP(a);
 584
 585             if (b - a < c)
 586                 Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
 587             a += c;
 588             off--;
 589         }
 590     }
 591     else {
 592         while (b < a) {
 593             U8 c = UTF8SKIP(b);
 594
 595             if (a - b < c)
 596                 Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
 597             b += c;
 598             off++;
 599         }
 600     }
 601
 602     return off;
 603 }
 604
 605 /*
 606 =for apidoc A|U8 *|utf8_hop|U8 *s|I32 off
 607
 608 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
 609 forward or backward.
 610
 611 WARNING: do not use the following unless you *know* C<off> is within
 612 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
 613 on the first byte of character or just after the last byte of a character.
 614
 615 =cut
 616 */
 617
 618 U8 *
 619 Perl_utf8_hop(pTHX_ U8 *s, I32 off)
 620 {
 621     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
 622      * the bitops (especially ~) can create illegal UTF-8.
 623      * In other words: in Perl UTF-8 is not just for Unicode. */
 624
 625     if (off >= 0) {
 626         while (off--)
 627             s += UTF8SKIP(s);
 628     }
 629     else {
 630         while (off++) {
 631             s--;
 632             while (UTF8_IS_CONTINUATION(*s))
 633                 s--;
 634         }
 635     }
 636     return s;
 637 }
 638
 639 /*
 640 =for apidoc A|U8 *|utf8_to_bytes|U8 *s|STRLEN *len
 641
 642 Converts a string C<s> of length C<len> from UTF8 into byte encoding.
 643 Unlike C<bytes_to_utf8>, this over-writes the original string, and
 644 updates len to contain the new length.
 645 Returns zero on failure, setting C<len> to -1.
 646
 647 =cut
 648 */
 649
 650 U8 *
 651 Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
 652 {
 653     U8 *send;
 654     U8 *d;
 655     U8 *save = s;
 656
 657     /* ensure valid UTF8 and chars < 256 before updating string */
 658     for (send = s + *len; s < send; ) {
 659         U8 c = *s++;
 660
 661         if (!UTF8_IS_INVARIANT(c) &&
 662             (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
 663              || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
 664             *len = -1;
 665             return 0;
 666         }
 667     }
 668
 669     d = s = save;
 670     while (s < send) {
 671         STRLEN ulen;
 672         *d++ = (U8)utf8_to_uvchr(s, &ulen);
 673         s += ulen;
 674     }
 675     *d = '\0';
 676     *len = d - save;
 677     return save;
 678 }
 679
 680 /*
 681 =for apidoc A|U8 *|bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8
 682
 683 Converts a string C<s> of length C<len> from UTF8 into byte encoding.
 684 Unlike <utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
 685 the newly-created string, and updates C<len> to contain the new
 686 length.  Returns the original string if no conversion occurs, C<len>
 687 is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
 688 0 if C<s> is converted or contains all 7bit characters.
 689
 690 =cut
 691 */
 692
 693 U8 *
 694 Perl_bytes_from_utf8(pTHX_ U8 *s, STRLEN *len, bool *is_utf8)
 695 {
 696     U8 *d;
 697     U8 *start = s;
 698     U8 *send;
 699     I32 count = 0;
 700
 701     if (!*is_utf8)
 702         return start;
 703
 704     /* ensure valid UTF8 and chars < 256 before converting string */
 705     for (send = s + *len; s < send;) {
 706         U8 c = *s++;
 707         if (!UTF8_IS_INVARIANT(c)) {
 708             if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
 709                 (c = *s++) && UTF8_IS_CONTINUATION(c))
 710                 count++;
 711             else
 712                 return start;
 713         }
 714     }
 715
 716     *is_utf8 = 0;
 717
 718     Newz(801, d, (*len) - count + 1, U8);
 719     s = start; start = d;
 720     while (s < send) {
 721         U8 c = *s++;
 722         if (!UTF8_IS_INVARIANT(c)) {
 723             /* Then it is two-byte encoded */
 724             c = UTF8_ACCUMULATE(NATIVE_TO_UTF(c), *s++);
 725             c = ASCII_TO_NATIVE(c);
 726         }
 727         *d++ = c;
 728     }
 729     *d = '\0';
 730     *len = d - start;
 731     return start;
 732 }
 733
 734 /*
 735 =for apidoc A|U8 *|bytes_to_utf8|U8 *s|STRLEN *len
 736
 737 Converts a string C<s> of length C<len> from ASCII into UTF8 encoding.
 738 Returns a pointer to the newly-created string, and sets C<len> to
 739 reflect the new length.
 740
 741 =cut
 742 */
 743
 744 U8*
 745 Perl_bytes_to_utf8(pTHX_ U8 *s, STRLEN *len)
 746 {
 747     U8 *send;
 748     U8 *d;
 749     U8 *dst;
 750     send = s + (*len);
 751
 752     Newz(801, d, (*len) * 2 + 1, U8);
 753     dst = d;
 754
 755     while (s < send) {
 756         UV uv = NATIVE_TO_ASCII(*s++);
 757         if (UNI_IS_INVARIANT(uv))
 758             *d++ = UTF_TO_NATIVE(uv);
 759         else {
 760             *d++ = UTF8_EIGHT_BIT_HI(uv);
 761             *d++ = UTF8_EIGHT_BIT_LO(uv);
 762         }
 763     }
 764     *d = '\0';
 765     *len = d-dst;
 766     return dst;
 767 }
 768
 769 /*
 770  * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
 771  *
 772  * Destination must be pre-extended to 3/2 source.  Do not use in-place.
 773  * We optimize for native, for obvious reasons. */
 774
 775 U8*
 776 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 777 {
 778     U8* pend;
 779     U8* dstart = d;
 780
 781     if (bytelen & 1)
 782         Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen");
 783
 784     pend = p + bytelen;
 785
 786     while (p < pend) {
 787         UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
 788         p += 2;
 789         if (uv < 0x80) {
 790             *d++ = uv;
 791             continue;
 792         }
 793         if (uv < 0x800) {
 794             *d++ = (( uv >>  6)         | 0xc0);
 795             *d++ = (( uv        & 0x3f) | 0x80);
 796             continue;
 797         }
 798         if (uv >= 0xd800 && uv < 0xdbff) {      /* surrogates */
 799             UV low = *p++;
 800             if (low < 0xdc00 || low >= 0xdfff)
 801                 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
 802             uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
 803         }
 804         if (uv < 0x10000) {
 805             *d++ = (( uv >> 12)         | 0xe0);
 806             *d++ = (((uv >>  6) & 0x3f) | 0x80);
 807             *d++ = (( uv        & 0x3f) | 0x80);
 808             continue;
 809         }
 810         else {
 811             *d++ = (( uv >> 18)         | 0xf0);
 812             *d++ = (((uv >> 12) & 0x3f) | 0x80);
 813             *d++ = (((uv >>  6) & 0x3f) | 0x80);
 814             *d++ = (( uv        & 0x3f) | 0x80);
 815             continue;
 816         }
 817     }
 818     *newlen = d - dstart;
 819     return d;
 820 }
 821
 822 /* Note: this one is slightly destructive of the source. */
 823
 824 U8*
 825 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 826 {
 827     U8* s = (U8*)p;
 828     U8* send = s + bytelen;
 829     while (s < send) {
 830         U8 tmp = s[0];
 831         s[0] = s[1];
 832         s[1] = tmp;
 833         s += 2;
 834     }
 835     return utf16_to_utf8(p, d, bytelen, newlen);
 836 }
 837
 838 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
 839
 840 bool
 841 Perl_is_uni_alnum(pTHX_ UV c)
 842 {
 843     U8 tmpbuf[UTF8_MAXLEN+1];
 844     uvchr_to_utf8(tmpbuf, (UV)c);
 845     return is_utf8_alnum(tmpbuf);
 846 }
 847
 848 bool
 849 Perl_is_uni_alnumc(pTHX_ UV c)
 850 {
 851     U8 tmpbuf[UTF8_MAXLEN+1];
 852     uvchr_to_utf8(tmpbuf, (UV)c);
 853     return is_utf8_alnumc(tmpbuf);
 854 }
 855
 856 bool
 857 Perl_is_uni_idfirst(pTHX_ UV c)
 858 {
 859     U8 tmpbuf[UTF8_MAXLEN+1];
 860     uvchr_to_utf8(tmpbuf, (UV)c);
 861     return is_utf8_idfirst(tmpbuf);
 862 }
 863
 864 bool
 865 Perl_is_uni_alpha(pTHX_ UV c)
 866 {
 867     U8 tmpbuf[UTF8_MAXLEN+1];
 868     uvchr_to_utf8(tmpbuf, (UV)c);
 869     return is_utf8_alpha(tmpbuf);
 870 }
 871
 872 bool
 873 Perl_is_uni_ascii(pTHX_ UV c)
 874 {
 875     U8 tmpbuf[UTF8_MAXLEN+1];
 876     uvchr_to_utf8(tmpbuf, (UV)c);
 877     return is_utf8_ascii(tmpbuf);
 878 }
 879
 880 bool
 881 Perl_is_uni_space(pTHX_ UV c)
 882 {
 883     U8 tmpbuf[UTF8_MAXLEN+1];
 884     uvchr_to_utf8(tmpbuf, (UV)c);
 885     return is_utf8_space(tmpbuf);
 886 }
 887
 888 bool
 889 Perl_is_uni_digit(pTHX_ UV c)
 890 {
 891     U8 tmpbuf[UTF8_MAXLEN+1];
 892     uvchr_to_utf8(tmpbuf, (UV)c);
 893     return is_utf8_digit(tmpbuf);
 894 }
 895
 896 bool
 897 Perl_is_uni_upper(pTHX_ UV c)
 898 {
 899     U8 tmpbuf[UTF8_MAXLEN+1];
 900     uvchr_to_utf8(tmpbuf, (UV)c);
 901     return is_utf8_upper(tmpbuf);
 902 }
 903
 904 bool
 905 Perl_is_uni_lower(pTHX_ UV c)
 906 {
 907     U8 tmpbuf[UTF8_MAXLEN+1];
 908     uvchr_to_utf8(tmpbuf, (UV)c);
 909     return is_utf8_lower(tmpbuf);
 910 }
 911
 912 bool
 913 Perl_is_uni_cntrl(pTHX_ UV c)
 914 {
 915     U8 tmpbuf[UTF8_MAXLEN+1];
 916     uvchr_to_utf8(tmpbuf, (UV)c);
 917     return is_utf8_cntrl(tmpbuf);
 918 }
 919
 920 bool
 921 Perl_is_uni_graph(pTHX_ UV c)
 922 {
 923     U8 tmpbuf[UTF8_MAXLEN+1];
 924     uvchr_to_utf8(tmpbuf, (UV)c);
 925     return is_utf8_graph(tmpbuf);
 926 }
 927
 928 bool
 929 Perl_is_uni_print(pTHX_ UV c)
 930 {
 931     U8 tmpbuf[UTF8_MAXLEN+1];
 932     uvchr_to_utf8(tmpbuf, (UV)c);
 933     return is_utf8_print(tmpbuf);
 934 }
 935
 936 bool
 937 Perl_is_uni_punct(pTHX_ UV c)
 938 {
 939     U8 tmpbuf[UTF8_MAXLEN+1];
 940     uvchr_to_utf8(tmpbuf, (UV)c);
 941     return is_utf8_punct(tmpbuf);
 942 }
 943
 944 bool
 945 Perl_is_uni_xdigit(pTHX_ UV c)
 946 {
 947     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
 948     uvchr_to_utf8(tmpbuf, (UV)c);
 949     return is_utf8_xdigit(tmpbuf);
 950 }
 951
 952 UV
 953 Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
 954 {
 955     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
 956     uvchr_to_utf8(tmpbuf, (UV)c);
 957     return to_utf8_upper(tmpbuf, p, lenp);
 958 }
 959
 960 UV
 961 Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
 962 {
 963     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
 964     uvchr_to_utf8(tmpbuf, (UV)c);
 965     return to_utf8_title(tmpbuf, p, lenp);
 966 }
 967
 968 UV
 969 Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
 970 {
 971     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
 972     uvchr_to_utf8(tmpbuf, (UV)c);
 973     return to_utf8_lower(tmpbuf, p, lenp);
 974 }
 975
 976 UV
 977 Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
 978 {
 979     U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
 980     uvchr_to_utf8(tmpbuf, (UV)c);
 981     return to_utf8_fold(tmpbuf, p, lenp);
 982 }
 983
 984 /* for now these all assume no locale info available for Unicode > 255 */
 985
 986 bool
 987 Perl_is_uni_alnum_lc(pTHX_ UV c)
 988 {
 989     return is_uni_alnum(c);     /* XXX no locale support yet */
 990 }
 991
 992 bool
 993 Perl_is_uni_alnumc_lc(pTHX_ UV c)
 994 {
 995     return is_uni_alnumc(c);    /* XXX no locale support yet */
 996 }
 997
 998 bool
 999 Perl_is_uni_idfirst_lc(pTHX_ UV c)
1000 {
1001     return is_uni_idfirst(c);   /* XXX no locale support yet */
1002 }
1003
1004 bool
1005 Perl_is_uni_alpha_lc(pTHX_ UV c)
1006 {
1007     return is_uni_alpha(c);     /* XXX no locale support yet */
1008 }
1009
1010 bool
1011 Perl_is_uni_ascii_lc(pTHX_ UV c)
1012 {
1013     return is_uni_ascii(c);     /* XXX no locale support yet */
1014 }
1015
1016 bool
1017 Perl_is_uni_space_lc(pTHX_ UV c)
1018 {
1019     return is_uni_space(c);     /* XXX no locale support yet */
1020 }
1021
1022 bool
1023 Perl_is_uni_digit_lc(pTHX_ UV c)
1024 {
1025     return is_uni_digit(c);     /* XXX no locale support yet */
1026 }
1027
1028 bool
1029 Perl_is_uni_upper_lc(pTHX_ UV c)
1030 {
1031     return is_uni_upper(c);     /* XXX no locale support yet */
1032 }
1033
1034 bool
1035 Perl_is_uni_lower_lc(pTHX_ UV c)
1036 {
1037     return is_uni_lower(c);     /* XXX no locale support yet */
1038 }
1039
1040 bool
1041 Perl_is_uni_cntrl_lc(pTHX_ UV c)
1042 {
1043     return is_uni_cntrl(c);     /* XXX no locale support yet */
1044 }
1045
1046 bool
1047 Perl_is_uni_graph_lc(pTHX_ UV c)
1048 {
1049     return is_uni_graph(c);     /* XXX no locale support yet */
1050 }
1051
1052 bool
1053 Perl_is_uni_print_lc(pTHX_ UV c)
1054 {
1055     return is_uni_print(c);     /* XXX no locale support yet */
1056 }
1057
1058 bool
1059 Perl_is_uni_punct_lc(pTHX_ UV c)
1060 {
1061     return is_uni_punct(c);     /* XXX no locale support yet */
1062 }
1063
1064 bool
1065 Perl_is_uni_xdigit_lc(pTHX_ UV c)
1066 {
1067     return is_uni_xdigit(c);    /* XXX no locale support yet */
1068 }
1069
1070 U32
1071 Perl_to_uni_upper_lc(pTHX_ U32 c)
1072 {
1073     /* XXX returns only the first character -- do not use XXX */
1074     /* XXX no locale support yet */
1075     STRLEN len;
1076     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
1077     return (U32)to_uni_upper(c, tmpbuf, &len);
1078 }
1079
1080 U32
1081 Perl_to_uni_title_lc(pTHX_ U32 c)
1082 {
1083     /* XXX returns only the first character XXX -- do not use XXX */
1084     /* XXX no locale support yet */
1085     STRLEN len;
1086     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
1087     return (U32)to_uni_title(c, tmpbuf, &len);
1088 }
1089
1090 U32
1091 Perl_to_uni_lower_lc(pTHX_ U32 c)
1092 {
1093     /* XXX returns only the first character -- do not use XXX */
1094     /* XXX no locale support yet */
1095     STRLEN len;
1096     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
1097     return (U32)to_uni_lower(c, tmpbuf, &len);
1098 }
1099
1100 bool
1101 Perl_is_utf8_alnum(pTHX_ U8 *p)
1102 {
1103     if (!is_utf8_char(p))
1104         return FALSE;
1105     if (!PL_utf8_alnum)
1106         /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1107          * descendant of isalnum(3), in other words, it doesn't
1108          * contain the '_'. --jhi */
1109         PL_utf8_alnum = swash_init("utf8", "IsWord", &PL_sv_undef, 0, 0);
1110     return swash_fetch(PL_utf8_alnum, p, TRUE);
1111 /*    return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */
1112 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
1113     if (!PL_utf8_alnum)
1114         PL_utf8_alnum = swash_init("utf8", "",
1115             sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
1116     return swash_fetch(PL_utf8_alnum, p, TRUE);
1117 #endif
1118 }
1119
1120 bool
1121 Perl_is_utf8_alnumc(pTHX_ U8 *p)
1122 {
1123     if (!is_utf8_char(p))
1124         return FALSE;
1125     if (!PL_utf8_alnum)
1126         PL_utf8_alnum = swash_init("utf8", "IsAlnumC", &PL_sv_undef, 0, 0);
1127     return swash_fetch(PL_utf8_alnum, p, TRUE);
1128 /*    return is_utf8_alpha(p) || is_utf8_digit(p); */
1129 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
1130     if (!PL_utf8_alnum)
1131         PL_utf8_alnum = swash_init("utf8", "",
1132             sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
1133     return swash_fetch(PL_utf8_alnum, p, TRUE);
1134 #endif
1135 }
1136
1137 bool
1138 Perl_is_utf8_idfirst(pTHX_ U8 *p)
1139 {
1140     return *p == '_' || is_utf8_alpha(p);
1141 }
1142
1143 bool
1144 Perl_is_utf8_alpha(pTHX_ U8 *p)
1145 {
1146     if (!is_utf8_char(p))
1147         return FALSE;
1148     if (!PL_utf8_alpha)
1149         PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0);
1150     return swash_fetch(PL_utf8_alpha, p, TRUE);
1151 }
1152
1153 bool
1154 Perl_is_utf8_ascii(pTHX_ U8 *p)
1155 {
1156     if (!is_utf8_char(p))
1157         return FALSE;
1158     if (!PL_utf8_ascii)
1159         PL_utf8_ascii = swash_init("utf8", "IsAscii", &PL_sv_undef, 0, 0);
1160     return swash_fetch(PL_utf8_ascii, p, TRUE);
1161 }
1162
1163 bool
1164 Perl_is_utf8_space(pTHX_ U8 *p)
1165 {
1166     if (!is_utf8_char(p))
1167         return FALSE;
1168     if (!PL_utf8_space)
1169         PL_utf8_space = swash_init("utf8", "IsSpacePerl", &PL_sv_undef, 0, 0);
1170     return swash_fetch(PL_utf8_space, p, TRUE);
1171 }
1172
1173 bool
1174 Perl_is_utf8_digit(pTHX_ U8 *p)
1175 {
1176     if (!is_utf8_char(p))
1177         return FALSE;
1178     if (!PL_utf8_digit)
1179         PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0);
1180     return swash_fetch(PL_utf8_digit, p, TRUE);
1181 }
1182
1183 bool
1184 Perl_is_utf8_upper(pTHX_ U8 *p)
1185 {
1186     if (!is_utf8_char(p))
1187         return FALSE;
1188     if (!PL_utf8_upper)
1189         PL_utf8_upper = swash_init("utf8", "IsUpper", &PL_sv_undef, 0, 0);
1190     return swash_fetch(PL_utf8_upper, p, TRUE);
1191 }
1192
1193 bool
1194 Perl_is_utf8_lower(pTHX_ U8 *p)
1195 {
1196     if (!is_utf8_char(p))
1197         return FALSE;
1198     if (!PL_utf8_lower)
1199         PL_utf8_lower = swash_init("utf8", "IsLower", &PL_sv_undef, 0, 0);
1200     return swash_fetch(PL_utf8_lower, p, TRUE);
1201 }
1202
1203 bool
1204 Perl_is_utf8_cntrl(pTHX_ U8 *p)
1205 {
1206     if (!is_utf8_char(p))
1207         return FALSE;
1208     if (!PL_utf8_cntrl)
1209         PL_utf8_cntrl = swash_init("utf8", "IsCntrl", &PL_sv_undef, 0, 0);
1210     return swash_fetch(PL_utf8_cntrl, p, TRUE);
1211 }
1212
1213 bool
1214 Perl_is_utf8_graph(pTHX_ U8 *p)
1215 {
1216     if (!is_utf8_char(p))
1217         return FALSE;
1218     if (!PL_utf8_graph)
1219         PL_utf8_graph = swash_init("utf8", "IsGraph", &PL_sv_undef, 0, 0);
1220     return swash_fetch(PL_utf8_graph, p, TRUE);
1221 }
1222
1223 bool
1224 Perl_is_utf8_print(pTHX_ U8 *p)
1225 {
1226     if (!is_utf8_char(p))
1227         return FALSE;
1228     if (!PL_utf8_print)
1229         PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0);
1230     return swash_fetch(PL_utf8_print, p, TRUE);
1231 }
1232
1233 bool
1234 Perl_is_utf8_punct(pTHX_ U8 *p)
1235 {
1236     if (!is_utf8_char(p))
1237         return FALSE;
1238     if (!PL_utf8_punct)
1239         PL_utf8_punct = swash_init("utf8", "IsPunct", &PL_sv_undef, 0, 0);
1240     return swash_fetch(PL_utf8_punct, p, TRUE);
1241 }
1242
1243 bool
1244 Perl_is_utf8_xdigit(pTHX_ U8 *p)
1245 {
1246     if (!is_utf8_char(p))
1247         return FALSE;
1248     if (!PL_utf8_xdigit)
1249         PL_utf8_xdigit = swash_init("utf8", "IsXDigit", &PL_sv_undef, 0, 0);
1250     return swash_fetch(PL_utf8_xdigit, p, TRUE);
1251 }
1252
1253 bool
1254 Perl_is_utf8_mark(pTHX_ U8 *p)
1255 {
1256     if (!is_utf8_char(p))
1257         return FALSE;
1258     if (!PL_utf8_mark)
1259         PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0);
1260     return swash_fetch(PL_utf8_mark, p, TRUE);
1261 }
1262
1263 /*
1264 =for apidoc A|UV|to_utf8_case|U8 *p|U8* ustrp|STRLEN *lenp|SV **swash|char *normal|char *special
1265
1266 The "p" contains the pointer to the UTF-8 string encoding
1267 the character that is being converted.
1268
1269 The "ustrp" is a pointer to the character buffer to put the
1270 conversion result to.  The "lenp" is a pointer to the length
1271 of the result.
1272
1273 The "swash" is a pointer to the swash to use.
1274
1275 The "normal" is a string like "ToLower" which means the swash
1276 $utf8::ToLower, which is stored in lib/unicore/To/Lower.pl,
1277 and loaded by SWASHGET, using lib/utf8_heavy.pl.
1278
1279 The "special" is a string like "utf8::ToSpecLower", which means
1280 the hash %utf8::ToSpecLower, which is stored in the same file,
1281 lib/unicore/To/Lower.pl, and also loaded by SWASHGET.  The access
1282 to the hash is by Perl_to_utf8_case().
1283
1284 =cut
1285  */
1286
1287 UV
1288 Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp,char *normal, char *special)
1289 {
1290     UV uv;
1291
1292     if (!*swashp)
1293         *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1294     uv = swash_fetch(*swashp, p, TRUE);
1295     if (uv)
1296          uv = UNI_TO_NATIVE(uv);
1297     else {
1298          HV *hv;
1299          SV *keysv;
1300          HE *he;
1301
1302          uv = utf8_to_uvchr(p, 0);
1303
1304          if ((hv    = get_hv(special, FALSE)) &&
1305              (keysv = sv_2mortal(Perl_newSVpvf(aTHX_ "%04"UVXf, uv))) &&
1306              (he    = hv_fetch_ent(hv, keysv, FALSE, 0))) {
1307               SV *val = HeVAL(he);
1308               char *s = SvPV(val, *lenp);
1309               U8 c = *(U8*)s;
1310               if (*lenp > 1 || UNI_IS_INVARIANT(c))
1311                    Copy(s, ustrp, *lenp, U8);
1312               else {
1313                    /* something in the 0x80..0xFF range */
1314                    ustrp[0] = UTF8_EIGHT_BIT_HI(c);
1315                    ustrp[1] = UTF8_EIGHT_BIT_LO(c);
1316                    *lenp = 2;
1317               }
1318               return 0;
1319          }
1320     }
1321     if (lenp)
1322        *lenp = UNISKIP(uv);
1323     uvuni_to_utf8(ustrp, uv);
1324     return uv;
1325 }
1326
1327 UV
1328 Perl_to_utf8_upper(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1329 {
1330     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1331                              &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
1332 }
1333
1334 UV
1335 Perl_to_utf8_title(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1336 {
1337     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1338                              &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
1339 }
1340
1341 UV
1342 Perl_to_utf8_lower(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1343 {
1344     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1345                              &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
1346 }
1347
1348 UV
1349 Perl_to_utf8_fold(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1350 {
1351     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1352                              &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
1353 }
1354
1355 /* a "swash" is a swatch hash */
1356
1357 SV*
1358 Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
1359 {
1360     SV* retval;
1361     SV* tokenbufsv = sv_2mortal(NEWSV(0,0));
1362     dSP;
1363     HV *stash = gv_stashpvn(pkg, strlen(pkg), FALSE);
1364     SV* errsv_save;
1365
1366     if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) {      /* demand load utf8 */
1367         ENTER;
1368         errsv_save = newSVsv(ERRSV);
1369         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpv(pkg,0), Nullsv);
1370         if (!SvTRUE(ERRSV))
1371             sv_setsv(ERRSV, errsv_save);
1372         SvREFCNT_dec(errsv_save);
1373         LEAVE;
1374     }
1375     SPAGAIN;
1376     PUSHSTACKi(PERLSI_MAGIC);
1377     PUSHMARK(SP);
1378     EXTEND(SP,5);
1379     PUSHs(sv_2mortal(newSVpvn(pkg, strlen(pkg))));
1380     PUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
1381     PUSHs(listsv);
1382     PUSHs(sv_2mortal(newSViv(minbits)));
1383     PUSHs(sv_2mortal(newSViv(none)));
1384     PUTBACK;
1385     ENTER;
1386     SAVEI32(PL_hints);
1387     PL_hints = 0;
1388     save_re_context();
1389     if (PL_curcop == &PL_compiling)
1390         /* XXX ought to be handled by lex_start */
1391         sv_setpv(tokenbufsv, PL_tokenbuf);
1392     errsv_save = newSVsv(ERRSV);
1393     if (call_method("SWASHNEW", G_SCALAR))
1394         retval = newSVsv(*PL_stack_sp--);
1395     else
1396         retval = &PL_sv_undef;
1397     if (!SvTRUE(ERRSV))
1398         sv_setsv(ERRSV, errsv_save);
1399     SvREFCNT_dec(errsv_save);
1400     LEAVE;
1401     POPSTACK;
1402     if (PL_curcop == &PL_compiling) {
1403         STRLEN len;
1404         char* pv = SvPV(tokenbufsv, len);
1405
1406         Copy(pv, PL_tokenbuf, len+1, char);
1407         PL_curcop->op_private = PL_hints;
1408     }
1409     if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV)
1410         Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
1411     return retval;
1412 }
1413
1414
1415 /* This API is wrong for special case conversions since we may need to
1416  * return several Unicode characters for a single Unicode character
1417  * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
1418  * the lower-level routine, and it is similarly broken for returning
1419  * multiple values.  --jhi */
1420 UV
1421 Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr, bool do_utf8)
1422 {
1423     HV* hv = (HV*)SvRV(sv);
1424     U32 klen;
1425     U32 off;
1426     STRLEN slen;
1427     STRLEN needents;
1428     U8 *tmps = NULL;
1429     U32 bit;
1430     SV *retval;
1431     U8 tmputf8[2];
1432     UV c = NATIVE_TO_ASCII(*ptr);
1433
1434     if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
1435         tmputf8[0] = UTF8_EIGHT_BIT_HI(c);
1436         tmputf8[1] = UTF8_EIGHT_BIT_LO(c);
1437         ptr = tmputf8;
1438     }
1439     /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
1440      * then the "swatch" is a vec() for al the chars which start
1441      * with 0xAA..0xYY
1442      * So the key in the hash (klen) is length of encoded char -1
1443      */
1444     klen = UTF8SKIP(ptr) - 1;
1445     off  = ptr[klen];
1446
1447     if (klen == 0)
1448      {
1449       /* If char in invariant then swatch is for all the invariant chars
1450        * In both UTF-8 and UTF8-MOD that happens to be UTF_CONTINUATION_MARK
1451        */
1452       needents = UTF_CONTINUATION_MARK;
1453       off      = NATIVE_TO_UTF(ptr[klen]);
1454      }
1455     else
1456      {
1457       /* If char is encoded then swatch is for the prefix */
1458       needents = (1 << UTF_ACCUMULATION_SHIFT);
1459       off      = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
1460      }
1461
1462     /*
1463      * This single-entry cache saves about 1/3 of the utf8 overhead in test
1464      * suite.  (That is, only 7-8% overall over just a hash cache.  Still,
1465      * it's nothing to sniff at.)  Pity we usually come through at least
1466      * two function calls to get here...
1467      *
1468      * NB: this code assumes that swatches are never modified, once generated!
1469      */
1470
1471     if (hv   == PL_last_swash_hv &&
1472         klen == PL_last_swash_klen &&
1473         (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
1474     {
1475         tmps = PL_last_swash_tmps;
1476         slen = PL_last_swash_slen;
1477     }
1478     else {
1479         /* Try our second-level swatch cache, kept in a hash. */
1480         SV** svp = hv_fetch(hv, (char*)ptr, klen, FALSE);
1481
1482         /* If not cached, generate it via utf8::SWASHGET */
1483         if (!svp || !SvPOK(*svp) || !(tmps = (U8*)SvPV(*svp, slen))) {
1484             dSP;
1485             /* We use utf8n_to_uvuni() as we want an index into
1486                Unicode tables, not a native character number.
1487              */
1488             UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXLEN, NULL, 0);
1489             SV *errsv_save;
1490             ENTER;
1491             SAVETMPS;
1492             save_re_context();
1493             PUSHSTACKi(PERLSI_MAGIC);
1494             PUSHMARK(SP);
1495             EXTEND(SP,3);
1496             PUSHs((SV*)sv);
1497             /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
1498             PUSHs(sv_2mortal(newSViv((klen) ?
1499                                      (code_point & ~(needents - 1)) : 0)));
1500             PUSHs(sv_2mortal(newSViv(needents)));
1501             PUTBACK;
1502             errsv_save = newSVsv(ERRSV);
1503             if (call_method("SWASHGET", G_SCALAR))
1504                 retval = newSVsv(*PL_stack_sp--);
1505             else
1506                 retval = &PL_sv_undef;
1507             if (!SvTRUE(ERRSV))
1508                 sv_setsv(ERRSV, errsv_save);
1509             SvREFCNT_dec(errsv_save);
1510             POPSTACK;
1511             FREETMPS;
1512             LEAVE;
1513             if (PL_curcop == &PL_compiling)
1514                 PL_curcop->op_private = PL_hints;
1515
1516             svp = hv_store(hv, (char*)ptr, klen, retval, 0);
1517
1518             if (!svp || !(tmps = (U8*)SvPV(*svp, slen)) || (slen << 3) < needents)
1519                 Perl_croak(aTHX_ "SWASHGET didn't return result of proper length");
1520         }
1521
1522         PL_last_swash_hv = hv;
1523         PL_last_swash_klen = klen;
1524         PL_last_swash_tmps = tmps;
1525         PL_last_swash_slen = slen;
1526         if (klen)
1527             Copy(ptr, PL_last_swash_key, klen, U8);
1528     }
1529
1530     switch ((int)((slen << 3) / needents)) {
1531     case 1:
1532         bit = 1 << (off & 7);
1533         off >>= 3;
1534         return (tmps[off] & bit) != 0;
1535     case 8:
1536         return tmps[off];
1537     case 16:
1538         off <<= 1;
1539         return (tmps[off] << 8) + tmps[off + 1] ;
1540     case 32:
1541         off <<= 2;
1542         return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1543     }
1544     Perl_croak(aTHX_ "panic: swash_fetch");
1545     return 0;
1546 }
1547
1548
1549 /*
1550 =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
1551
1552 Adds the UTF8 representation of the Native codepoint C<uv> to the end
1553 of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
1554 bytes available. The return value is the pointer to the byte after the
1555 end of the new character. In other words,
1556
1557     d = uvchr_to_utf8(d, uv);
1558
1559 is the recommended wide native character-aware way of saying
1560
1561     *(d++) = uv;
1562
1563 =cut
1564 */
1565
1566 /* On ASCII machines this is normally a macro but we want a
1567    real function in case XS code wants it
1568 */
1569 #undef Perl_uvchr_to_utf8
1570 U8 *
1571 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
1572 {
1573     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
1574 }
1575
1576 U8 *
1577 Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
1578 {
1579     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
1580 }
1581
1582 /*
1583 =for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
1584
1585 Returns the native character value of the first character in the string C<s>
1586 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
1587 length, in bytes, of that character.
1588
1589 Allows length and flags to be passed to low level routine.
1590
1591 =cut
1592 */
1593 /* On ASCII machines this is normally a macro but we want a
1594    real function in case XS code wants it
1595 */
1596 #undef Perl_utf8n_to_uvchr
1597 UV
1598 Perl_utf8n_to_uvchr(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
1599 {
1600     UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
1601     return UNI_TO_NATIVE(uv);
1602 }
1603
1604 /*
1605 =for apidoc A|char *|pv_uni_display|SV *dsv|U8 *spv|STRLEN len|STRLEN pvlim|UV flags
1606
1607 Build to the scalar dsv a displayable version of the string spv,
1608 length len, the displayable version being at most pvlim bytes long
1609 (if longer, the rest is truncated and "..." will be appended).
1610 The flags argument is currently unused but available for future extensions.
1611 The pointer to the PV of the dsv is returned.
1612
1613 =cut */
1614 char *
1615 Perl_pv_uni_display(pTHX_ SV *dsv, U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
1616 {
1617     int truncated = 0;
1618     char *s, *e;
1619
1620     sv_setpvn(dsv, "", 0);
1621     for (s = (char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
1622          UV u;
1623          if (pvlim && SvCUR(dsv) >= pvlim) {
1624               truncated++;
1625               break;
1626          }
1627          u = utf8_to_uvchr((U8*)s, 0);
1628          Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
1629     }
1630     if (truncated)
1631          sv_catpvn(dsv, "...", 3);
1632
1633     return SvPVX(dsv);
1634 }
1635
1636 /*
1637 =for apidoc A|char *|sv_uni_display|SV *dsv|SV *ssv|STRLEN pvlim|UV flags
1638
1639 Build to the scalar dsv a displayable version of the scalar sv,
1640 he displayable version being at most pvlim bytes long
1641 (if longer, the rest is truncated and "..." will be appended).
1642 The flags argument is currently unused but available for future extensions.
1643 The pointer to the PV of the dsv is returned.
1644
1645 =cut */
1646 char *
1647 Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
1648 {
1649      return Perl_pv_uni_display(aTHX_ dsv, (U8*)SvPVX(ssv), SvCUR(ssv),
1650                                 pvlim, flags);
1651 }
1652
1653 /*
1654 =for apidoc A|I32|ibcmp_utf8|const char *s1|bool u1|const char *s2|bool u2|register I32 len
1655
1656 Return true if the strings s1 and s2 differ case-insensitively, false
1657 if not (if they are equal case-insensitively).  If u1 is true, the
1658 string s1 is assumed to be in UTF-8-encoded Unicode.  If u2 is true,
1659 the string s2 is assumed to be in UTF-8-encoded Unicode.
1660
1661 For case-insensitiveness, the "casefolding" of Unicode is used
1662 instead of upper/lowercasing both the characters, see
1663 http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
1664
1665 =cut */
1666 I32
1667 Perl_ibcmp_utf8(pTHX_ const char *s1, bool u1, register I32 len1, const char *s2, bool u2, register I32 len2)
1668 {
1669      register U8 *a  = (U8*)s1;
1670      register U8 *b  = (U8*)s2;
1671      register U8 *ae = b + len1;
1672      register U8 *be = b + len2;
1673      STRLEN la, lb;
1674      UV ca, cb;
1675      STRLEN ulen1, ulen2;
1676      U8 tmpbuf1[UTF8_MAXLEN_FOLD+1];
1677      U8 tmpbuf2[UTF8_MAXLEN_FOLD+1];
1678
1679      while (a < ae && b < be) {
1680           if (u1) {
1681                if (a + UTF8SKIP(a) > ae)
1682                     break;
1683                ca = utf8_to_uvchr((U8*)a, &la);
1684           } else {
1685                ca = *a;
1686                la = 1;
1687           }
1688           if (u2) {
1689                if (b + UTF8SKIP(b) > be)
1690                     break;
1691                cb = utf8_to_uvchr((U8*)b, &lb);
1692           } else {
1693                cb = *b;
1694                lb = 1;
1695           }
1696           if (ca != cb) {
1697                if (u1)
1698                     to_uni_fold(NATIVE_TO_UNI(ca), tmpbuf1, &ulen1);
1699                else
1700                     ulen1 = 1;
1701                if (u2)
1702                     to_uni_fold(NATIVE_TO_UNI(cb), tmpbuf2, &ulen2);
1703                else
1704                     ulen2 = 1;
1705                if (ulen1 != ulen2
1706                    || (ulen1 == 1 && PL_fold[ca] != PL_fold[cb])
1707                    || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
1708                     return 1; /* mismatch */
1709           }
1710           a += la;
1711           b += lb;
1712      }
1713      return a == ae && b == be ? 0 : 1; /* 0 match, 1 mismatch */
1714 }
1715