utf8.c

   1 /*    utf8.c
   2  *
   3  *    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   4  *    by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * 'What a fix!' said Sam.  'That's the one place in all the lands we've ever
  13  *  heard of that we don't want to see any closer; and that's the one place
  14  *  we're trying to get to!  And that's just where we can't get, nohow.'
  15  *
  16  *     [p.603 of _The Lord of the Rings_, IV/I: "The Taming of Sméagol"]
  17  *
  18  * 'Well do I understand your speech,' he answered in the same language;
  19  * 'yet few strangers do so.  Why then do you not speak in the Common Tongue,
  20  *  as is the custom in the West, if you wish to be answered?'
  21  *                           --Gandalf, addressing Théoden's door wardens
  22  *
  23  *     [p.508 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
  24  *
  25  * ...the travellers perceived that the floor was paved with stones of many
  26  * hues; branching runes and strange devices intertwined beneath their feet.
  27  *
  28  *     [p.512 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
  29  */
  30
  31 #include "EXTERN.h"
  32 #define PERL_IN_UTF8_C
  33 #include "perl.h"
  34
  35 #ifndef EBCDIC
  36 /* Separate prototypes needed because in ASCII systems these
  37  * usually macros but they still are compiled as code, too. */
  38 PERL_CALLCONV UV        Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags);
  39 PERL_CALLCONV U8*       Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv);
  40 #endif
  41
  42 static const char unees[] =
  43     "Malformed UTF-8 character (unexpected end of string)";
  44
  45 /*
  46 =head1 Unicode Support
  47
  48 This file contains various utility functions for manipulating UTF8-encoded
  49 strings. For the uninitiated, this is a method of representing arbitrary
  50 Unicode characters as a variable number of bytes, in such a way that
  51 characters in the ASCII range are unmodified, and a zero byte never appears
  52 within non-zero characters.
  53
  54 =for apidoc uvuni_to_utf8_flags
  55
  56 Adds the UTF-8 representation of the Unicode codepoint C<uv> to the end
  57 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
  58 bytes available. The return value is the pointer to the byte after the
  59 end of the new character. In other words,
  60
  61     d = uvuni_to_utf8_flags(d, uv, flags);
  62
  63 or, in most cases,
  64
  65     d = uvuni_to_utf8(d, uv);
  66
  67 (which is equivalent to)
  68
  69     d = uvuni_to_utf8_flags(d, uv, 0);
  70
  71 is the recommended Unicode-aware way of saying
  72
  73     *(d++) = uv;
  74
  75 =cut
  76 */
  77
  78 U8 *
  79 Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
  80 {
  81     PERL_ARGS_ASSERT_UVUNI_TO_UTF8_FLAGS;
  82
  83     if (ckWARN(WARN_UTF8)) {
  84          if (UNICODE_IS_SURROGATE(uv) &&
  85              !(flags & UNICODE_ALLOW_SURROGATE))
  86               Perl_warner(aTHX_ packWARN(WARN_UTF8), "UTF-16 surrogate 0x%04"UVxf, uv);
  87          else if (
  88                   ((uv >= 0xFDD0 && uv <= 0xFDEF &&
  89                     !(flags & UNICODE_ALLOW_FDD0))
  90                    ||
  91                    ((uv & 0xFFFE) == 0xFFFE && /* Either FFFE or FFFF. */
  92                     !(flags & UNICODE_ALLOW_FFFF))) &&
  93                   /* UNICODE_ALLOW_SUPER includes
  94                    * FFFEs and FFFFs beyond 0x10FFFF. */
  95                   ((uv <= PERL_UNICODE_MAX) ||
  96                    !(flags & UNICODE_ALLOW_SUPER))
  97                   )
  98               Perl_warner(aTHX_ packWARN(WARN_UTF8),
  99                          "Unicode character 0x%04"UVxf" is illegal", uv);
 100     }
 101     if (UNI_IS_INVARIANT(uv)) {
 102         *d++ = (U8)UTF_TO_NATIVE(uv);
 103         return d;
 104     }
 105 #if defined(EBCDIC)
 106     else {
 107         STRLEN len  = UNISKIP(uv);
 108         U8 *p = d+len-1;
 109         while (p > d) {
 110             *p-- = (U8)UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
 111             uv >>= UTF_ACCUMULATION_SHIFT;
 112         }
 113         *p = (U8)UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
 114         return d+len;
 115     }
 116 #else /* Non loop style */
 117     if (uv < 0x800) {
 118         *d++ = (U8)(( uv >>  6)         | 0xc0);
 119         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 120         return d;
 121     }
 122     if (uv < 0x10000) {
 123         *d++ = (U8)(( uv >> 12)         | 0xe0);
 124         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 125         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 126         return d;
 127     }
 128     if (uv < 0x200000) {
 129         *d++ = (U8)(( uv >> 18)         | 0xf0);
 130         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
 131         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 132         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 133         return d;
 134     }
 135     if (uv < 0x4000000) {
 136         *d++ = (U8)(( uv >> 24)         | 0xf8);
 137         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
 138         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
 139         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 140         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 141         return d;
 142     }
 143     if (uv < 0x80000000) {
 144         *d++ = (U8)(( uv >> 30)         | 0xfc);
 145         *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
 146         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
 147         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
 148         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 149         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 150         return d;
 151     }
 152 #ifdef HAS_QUAD
 153     if (uv < UTF8_QUAD_MAX)
 154 #endif
 155     {
 156         *d++ =                            0xfe; /* Can't match U+FEFF! */
 157         *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
 158         *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
 159         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
 160         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
 161         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 162         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 163         return d;
 164     }
 165 #ifdef HAS_QUAD
 166     {
 167         *d++ =                            0xff;         /* Can't match U+FFFE! */
 168         *d++ =                            0x80;         /* 6 Reserved bits */
 169         *d++ = (U8)(((uv >> 60) & 0x0f) | 0x80);        /* 2 Reserved bits */
 170         *d++ = (U8)(((uv >> 54) & 0x3f) | 0x80);
 171         *d++ = (U8)(((uv >> 48) & 0x3f) | 0x80);
 172         *d++ = (U8)(((uv >> 42) & 0x3f) | 0x80);
 173         *d++ = (U8)(((uv >> 36) & 0x3f) | 0x80);
 174         *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
 175         *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
 176         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
 177         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
 178         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 179         *d++ = (U8)(( uv        & 0x3f) | 0x80);
 180         return d;
 181     }
 182 #endif
 183 #endif /* Loop style */
 184 }
 185
 186 /*
 187
 188 Tests if some arbitrary number of bytes begins in a valid UTF-8
 189 character.  Note that an INVARIANT (i.e. ASCII) character is a valid
 190 UTF-8 character.  The actual number of bytes in the UTF-8 character
 191 will be returned if it is valid, otherwise 0.
 192
 193 This is the "slow" version as opposed to the "fast" version which is
 194 the "unrolled" IS_UTF8_CHAR().  E.g. for t/uni/class.t the speed
 195 difference is a factor of 2 to 3.  For lengths (UTF8SKIP(s)) of four
 196 or less you should use the IS_UTF8_CHAR(), for lengths of five or more
 197 you should use the _slow().  In practice this means that the _slow()
 198 will be used very rarely, since the maximum Unicode code point (as of
 199 Unicode 4.1) is U+10FFFF, which encodes in UTF-8 to four bytes.  Only
 200 the "Perl extended UTF-8" (the infamous 'v-strings') will encode into
 201 five bytes or more.
 202
 203 =cut */
 204 STATIC STRLEN
 205 S_is_utf8_char_slow(const U8 *s, const STRLEN len)
 206 {
 207     U8 u = *s;
 208     STRLEN slen;
 209     UV uv, ouv;
 210
 211     PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW;
 212
 213     if (UTF8_IS_INVARIANT(u))
 214         return 1;
 215
 216     if (!UTF8_IS_START(u))
 217         return 0;
 218
 219     if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
 220         return 0;
 221
 222     slen = len - 1;
 223     s++;
 224 #ifdef EBCDIC
 225     u = NATIVE_TO_UTF(u);
 226 #endif
 227     u &= UTF_START_MASK(len);
 228     uv  = u;
 229     ouv = uv;
 230     while (slen--) {
 231         if (!UTF8_IS_CONTINUATION(*s))
 232             return 0;
 233         uv = UTF8_ACCUMULATE(uv, *s);
 234         if (uv < ouv)
 235             return 0;
 236         ouv = uv;
 237         s++;
 238     }
 239
 240     if ((STRLEN)UNISKIP(uv) < len)
 241         return 0;
 242
 243     return len;
 244 }
 245
 246 /*
 247 =for apidoc is_utf8_char
 248
 249 Tests if some arbitrary number of bytes begins in a valid UTF-8
 250 character.  Note that an INVARIANT (i.e. ASCII on non-EBCDIC machines)
 251 character is a valid UTF-8 character.  The actual number of bytes in the UTF-8
 252 character will be returned if it is valid, otherwise 0.
 253
 254 =cut */
 255 STRLEN
 256 Perl_is_utf8_char(pTHX_ const U8 *s)
 257 {
 258     const STRLEN len = UTF8SKIP(s);
 259
 260     PERL_ARGS_ASSERT_IS_UTF8_CHAR;
 261     PERL_UNUSED_CONTEXT;
 262 #ifdef IS_UTF8_CHAR
 263     if (IS_UTF8_CHAR_FAST(len))
 264         return IS_UTF8_CHAR(s, len) ? len : 0;
 265 #endif /* #ifdef IS_UTF8_CHAR */
 266     return is_utf8_char_slow(s, len);
 267 }
 268
 269 /*
 270 =for apidoc is_utf8_string
 271
 272 Returns true if first C<len> bytes of the given string form a valid
 273 UTF-8 string, false otherwise.  Note that 'a valid UTF-8 string' does
 274 not mean 'a string that contains code points above 0x7F encoded in UTF-8'
 275 because a valid ASCII string is a valid UTF-8 string.
 276
 277 See also is_utf8_string_loclen() and is_utf8_string_loc().
 278
 279 =cut
 280 */
 281
 282 bool
 283 Perl_is_utf8_string(pTHX_ const U8 *s, STRLEN len)
 284 {
 285     const U8* const send = s + (len ? len : strlen((const char *)s));
 286     const U8* x = s;
 287
 288     PERL_ARGS_ASSERT_IS_UTF8_STRING;
 289     PERL_UNUSED_CONTEXT;
 290
 291     while (x < send) {
 292         STRLEN c;
 293          /* Inline the easy bits of is_utf8_char() here for speed... */
 294          if (UTF8_IS_INVARIANT(*x))
 295               c = 1;
 296          else if (!UTF8_IS_START(*x))
 297              goto out;
 298          else {
 299               /* ... and call is_utf8_char() only if really needed. */
 300 #ifdef IS_UTF8_CHAR
 301              c = UTF8SKIP(x);
 302              if (IS_UTF8_CHAR_FAST(c)) {
 303                  if (!IS_UTF8_CHAR(x, c))
 304                      c = 0;
 305              }
 306              else
 307                 c = is_utf8_char_slow(x, c);
 308 #else
 309              c = is_utf8_char(x);
 310 #endif /* #ifdef IS_UTF8_CHAR */
 311               if (!c)
 312                   goto out;
 313          }
 314         x += c;
 315     }
 316
 317  out:
 318     if (x != send)
 319         return FALSE;
 320
 321     return TRUE;
 322 }
 323
 324 /*
 325 Implemented as a macro in utf8.h
 326
 327 =for apidoc is_utf8_string_loc
 328
 329 Like is_utf8_string() but stores the location of the failure (in the
 330 case of "utf8ness failure") or the location s+len (in the case of
 331 "utf8ness success") in the C<ep>.
 332
 333 See also is_utf8_string_loclen() and is_utf8_string().
 334
 335 =for apidoc is_utf8_string_loclen
 336
 337 Like is_utf8_string() but stores the location of the failure (in the
 338 case of "utf8ness failure") or the location s+len (in the case of
 339 "utf8ness success") in the C<ep>, and the number of UTF-8
 340 encoded characters in the C<el>.
 341
 342 See also is_utf8_string_loc() and is_utf8_string().
 343
 344 =cut
 345 */
 346
 347 bool
 348 Perl_is_utf8_string_loclen(pTHX_ const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
 349 {
 350     const U8* const send = s + (len ? len : strlen((const char *)s));
 351     const U8* x = s;
 352     STRLEN c;
 353     STRLEN outlen = 0;
 354
 355     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
 356     PERL_UNUSED_CONTEXT;
 357
 358     while (x < send) {
 359          /* Inline the easy bits of is_utf8_char() here for speed... */
 360          if (UTF8_IS_INVARIANT(*x))
 361              c = 1;
 362          else if (!UTF8_IS_START(*x))
 363              goto out;
 364          else {
 365              /* ... and call is_utf8_char() only if really needed. */
 366 #ifdef IS_UTF8_CHAR
 367              c = UTF8SKIP(x);
 368              if (IS_UTF8_CHAR_FAST(c)) {
 369                  if (!IS_UTF8_CHAR(x, c))
 370                      c = 0;
 371              } else
 372                  c = is_utf8_char_slow(x, c);
 373 #else
 374              c = is_utf8_char(x);
 375 #endif /* #ifdef IS_UTF8_CHAR */
 376              if (!c)
 377                  goto out;
 378          }
 379          x += c;
 380          outlen++;
 381     }
 382
 383  out:
 384     if (el)
 385         *el = outlen;
 386
 387     if (ep)
 388         *ep = x;
 389     return (x == send);
 390 }
 391
 392 /*
 393
 394 =for apidoc utf8n_to_uvuni
 395
 396 Bottom level UTF-8 decode routine.
 397 Returns the Unicode code point value of the first character in the string C<s>
 398 which is assumed to be in UTF-8 encoding and no longer than C<curlen>;
 399 C<retlen> will be set to the length, in bytes, of that character.
 400
 401 If C<s> does not point to a well-formed UTF-8 character, the behaviour
 402 is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
 403 it is assumed that the caller will raise a warning, and this function
 404 will silently just set C<retlen> to C<-1> and return zero.  If the
 405 C<flags> does not contain UTF8_CHECK_ONLY, warnings about
 406 malformations will be given, C<retlen> will be set to the expected
 407 length of the UTF-8 character in bytes, and zero will be returned.
 408
 409 The C<flags> can also contain various flags to allow deviations from
 410 the strict UTF-8 encoding (see F<utf8.h>).
 411
 412 Most code should use utf8_to_uvchr() rather than call this directly.
 413
 414 =cut
 415 */
 416
 417 UV
 418 Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
 419 {
 420     dVAR;
 421     const U8 * const s0 = s;
 422     UV uv = *s, ouv = 0;
 423     STRLEN len = 1;
 424     const bool dowarn = ckWARN_d(WARN_UTF8);
 425     const UV startbyte = *s;
 426     STRLEN expectlen = 0;
 427     U32 warning = 0;
 428
 429     PERL_ARGS_ASSERT_UTF8N_TO_UVUNI;
 430
 431 /* This list is a superset of the UTF8_ALLOW_XXX. */
 432
 433 #define UTF8_WARN_EMPTY                          1
 434 #define UTF8_WARN_CONTINUATION                   2
 435 #define UTF8_WARN_NON_CONTINUATION               3
 436 #define UTF8_WARN_FE_FF                          4
 437 #define UTF8_WARN_SHORT                          5
 438 #define UTF8_WARN_OVERFLOW                       6
 439 #define UTF8_WARN_SURROGATE                      7
 440 #define UTF8_WARN_LONG                           8
 441 #define UTF8_WARN_FFFF                           9 /* Also FFFE. */
 442
 443     if (curlen == 0 &&
 444         !(flags & UTF8_ALLOW_EMPTY)) {
 445         warning = UTF8_WARN_EMPTY;
 446         goto malformed;
 447     }
 448
 449     if (UTF8_IS_INVARIANT(uv)) {
 450         if (retlen)
 451             *retlen = 1;
 452         return (UV) (NATIVE_TO_UTF(*s));
 453     }
 454
 455     if (UTF8_IS_CONTINUATION(uv) &&
 456         !(flags & UTF8_ALLOW_CONTINUATION)) {
 457         warning = UTF8_WARN_CONTINUATION;
 458         goto malformed;
 459     }
 460
 461     if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
 462         !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
 463         warning = UTF8_WARN_NON_CONTINUATION;
 464         goto malformed;
 465     }
 466
 467 #ifdef EBCDIC
 468     uv = NATIVE_TO_UTF(uv);
 469 #else
 470     if ((uv == 0xfe || uv == 0xff) &&
 471         !(flags & UTF8_ALLOW_FE_FF)) {
 472         warning = UTF8_WARN_FE_FF;
 473         goto malformed;
 474     }
 475 #endif
 476
 477     if      (!(uv & 0x20))      { len =  2; uv &= 0x1f; }
 478     else if (!(uv & 0x10))      { len =  3; uv &= 0x0f; }
 479     else if (!(uv & 0x08))      { len =  4; uv &= 0x07; }
 480     else if (!(uv & 0x04))      { len =  5; uv &= 0x03; }
 481 #ifdef EBCDIC
 482     else if (!(uv & 0x02))      { len =  6; uv &= 0x01; }
 483     else                        { len =  7; uv &= 0x01; }
 484 #else
 485     else if (!(uv & 0x02))      { len =  6; uv &= 0x01; }
 486     else if (!(uv & 0x01))      { len =  7; uv = 0; }
 487     else                        { len = 13; uv = 0; } /* whoa! */
 488 #endif
 489
 490     if (retlen)
 491         *retlen = len;
 492
 493     expectlen = len;
 494
 495     if ((curlen < expectlen) &&
 496         !(flags & UTF8_ALLOW_SHORT)) {
 497         warning = UTF8_WARN_SHORT;
 498         goto malformed;
 499     }
 500
 501     len--;
 502     s++;
 503     ouv = uv;
 504
 505     while (len--) {
 506         if (!UTF8_IS_CONTINUATION(*s) &&
 507             !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
 508             s--;
 509             warning = UTF8_WARN_NON_CONTINUATION;
 510             goto malformed;
 511         }
 512         else
 513             uv = UTF8_ACCUMULATE(uv, *s);
 514         if (!(uv > ouv)) {
 515             /* These cannot be allowed. */
 516             if (uv == ouv) {
 517                 if (expectlen != 13 && !(flags & UTF8_ALLOW_LONG)) {
 518                     warning = UTF8_WARN_LONG;
 519                     goto malformed;
 520                 }
 521             }
 522             else { /* uv < ouv */
 523                 /* This cannot be allowed. */
 524                 warning = UTF8_WARN_OVERFLOW;
 525                 goto malformed;
 526             }
 527         }
 528         s++;
 529         ouv = uv;
 530     }
 531
 532     if (UNICODE_IS_SURROGATE(uv) &&
 533         !(flags & UTF8_ALLOW_SURROGATE)) {
 534         warning = UTF8_WARN_SURROGATE;
 535         goto malformed;
 536     } else if ((expectlen > (STRLEN)UNISKIP(uv)) &&
 537                !(flags & UTF8_ALLOW_LONG)) {
 538         warning = UTF8_WARN_LONG;
 539         goto malformed;
 540     } else if (UNICODE_IS_ILLEGAL(uv) &&
 541                !(flags & UTF8_ALLOW_FFFF)) {
 542         warning = UTF8_WARN_FFFF;
 543         goto malformed;
 544     }
 545
 546     return uv;
 547
 548 malformed:
 549
 550     if (flags & UTF8_CHECK_ONLY) {
 551         if (retlen)
 552             *retlen = ((STRLEN) -1);
 553         return 0;
 554     }
 555
 556     if (dowarn) {
 557         SV* const sv = newSVpvs_flags("Malformed UTF-8 character ", SVs_TEMP);
 558
 559         switch (warning) {
 560         case 0: /* Intentionally empty. */ break;
 561         case UTF8_WARN_EMPTY:
 562             sv_catpvs(sv, "(empty string)");
 563             break;
 564         case UTF8_WARN_CONTINUATION:
 565             Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
 566             break;
 567         case UTF8_WARN_NON_CONTINUATION:
 568             if (s == s0)
 569                 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
 570                            (UV)s[1], startbyte);
 571             else {
 572                 const int len = (int)(s-s0);
 573                 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
 574                            (UV)s[1], len, len > 1 ? "s" : "", startbyte, (int)expectlen);
 575             }
 576
 577             break;
 578         case UTF8_WARN_FE_FF:
 579             Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
 580             break;
 581         case UTF8_WARN_SHORT:
 582             Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
 583                            (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, startbyte);
 584             expectlen = curlen;         /* distance for caller to skip */
 585             break;
 586         case UTF8_WARN_OVERFLOW:
 587             Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
 588                            ouv, *s, startbyte);
 589             break;
 590         case UTF8_WARN_SURROGATE:
 591             Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
 592             break;
 593         case UTF8_WARN_LONG:
 594             Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
 595                            (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
 596             break;
 597         case UTF8_WARN_FFFF:
 598             Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
 599             break;
 600         default:
 601             sv_catpvs(sv, "(unknown reason)");
 602             break;
 603         }
 604
 605         if (warning) {
 606             const char * const s = SvPVX_const(sv);
 607
 608             if (PL_op)
 609                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
 610                             "%s in %s", s,  OP_DESC(PL_op));
 611             else
 612                 Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s);
 613         }
 614     }
 615
 616     if (retlen)
 617         *retlen = expectlen ? expectlen : len;
 618
 619     return 0;
 620 }
 621
 622 /*
 623 =for apidoc utf8_to_uvchr
 624
 625 Returns the native character value of the first character in the string C<s>
 626 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
 627 length, in bytes, of that character.
 628
 629 If C<s> does not point to a well-formed UTF-8 character, zero is
 630 returned and retlen is set, if possible, to -1.
 631
 632 =cut
 633 */
 634
 635 UV
 636 Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
 637 {
 638     PERL_ARGS_ASSERT_UTF8_TO_UVCHR;
 639
 640     return utf8n_to_uvchr(s, UTF8_MAXBYTES, retlen,
 641                           ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
 642 }
 643
 644 /*
 645 =for apidoc utf8_to_uvuni
 646
 647 Returns the Unicode code point of the first character in the string C<s>
 648 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
 649 length, in bytes, of that character.
 650
 651 This function should only be used when the returned UV is considered
 652 an index into the Unicode semantic tables (e.g. swashes).
 653
 654 If C<s> does not point to a well-formed UTF-8 character, zero is
 655 returned and retlen is set, if possible, to -1.
 656
 657 =cut
 658 */
 659
 660 UV
 661 Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
 662 {
 663     PERL_ARGS_ASSERT_UTF8_TO_UVUNI;
 664
 665     /* Call the low level routine asking for checks */
 666     return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXBYTES, retlen,
 667                                ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
 668 }
 669
 670 /*
 671 =for apidoc utf8_length
 672
 673 Return the length of the UTF-8 char encoded string C<s> in characters.
 674 Stops at C<e> (inclusive).  If C<e E<lt> s> or if the scan would end
 675 up past C<e>, croaks.
 676
 677 =cut
 678 */
 679
 680 STRLEN
 681 Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
 682 {
 683     dVAR;
 684     STRLEN len = 0;
 685     U8 t = 0;
 686
 687     PERL_ARGS_ASSERT_UTF8_LENGTH;
 688
 689     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
 690      * the bitops (especially ~) can create illegal UTF-8.
 691      * In other words: in Perl UTF-8 is not just for Unicode. */
 692
 693     if (e < s)
 694         goto warn_and_return;
 695     while (s < e) {
 696         t = UTF8SKIP(s);
 697         if (e - s < t) {
 698             warn_and_return:
 699             if (ckWARN_d(WARN_UTF8)) {
 700                 if (PL_op)
 701                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
 702                             "%s in %s", unees, OP_DESC(PL_op));
 703                 else
 704                     Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
 705             }
 706             return len;
 707         }
 708         s += t;
 709         len++;
 710     }
 711
 712     return len;
 713 }
 714
 715 /*
 716 =for apidoc utf8_distance
 717
 718 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
 719 and C<b>.
 720
 721 WARNING: use only if you *know* that the pointers point inside the
 722 same UTF-8 buffer.
 723
 724 =cut
 725 */
 726
 727 IV
 728 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
 729 {
 730     PERL_ARGS_ASSERT_UTF8_DISTANCE;
 731
 732     return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
 733 }
 734
 735 /*
 736 =for apidoc utf8_hop
 737
 738 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
 739 forward or backward.
 740
 741 WARNING: do not use the following unless you *know* C<off> is within
 742 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
 743 on the first byte of character or just after the last byte of a character.
 744
 745 =cut
 746 */
 747
 748 U8 *
 749 Perl_utf8_hop(pTHX_ const U8 *s, I32 off)
 750 {
 751     PERL_ARGS_ASSERT_UTF8_HOP;
 752
 753     PERL_UNUSED_CONTEXT;
 754     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
 755      * the bitops (especially ~) can create illegal UTF-8.
 756      * In other words: in Perl UTF-8 is not just for Unicode. */
 757
 758     if (off >= 0) {
 759         while (off--)
 760             s += UTF8SKIP(s);
 761     }
 762     else {
 763         while (off++) {
 764             s--;
 765             while (UTF8_IS_CONTINUATION(*s))
 766                 s--;
 767         }
 768     }
 769     return (U8 *)s;
 770 }
 771
 772 /*
 773 =for apidoc utf8_to_bytes
 774
 775 Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
 776 Unlike C<bytes_to_utf8>, this over-writes the original string, and
 777 updates len to contain the new length.
 778 Returns zero on failure, setting C<len> to -1.
 779
 780 If you need a copy of the string, see C<bytes_from_utf8>.
 781
 782 =cut
 783 */
 784
 785 U8 *
 786 Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
 787 {
 788     U8 * const save = s;
 789     U8 * const send = s + *len;
 790     U8 *d;
 791
 792     PERL_ARGS_ASSERT_UTF8_TO_BYTES;
 793
 794     /* ensure valid UTF-8 and chars < 256 before updating string */
 795     while (s < send) {
 796         U8 c = *s++;
 797
 798         if (!UTF8_IS_INVARIANT(c) &&
 799             (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
 800              || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
 801             *len = ((STRLEN) -1);
 802             return 0;
 803         }
 804     }
 805
 806     d = s = save;
 807     while (s < send) {
 808         STRLEN ulen;
 809         *d++ = (U8)utf8_to_uvchr(s, &ulen);
 810         s += ulen;
 811     }
 812     *d = '\0';
 813     *len = d - save;
 814     return save;
 815 }
 816
 817 /*
 818 =for apidoc bytes_from_utf8
 819
 820 Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
 821 Unlike C<utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
 822 the newly-created string, and updates C<len> to contain the new
 823 length.  Returns the original string if no conversion occurs, C<len>
 824 is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
 825 0 if C<s> is converted or consisted entirely of characters that are invariant
 826 in utf8 (i.e., US-ASCII on non-EBCDIC machines).
 827
 828 =cut
 829 */
 830
 831 U8 *
 832 Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8)
 833 {
 834     U8 *d;
 835     const U8 *start = s;
 836     const U8 *send;
 837     I32 count = 0;
 838
 839     PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
 840
 841     PERL_UNUSED_CONTEXT;
 842     if (!*is_utf8)
 843         return (U8 *)start;
 844
 845     /* ensure valid UTF-8 and chars < 256 before converting string */
 846     for (send = s + *len; s < send;) {
 847         U8 c = *s++;
 848         if (!UTF8_IS_INVARIANT(c)) {
 849             if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
 850                 (c = *s++) && UTF8_IS_CONTINUATION(c))
 851                 count++;
 852             else
 853                 return (U8 *)start;
 854         }
 855     }
 856
 857     *is_utf8 = FALSE;
 858
 859     Newx(d, (*len) - count + 1, U8);
 860     s = start; start = d;
 861     while (s < send) {
 862         U8 c = *s++;
 863         if (!UTF8_IS_INVARIANT(c)) {
 864             /* Then it is two-byte encoded */
 865             c = UTF8_ACCUMULATE(NATIVE_TO_UTF(c), *s++);
 866             c = ASCII_TO_NATIVE(c);
 867         }
 868         *d++ = c;
 869     }
 870     *d = '\0';
 871     *len = d - start;
 872     return (U8 *)start;
 873 }
 874
 875 /*
 876 =for apidoc bytes_to_utf8
 877
 878 Converts a string C<s> of length C<len> from the native encoding into UTF-8.
 879 Returns a pointer to the newly-created string, and sets C<len> to
 880 reflect the new length.
 881
 882 A NUL character will be written after the end of the string.
 883
 884 If you want to convert to UTF-8 from encodings other than
 885 the native (Latin1 or EBCDIC),
 886 see sv_recode_to_utf8().
 887
 888 =cut
 889 */
 890
 891 U8*
 892 Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len)
 893 {
 894     const U8 * const send = s + (*len);
 895     U8 *d;
 896     U8 *dst;
 897
 898     PERL_ARGS_ASSERT_BYTES_TO_UTF8;
 899     PERL_UNUSED_CONTEXT;
 900
 901     Newx(d, (*len) * 2 + 1, U8);
 902     dst = d;
 903
 904     while (s < send) {
 905         const UV uv = NATIVE_TO_ASCII(*s++);
 906         if (UNI_IS_INVARIANT(uv))
 907             *d++ = (U8)UTF_TO_NATIVE(uv);
 908         else {
 909             *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
 910             *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
 911         }
 912     }
 913     *d = '\0';
 914     *len = d-dst;
 915     return dst;
 916 }
 917
 918 /*
 919  * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
 920  *
 921  * Destination must be pre-extended to 3/2 source.  Do not use in-place.
 922  * We optimize for native, for obvious reasons. */
 923
 924 U8*
 925 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 926 {
 927     U8* pend;
 928     U8* dstart = d;
 929
 930     PERL_ARGS_ASSERT_UTF16_TO_UTF8;
 931
 932     if (bytelen == 1 && p[0] == 0) { /* Be understanding. */
 933          d[0] = 0;
 934          *newlen = 1;
 935          return d;
 936     }
 937
 938     if (bytelen & 1)
 939         Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %"UVuf, (UV)bytelen);
 940
 941     pend = p + bytelen;
 942
 943     while (p < pend) {
 944         UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
 945         p += 2;
 946         if (uv < 0x80) {
 947 #ifdef EBCDIC
 948             *d++ = UNI_TO_NATIVE(uv);
 949 #else
 950             *d++ = (U8)uv;
 951 #endif
 952             continue;
 953         }
 954         if (uv < 0x800) {
 955             *d++ = (U8)(( uv >>  6)         | 0xc0);
 956             *d++ = (U8)(( uv        & 0x3f) | 0x80);
 957             continue;
 958         }
 959         if (uv >= 0xd800 && uv < 0xdbff) {      /* surrogates */
 960             UV low = (p[0] << 8) + p[1];
 961             p += 2;
 962             if (low < 0xdc00 || low >= 0xdfff)
 963                 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
 964             uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
 965         }
 966         if (uv < 0x10000) {
 967             *d++ = (U8)(( uv >> 12)         | 0xe0);
 968             *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 969             *d++ = (U8)(( uv        & 0x3f) | 0x80);
 970             continue;
 971         }
 972         else {
 973             *d++ = (U8)(( uv >> 18)         | 0xf0);
 974             *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
 975             *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
 976             *d++ = (U8)(( uv        & 0x3f) | 0x80);
 977             continue;
 978         }
 979     }
 980     *newlen = d - dstart;
 981     return d;
 982 }
 983
 984 /* Note: this one is slightly destructive of the source. */
 985
 986 U8*
 987 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 988 {
 989     U8* s = (U8*)p;
 990     U8* const send = s + bytelen;
 991
 992     PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED;
 993
 994     while (s < send) {
 995         const U8 tmp = s[0];
 996         s[0] = s[1];
 997         s[1] = tmp;
 998         s += 2;
 999     }
1000     return utf16_to_utf8(p, d, bytelen, newlen);
1001 }
1002
1003 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
1004
1005 bool
1006 Perl_is_uni_alnum(pTHX_ UV c)
1007 {
1008     U8 tmpbuf[UTF8_MAXBYTES+1];
1009     uvchr_to_utf8(tmpbuf, c);
1010     return is_utf8_alnum(tmpbuf);
1011 }
1012
1013 bool
1014 Perl_is_uni_alnumc(pTHX_ UV c)
1015 {
1016     U8 tmpbuf[UTF8_MAXBYTES+1];
1017     uvchr_to_utf8(tmpbuf, c);
1018     return is_utf8_alnumc(tmpbuf);
1019 }
1020
1021 bool
1022 Perl_is_uni_idfirst(pTHX_ UV c)
1023 {
1024     U8 tmpbuf[UTF8_MAXBYTES+1];
1025     uvchr_to_utf8(tmpbuf, c);
1026     return is_utf8_idfirst(tmpbuf);
1027 }
1028
1029 bool
1030 Perl_is_uni_alpha(pTHX_ UV c)
1031 {
1032     U8 tmpbuf[UTF8_MAXBYTES+1];
1033     uvchr_to_utf8(tmpbuf, c);
1034     return is_utf8_alpha(tmpbuf);
1035 }
1036
1037 bool
1038 Perl_is_uni_ascii(pTHX_ UV c)
1039 {
1040     U8 tmpbuf[UTF8_MAXBYTES+1];
1041     uvchr_to_utf8(tmpbuf, c);
1042     return is_utf8_ascii(tmpbuf);
1043 }
1044
1045 bool
1046 Perl_is_uni_space(pTHX_ UV c)
1047 {
1048     U8 tmpbuf[UTF8_MAXBYTES+1];
1049     uvchr_to_utf8(tmpbuf, c);
1050     return is_utf8_space(tmpbuf);
1051 }
1052
1053 bool
1054 Perl_is_uni_digit(pTHX_ UV c)
1055 {
1056     U8 tmpbuf[UTF8_MAXBYTES+1];
1057     uvchr_to_utf8(tmpbuf, c);
1058     return is_utf8_digit(tmpbuf);
1059 }
1060
1061 bool
1062 Perl_is_uni_upper(pTHX_ UV c)
1063 {
1064     U8 tmpbuf[UTF8_MAXBYTES+1];
1065     uvchr_to_utf8(tmpbuf, c);
1066     return is_utf8_upper(tmpbuf);
1067 }
1068
1069 bool
1070 Perl_is_uni_lower(pTHX_ UV c)
1071 {
1072     U8 tmpbuf[UTF8_MAXBYTES+1];
1073     uvchr_to_utf8(tmpbuf, c);
1074     return is_utf8_lower(tmpbuf);
1075 }
1076
1077 bool
1078 Perl_is_uni_cntrl(pTHX_ UV c)
1079 {
1080     U8 tmpbuf[UTF8_MAXBYTES+1];
1081     uvchr_to_utf8(tmpbuf, c);
1082     return is_utf8_cntrl(tmpbuf);
1083 }
1084
1085 bool
1086 Perl_is_uni_graph(pTHX_ UV c)
1087 {
1088     U8 tmpbuf[UTF8_MAXBYTES+1];
1089     uvchr_to_utf8(tmpbuf, c);
1090     return is_utf8_graph(tmpbuf);
1091 }
1092
1093 bool
1094 Perl_is_uni_print(pTHX_ UV c)
1095 {
1096     U8 tmpbuf[UTF8_MAXBYTES+1];
1097     uvchr_to_utf8(tmpbuf, c);
1098     return is_utf8_print(tmpbuf);
1099 }
1100
1101 bool
1102 Perl_is_uni_punct(pTHX_ UV c)
1103 {
1104     U8 tmpbuf[UTF8_MAXBYTES+1];
1105     uvchr_to_utf8(tmpbuf, c);
1106     return is_utf8_punct(tmpbuf);
1107 }
1108
1109 bool
1110 Perl_is_uni_xdigit(pTHX_ UV c)
1111 {
1112     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1113     uvchr_to_utf8(tmpbuf, c);
1114     return is_utf8_xdigit(tmpbuf);
1115 }
1116
1117 UV
1118 Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
1119 {
1120     PERL_ARGS_ASSERT_TO_UNI_UPPER;
1121
1122     uvchr_to_utf8(p, c);
1123     return to_utf8_upper(p, p, lenp);
1124 }
1125
1126 UV
1127 Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
1128 {
1129     PERL_ARGS_ASSERT_TO_UNI_TITLE;
1130
1131     uvchr_to_utf8(p, c);
1132     return to_utf8_title(p, p, lenp);
1133 }
1134
1135 UV
1136 Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
1137 {
1138     PERL_ARGS_ASSERT_TO_UNI_LOWER;
1139
1140     uvchr_to_utf8(p, c);
1141     return to_utf8_lower(p, p, lenp);
1142 }
1143
1144 UV
1145 Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
1146 {
1147     PERL_ARGS_ASSERT_TO_UNI_FOLD;
1148
1149     uvchr_to_utf8(p, c);
1150     return to_utf8_fold(p, p, lenp);
1151 }
1152
1153 /* for now these all assume no locale info available for Unicode > 255 */
1154
1155 bool
1156 Perl_is_uni_alnum_lc(pTHX_ UV c)
1157 {
1158     return is_uni_alnum(c);     /* XXX no locale support yet */
1159 }
1160
1161 bool
1162 Perl_is_uni_alnumc_lc(pTHX_ UV c)
1163 {
1164     return is_uni_alnumc(c);    /* XXX no locale support yet */
1165 }
1166
1167 bool
1168 Perl_is_uni_idfirst_lc(pTHX_ UV c)
1169 {
1170     return is_uni_idfirst(c);   /* XXX no locale support yet */
1171 }
1172
1173 bool
1174 Perl_is_uni_alpha_lc(pTHX_ UV c)
1175 {
1176     return is_uni_alpha(c);     /* XXX no locale support yet */
1177 }
1178
1179 bool
1180 Perl_is_uni_ascii_lc(pTHX_ UV c)
1181 {
1182     return is_uni_ascii(c);     /* XXX no locale support yet */
1183 }
1184
1185 bool
1186 Perl_is_uni_space_lc(pTHX_ UV c)
1187 {
1188     return is_uni_space(c);     /* XXX no locale support yet */
1189 }
1190
1191 bool
1192 Perl_is_uni_digit_lc(pTHX_ UV c)
1193 {
1194     return is_uni_digit(c);     /* XXX no locale support yet */
1195 }
1196
1197 bool
1198 Perl_is_uni_upper_lc(pTHX_ UV c)
1199 {
1200     return is_uni_upper(c);     /* XXX no locale support yet */
1201 }
1202
1203 bool
1204 Perl_is_uni_lower_lc(pTHX_ UV c)
1205 {
1206     return is_uni_lower(c);     /* XXX no locale support yet */
1207 }
1208
1209 bool
1210 Perl_is_uni_cntrl_lc(pTHX_ UV c)
1211 {
1212     return is_uni_cntrl(c);     /* XXX no locale support yet */
1213 }
1214
1215 bool
1216 Perl_is_uni_graph_lc(pTHX_ UV c)
1217 {
1218     return is_uni_graph(c);     /* XXX no locale support yet */
1219 }
1220
1221 bool
1222 Perl_is_uni_print_lc(pTHX_ UV c)
1223 {
1224     return is_uni_print(c);     /* XXX no locale support yet */
1225 }
1226
1227 bool
1228 Perl_is_uni_punct_lc(pTHX_ UV c)
1229 {
1230     return is_uni_punct(c);     /* XXX no locale support yet */
1231 }
1232
1233 bool
1234 Perl_is_uni_xdigit_lc(pTHX_ UV c)
1235 {
1236     return is_uni_xdigit(c);    /* XXX no locale support yet */
1237 }
1238
1239 U32
1240 Perl_to_uni_upper_lc(pTHX_ U32 c)
1241 {
1242     /* XXX returns only the first character -- do not use XXX */
1243     /* XXX no locale support yet */
1244     STRLEN len;
1245     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1246     return (U32)to_uni_upper(c, tmpbuf, &len);
1247 }
1248
1249 U32
1250 Perl_to_uni_title_lc(pTHX_ U32 c)
1251 {
1252     /* XXX returns only the first character XXX -- do not use XXX */
1253     /* XXX no locale support yet */
1254     STRLEN len;
1255     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1256     return (U32)to_uni_title(c, tmpbuf, &len);
1257 }
1258
1259 U32
1260 Perl_to_uni_lower_lc(pTHX_ U32 c)
1261 {
1262     /* XXX returns only the first character -- do not use XXX */
1263     /* XXX no locale support yet */
1264     STRLEN len;
1265     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1266     return (U32)to_uni_lower(c, tmpbuf, &len);
1267 }
1268
1269 static bool
1270 S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
1271                  const char *const swashname)
1272 {
1273     dVAR;
1274
1275     PERL_ARGS_ASSERT_IS_UTF8_COMMON;
1276
1277     if (!is_utf8_char(p))
1278         return FALSE;
1279     if (!*swash)
1280         *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0);
1281     return swash_fetch(*swash, p, TRUE) != 0;
1282 }
1283
1284 bool
1285 Perl_is_utf8_alnum(pTHX_ const U8 *p)
1286 {
1287     dVAR;
1288
1289     PERL_ARGS_ASSERT_IS_UTF8_ALNUM;
1290
1291     /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1292      * descendant of isalnum(3), in other words, it doesn't
1293      * contain the '_'. --jhi */
1294     return is_utf8_common(p, &PL_utf8_alnum, "IsWord");
1295 }
1296
1297 bool
1298 Perl_is_utf8_alnumc(pTHX_ const U8 *p)
1299 {
1300     dVAR;
1301
1302     PERL_ARGS_ASSERT_IS_UTF8_ALNUMC;
1303
1304     return is_utf8_common(p, &PL_utf8_alnumc, "IsAlnumC");
1305 }
1306
1307 bool
1308 Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
1309 {
1310     dVAR;
1311
1312     PERL_ARGS_ASSERT_IS_UTF8_IDFIRST;
1313
1314     if (*p == '_')
1315         return TRUE;
1316     /* is_utf8_idstart would be more logical. */
1317     return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
1318 }
1319
1320 bool
1321 Perl_is_utf8_idcont(pTHX_ const U8 *p)
1322 {
1323     dVAR;
1324
1325     PERL_ARGS_ASSERT_IS_UTF8_IDCONT;
1326
1327     if (*p == '_')
1328         return TRUE;
1329     return is_utf8_common(p, &PL_utf8_idcont, "IdContinue");
1330 }
1331
1332 bool
1333 Perl_is_utf8_alpha(pTHX_ const U8 *p)
1334 {
1335     dVAR;
1336
1337     PERL_ARGS_ASSERT_IS_UTF8_ALPHA;
1338
1339     return is_utf8_common(p, &PL_utf8_alpha, "IsAlpha");
1340 }
1341
1342 bool
1343 Perl_is_utf8_ascii(pTHX_ const U8 *p)
1344 {
1345     dVAR;
1346
1347     PERL_ARGS_ASSERT_IS_UTF8_ASCII;
1348
1349     return is_utf8_common(p, &PL_utf8_ascii, "IsAscii");
1350 }
1351
1352 bool
1353 Perl_is_utf8_space(pTHX_ const U8 *p)
1354 {
1355     dVAR;
1356
1357     PERL_ARGS_ASSERT_IS_UTF8_SPACE;
1358
1359     return is_utf8_common(p, &PL_utf8_space, "IsSpacePerl");
1360 }
1361
1362 bool
1363 Perl_is_utf8_digit(pTHX_ const U8 *p)
1364 {
1365     dVAR;
1366
1367     PERL_ARGS_ASSERT_IS_UTF8_DIGIT;
1368
1369     return is_utf8_common(p, &PL_utf8_digit, "IsDigit");
1370 }
1371
1372 bool
1373 Perl_is_utf8_upper(pTHX_ const U8 *p)
1374 {
1375     dVAR;
1376
1377     PERL_ARGS_ASSERT_IS_UTF8_UPPER;
1378
1379     return is_utf8_common(p, &PL_utf8_upper, "IsUppercase");
1380 }
1381
1382 bool
1383 Perl_is_utf8_lower(pTHX_ const U8 *p)
1384 {
1385     dVAR;
1386
1387     PERL_ARGS_ASSERT_IS_UTF8_LOWER;
1388
1389     return is_utf8_common(p, &PL_utf8_lower, "IsLowercase");
1390 }
1391
1392 bool
1393 Perl_is_utf8_cntrl(pTHX_ const U8 *p)
1394 {
1395     dVAR;
1396
1397     PERL_ARGS_ASSERT_IS_UTF8_CNTRL;
1398
1399     return is_utf8_common(p, &PL_utf8_cntrl, "IsCntrl");
1400 }
1401
1402 bool
1403 Perl_is_utf8_graph(pTHX_ const U8 *p)
1404 {
1405     dVAR;
1406
1407     PERL_ARGS_ASSERT_IS_UTF8_GRAPH;
1408
1409     return is_utf8_common(p, &PL_utf8_graph, "IsGraph");
1410 }
1411
1412 bool
1413 Perl_is_utf8_print(pTHX_ const U8 *p)
1414 {
1415     dVAR;
1416
1417     PERL_ARGS_ASSERT_IS_UTF8_PRINT;
1418
1419     return is_utf8_common(p, &PL_utf8_print, "IsPrint");
1420 }
1421
1422 bool
1423 Perl_is_utf8_punct(pTHX_ const U8 *p)
1424 {
1425     dVAR;
1426
1427     PERL_ARGS_ASSERT_IS_UTF8_PUNCT;
1428
1429     return is_utf8_common(p, &PL_utf8_punct, "IsPunct");
1430 }
1431
1432 bool
1433 Perl_is_utf8_xdigit(pTHX_ const U8 *p)
1434 {
1435     dVAR;
1436
1437     PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
1438
1439     return is_utf8_common(p, &PL_utf8_xdigit, "Isxdigit");
1440 }
1441
1442 bool
1443 Perl_is_utf8_mark(pTHX_ const U8 *p)
1444 {
1445     dVAR;
1446
1447     PERL_ARGS_ASSERT_IS_UTF8_MARK;
1448
1449     return is_utf8_common(p, &PL_utf8_mark, "IsM");
1450 }
1451
1452 /*
1453 =for apidoc to_utf8_case
1454
1455 The "p" contains the pointer to the UTF-8 string encoding
1456 the character that is being converted.
1457
1458 The "ustrp" is a pointer to the character buffer to put the
1459 conversion result to.  The "lenp" is a pointer to the length
1460 of the result.
1461
1462 The "swashp" is a pointer to the swash to use.
1463
1464 Both the special and normal mappings are stored lib/unicore/To/Foo.pl,
1465 and loaded by SWASHNEW, using lib/utf8_heavy.pl.  The special (usually,
1466 but not always, a multicharacter mapping), is tried first.
1467
1468 The "special" is a string like "utf8::ToSpecLower", which means the
1469 hash %utf8::ToSpecLower.  The access to the hash is through
1470 Perl_to_utf8_case().
1471
1472 The "normal" is a string like "ToLower" which means the swash
1473 %utf8::ToLower.
1474
1475 =cut */
1476
1477 UV
1478 Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
1479                         SV **swashp, const char *normal, const char *special)
1480 {
1481     dVAR;
1482     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1483     STRLEN len = 0;
1484     const UV uv0 = utf8_to_uvchr(p, NULL);
1485     /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
1486      * are necessary in EBCDIC, they are redundant no-ops
1487      * in ASCII-ish platforms, and hopefully optimized away. */
1488     const UV uv1 = NATIVE_TO_UNI(uv0);
1489
1490     PERL_ARGS_ASSERT_TO_UTF8_CASE;
1491
1492     uvuni_to_utf8(tmpbuf, uv1);
1493
1494     if (!*swashp) /* load on-demand */
1495          *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1496
1497     /* The 0xDF is the only special casing Unicode code point below 0x100. */
1498     if (special && (uv1 == 0xDF || uv1 > 0xFF)) {
1499          /* It might be "special" (sometimes, but not always,
1500           * a multicharacter mapping) */
1501          HV * const hv = get_hv(special, 0);
1502          SV **svp;
1503
1504          if (hv &&
1505              (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
1506              (*svp)) {
1507              const char *s;
1508
1509               s = SvPV_const(*svp, len);
1510               if (len == 1)
1511                    len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
1512               else {
1513 #ifdef EBCDIC
1514                    /* If we have EBCDIC we need to remap the characters
1515                     * since any characters in the low 256 are Unicode
1516                     * code points, not EBCDIC. */
1517                    U8 *t = (U8*)s, *tend = t + len, *d;
1518
1519                    d = tmpbuf;
1520                    if (SvUTF8(*svp)) {
1521                         STRLEN tlen = 0;
1522
1523                         while (t < tend) {
1524                              const UV c = utf8_to_uvchr(t, &tlen);
1525                              if (tlen > 0) {
1526                                   d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
1527                                   t += tlen;
1528                              }
1529                              else
1530                                   break;
1531                         }
1532                    }
1533                    else {
1534                         while (t < tend) {
1535                              d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
1536                              t++;
1537                         }
1538                    }
1539                    len = d - tmpbuf;
1540                    Copy(tmpbuf, ustrp, len, U8);
1541 #else
1542                    Copy(s, ustrp, len, U8);
1543 #endif
1544               }
1545          }
1546     }
1547
1548     if (!len && *swashp) {
1549         const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
1550
1551          if (uv2) {
1552               /* It was "normal" (a single character mapping). */
1553               const UV uv3 = UNI_TO_NATIVE(uv2);
1554               len = uvchr_to_utf8(ustrp, uv3) - ustrp;
1555          }
1556     }
1557
1558     if (!len) /* Neither: just copy. */
1559          len = uvchr_to_utf8(ustrp, uv0) - ustrp;
1560
1561     if (lenp)
1562          *lenp = len;
1563
1564     return len ? utf8_to_uvchr(ustrp, 0) : 0;
1565 }
1566
1567 /*
1568 =for apidoc to_utf8_upper
1569
1570 Convert the UTF-8 encoded character at p to its uppercase version and
1571 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1572 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
1573 the uppercase version may be longer than the original character.
1574
1575 The first character of the uppercased version is returned
1576 (but note, as explained above, that there may be more.)
1577
1578 =cut */
1579
1580 UV
1581 Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1582 {
1583     dVAR;
1584
1585     PERL_ARGS_ASSERT_TO_UTF8_UPPER;
1586
1587     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1588                              &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
1589 }
1590
1591 /*
1592 =for apidoc to_utf8_title
1593
1594 Convert the UTF-8 encoded character at p to its titlecase version and
1595 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1596 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1597 titlecase version may be longer than the original character.
1598
1599 The first character of the titlecased version is returned
1600 (but note, as explained above, that there may be more.)
1601
1602 =cut */
1603
1604 UV
1605 Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1606 {
1607     dVAR;
1608
1609     PERL_ARGS_ASSERT_TO_UTF8_TITLE;
1610
1611     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1612                              &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
1613 }
1614
1615 /*
1616 =for apidoc to_utf8_lower
1617
1618 Convert the UTF-8 encoded character at p to its lowercase version and
1619 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1620 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1621 lowercase version may be longer than the original character.
1622
1623 The first character of the lowercased version is returned
1624 (but note, as explained above, that there may be more.)
1625
1626 =cut */
1627
1628 UV
1629 Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1630 {
1631     dVAR;
1632
1633     PERL_ARGS_ASSERT_TO_UTF8_LOWER;
1634
1635     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1636                              &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
1637 }
1638
1639 /*
1640 =for apidoc to_utf8_fold
1641
1642 Convert the UTF-8 encoded character at p to its foldcase version and
1643 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1644 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1645 foldcase version may be longer than the original character (up to
1646 three characters).
1647
1648 The first character of the foldcased version is returned
1649 (but note, as explained above, that there may be more.)
1650
1651 =cut */
1652
1653 UV
1654 Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1655 {
1656     dVAR;
1657
1658     PERL_ARGS_ASSERT_TO_UTF8_FOLD;
1659
1660     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1661                              &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
1662 }
1663
1664 /* Note:
1665  * A "swash" is a swatch hash.
1666  * A "swatch" is a bit vector generated by utf8.c:S_swash_get().
1667  * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
1668  * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
1669  */
1670 SV*
1671 Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
1672 {
1673     dVAR;
1674     SV* retval;
1675     dSP;
1676     const size_t pkg_len = strlen(pkg);
1677     const size_t name_len = strlen(name);
1678     HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
1679     SV* errsv_save;
1680
1681     PERL_ARGS_ASSERT_SWASH_INIT;
1682
1683     PUSHSTACKi(PERLSI_MAGIC);
1684     ENTER;
1685     SAVEI32(PL_hints);
1686     PL_hints = 0;
1687     save_re_context();
1688     if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) {      /* demand load utf8 */
1689         ENTER;
1690         errsv_save = newSVsv(ERRSV);
1691         /* It is assumed that callers of this routine are not passing in any
1692            user derived data.  */
1693         /* Need to do this after save_re_context() as it will set PL_tainted to
1694            1 while saving $1 etc (see the code after getrx: in Perl_magic_get).
1695            Even line to create errsv_save can turn on PL_tainted.  */
1696         SAVEBOOL(PL_tainted);
1697         PL_tainted = 0;
1698         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
1699                          NULL);
1700         if (!SvTRUE(ERRSV))
1701             sv_setsv(ERRSV, errsv_save);
1702         SvREFCNT_dec(errsv_save);
1703         LEAVE;
1704     }
1705     SPAGAIN;
1706     PUSHMARK(SP);
1707     EXTEND(SP,5);
1708     mPUSHp(pkg, pkg_len);
1709     mPUSHp(name, name_len);
1710     PUSHs(listsv);
1711     mPUSHi(minbits);
1712     mPUSHi(none);
1713     PUTBACK;
1714     errsv_save = newSVsv(ERRSV);
1715     if (call_method("SWASHNEW", G_SCALAR))
1716         retval = newSVsv(*PL_stack_sp--);
1717     else
1718         retval = &PL_sv_undef;
1719     if (!SvTRUE(ERRSV))
1720         sv_setsv(ERRSV, errsv_save);
1721     SvREFCNT_dec(errsv_save);
1722     LEAVE;
1723     POPSTACK;
1724     if (IN_PERL_COMPILETIME) {
1725         CopHINTS_set(PL_curcop, PL_hints);
1726     }
1727     if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
1728         if (SvPOK(retval))
1729             Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
1730                        SVfARG(retval));
1731         Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
1732     }
1733     return retval;
1734 }
1735
1736
1737 /* This API is wrong for special case conversions since we may need to
1738  * return several Unicode characters for a single Unicode character
1739  * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
1740  * the lower-level routine, and it is similarly broken for returning
1741  * multiple values.  --jhi */
1742 /* Now SWASHGET is recasted into S_swash_get in this file. */
1743
1744 /* Note:
1745  * Returns the value of property/mapping C<swash> for the first character
1746  * of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
1747  * assumed to be in utf8. If C<do_utf8> is false, the string C<ptr> is
1748  * assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
1749  */
1750 UV
1751 Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
1752 {
1753     dVAR;
1754     HV *const hv = MUTABLE_HV(SvRV(swash));
1755     U32 klen;
1756     U32 off;
1757     STRLEN slen;
1758     STRLEN needents;
1759     const U8 *tmps = NULL;
1760     U32 bit;
1761     SV *swatch;
1762     U8 tmputf8[2];
1763     const UV c = NATIVE_TO_ASCII(*ptr);
1764
1765     PERL_ARGS_ASSERT_SWASH_FETCH;
1766
1767     if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
1768         tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
1769         tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
1770         ptr = tmputf8;
1771     }
1772     /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
1773      * then the "swatch" is a vec() for al the chars which start
1774      * with 0xAA..0xYY
1775      * So the key in the hash (klen) is length of encoded char -1
1776      */
1777     klen = UTF8SKIP(ptr) - 1;
1778     off  = ptr[klen];
1779
1780     if (klen == 0) {
1781       /* If char in invariant then swatch is for all the invariant chars
1782        * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
1783        */
1784         needents = UTF_CONTINUATION_MARK;
1785         off      = NATIVE_TO_UTF(ptr[klen]);
1786     }
1787     else {
1788       /* If char is encoded then swatch is for the prefix */
1789         needents = (1 << UTF_ACCUMULATION_SHIFT);
1790         off      = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
1791     }
1792
1793     /*
1794      * This single-entry cache saves about 1/3 of the utf8 overhead in test
1795      * suite.  (That is, only 7-8% overall over just a hash cache.  Still,
1796      * it's nothing to sniff at.)  Pity we usually come through at least
1797      * two function calls to get here...
1798      *
1799      * NB: this code assumes that swatches are never modified, once generated!
1800      */
1801
1802     if (hv   == PL_last_swash_hv &&
1803         klen == PL_last_swash_klen &&
1804         (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
1805     {
1806         tmps = PL_last_swash_tmps;
1807         slen = PL_last_swash_slen;
1808     }
1809     else {
1810         /* Try our second-level swatch cache, kept in a hash. */
1811         SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE);
1812
1813         /* If not cached, generate it via swash_get */
1814         if (!svp || !SvPOK(*svp)
1815                  || !(tmps = (const U8*)SvPV_const(*svp, slen))) {
1816             /* We use utf8n_to_uvuni() as we want an index into
1817                Unicode tables, not a native character number.
1818              */
1819             const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
1820                                            ckWARN(WARN_UTF8) ?
1821                                            0 : UTF8_ALLOW_ANY);
1822             swatch = swash_get(swash,
1823                     /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
1824                                 (klen) ? (code_point & ~(needents - 1)) : 0,
1825                                 needents);
1826
1827             if (IN_PERL_COMPILETIME)
1828                 CopHINTS_set(PL_curcop, PL_hints);
1829
1830             svp = hv_store(hv, (const char *)ptr, klen, swatch, 0);
1831
1832             if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
1833                      || (slen << 3) < needents)
1834                 Perl_croak(aTHX_ "panic: swash_fetch got improper swatch");
1835         }
1836
1837         PL_last_swash_hv = hv;
1838         assert(klen <= sizeof(PL_last_swash_key));
1839         PL_last_swash_klen = (U8)klen;
1840         /* FIXME change interpvar.h?  */
1841         PL_last_swash_tmps = (U8 *) tmps;
1842         PL_last_swash_slen = slen;
1843         if (klen)
1844             Copy(ptr, PL_last_swash_key, klen, U8);
1845     }
1846
1847     switch ((int)((slen << 3) / needents)) {
1848     case 1:
1849         bit = 1 << (off & 7);
1850         off >>= 3;
1851         return (tmps[off] & bit) != 0;
1852     case 8:
1853         return tmps[off];
1854     case 16:
1855         off <<= 1;
1856         return (tmps[off] << 8) + tmps[off + 1] ;
1857     case 32:
1858         off <<= 2;
1859         return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1860     }
1861     Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width");
1862     NORETURN_FUNCTION_END;
1863 }
1864
1865 /* Note:
1866  * Returns a swatch (a bit vector string) for a code point sequence
1867  * that starts from the value C<start> and comprises the number C<span>.
1868  * A C<swash> must be an object created by SWASHNEW (see lib/utf8_heavy.pl).
1869  * Should be used via swash_fetch, which will cache the swatch in C<swash>.
1870  */
1871 STATIC SV*
1872 S_swash_get(pTHX_ SV* swash, UV start, UV span)
1873 {
1874     SV *swatch;
1875     U8 *l, *lend, *x, *xend, *s;
1876     STRLEN lcur, xcur, scur;
1877     HV *const hv = MUTABLE_HV(SvRV(swash));
1878     SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
1879     SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
1880     SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
1881     SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
1882     SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
1883     const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
1884     const int  typeto  = typestr[0] == 'T' && typestr[1] == 'o';
1885     const STRLEN bits  = SvUV(*bitssvp);
1886     const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
1887     const UV     none  = SvUV(*nonesvp);
1888     const UV     end   = start + span;
1889
1890     PERL_ARGS_ASSERT_SWASH_GET;
1891
1892     if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
1893         Perl_croak(aTHX_ "panic: swash_get doesn't expect bits %"UVuf,
1894                                                  (UV)bits);
1895     }
1896
1897     /* create and initialize $swatch */
1898     scur   = octets ? (span * octets) : (span + 7) / 8;
1899     swatch = newSV(scur);
1900     SvPOK_on(swatch);
1901     s = (U8*)SvPVX(swatch);
1902     if (octets && none) {
1903         const U8* const e = s + scur;
1904         while (s < e) {
1905             if (bits == 8)
1906                 *s++ = (U8)(none & 0xff);
1907             else if (bits == 16) {
1908                 *s++ = (U8)((none >>  8) & 0xff);
1909                 *s++ = (U8)( none        & 0xff);
1910             }
1911             else if (bits == 32) {
1912                 *s++ = (U8)((none >> 24) & 0xff);
1913                 *s++ = (U8)((none >> 16) & 0xff);
1914                 *s++ = (U8)((none >>  8) & 0xff);
1915                 *s++ = (U8)( none        & 0xff);
1916             }
1917         }
1918         *s = '\0';
1919     }
1920     else {
1921         (void)memzero((U8*)s, scur + 1);
1922     }
1923     SvCUR_set(swatch, scur);
1924     s = (U8*)SvPVX(swatch);
1925
1926     /* read $swash->{LIST} */
1927     l = (U8*)SvPV(*listsvp, lcur);
1928     lend = l + lcur;
1929     while (l < lend) {
1930         UV min, max, val;
1931         STRLEN numlen;
1932         I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1933
1934         U8* const nl = (U8*)memchr(l, '\n', lend - l);
1935
1936         numlen = lend - l;
1937         min = grok_hex((char *)l, &numlen, &flags, NULL);
1938         if (numlen)
1939             l += numlen;
1940         else if (nl) {
1941             l = nl + 1; /* 1 is length of "\n" */
1942             continue;
1943         }
1944         else {
1945             l = lend; /* to LIST's end at which \n is not found */
1946             break;
1947         }
1948
1949         if (isBLANK(*l)) {
1950             ++l;
1951             flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1952             numlen = lend - l;
1953             max = grok_hex((char *)l, &numlen, &flags, NULL);
1954             if (numlen)
1955                 l += numlen;
1956             else
1957                 max = min;
1958
1959             if (octets) {
1960                 if (isBLANK(*l)) {
1961                     ++l;
1962                     flags = PERL_SCAN_SILENT_ILLDIGIT |
1963                             PERL_SCAN_DISALLOW_PREFIX;
1964                     numlen = lend - l;
1965                     val = grok_hex((char *)l, &numlen, &flags, NULL);
1966                     if (numlen)
1967                         l += numlen;
1968                     else
1969                         val = 0;
1970                 }
1971                 else {
1972                     val = 0;
1973                     if (typeto) {
1974                         Perl_croak(aTHX_ "%s: illegal mapping '%s'",
1975                                          typestr, l);
1976                     }
1977                 }
1978             }
1979             else
1980                 val = 0; /* bits == 1, then val should be ignored */
1981         }
1982         else {
1983             max = min;
1984             if (octets) {
1985                 val = 0;
1986                 if (typeto) {
1987                     Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
1988                 }
1989             }
1990             else
1991                 val = 0; /* bits == 1, then val should be ignored */
1992         }
1993
1994         if (nl)
1995             l = nl + 1;
1996         else
1997             l = lend;
1998
1999         if (max < start)
2000             continue;
2001
2002         if (octets) {
2003             UV key;
2004             if (min < start) {
2005                 if (!none || val < none) {
2006                     val += start - min;
2007                 }
2008                 min = start;
2009             }
2010             for (key = min; key <= max; key++) {
2011                 STRLEN offset;
2012                 if (key >= end)
2013                     goto go_out_list;
2014                 /* offset must be non-negative (start <= min <= key < end) */
2015                 offset = octets * (key - start);
2016                 if (bits == 8)
2017                     s[offset] = (U8)(val & 0xff);
2018                 else if (bits == 16) {
2019                     s[offset    ] = (U8)((val >>  8) & 0xff);
2020                     s[offset + 1] = (U8)( val        & 0xff);
2021                 }
2022                 else if (bits == 32) {
2023                     s[offset    ] = (U8)((val >> 24) & 0xff);
2024                     s[offset + 1] = (U8)((val >> 16) & 0xff);
2025                     s[offset + 2] = (U8)((val >>  8) & 0xff);
2026                     s[offset + 3] = (U8)( val        & 0xff);
2027                 }
2028
2029                 if (!none || val < none)
2030                     ++val;
2031             }
2032         }
2033         else { /* bits == 1, then val should be ignored */
2034             UV key;
2035             if (min < start)
2036                 min = start;
2037             for (key = min; key <= max; key++) {
2038                 const STRLEN offset = (STRLEN)(key - start);
2039                 if (key >= end)
2040                     goto go_out_list;
2041                 s[offset >> 3] |= 1 << (offset & 7);
2042             }
2043         }
2044     } /* while */
2045   go_out_list:
2046
2047     /* read $swash->{EXTRAS} */
2048     x = (U8*)SvPV(*extssvp, xcur);
2049     xend = x + xcur;
2050     while (x < xend) {
2051         STRLEN namelen;
2052         U8 *namestr;
2053         SV** othersvp;
2054         HV* otherhv;
2055         STRLEN otherbits;
2056         SV **otherbitssvp, *other;
2057         U8 *s, *o, *nl;
2058         STRLEN slen, olen;
2059
2060         const U8 opc = *x++;
2061         if (opc == '\n')
2062             continue;
2063
2064         nl = (U8*)memchr(x, '\n', xend - x);
2065
2066         if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
2067             if (nl) {
2068                 x = nl + 1; /* 1 is length of "\n" */
2069                 continue;
2070             }
2071             else {
2072                 x = xend; /* to EXTRAS' end at which \n is not found */
2073                 break;
2074             }
2075         }
2076
2077         namestr = x;
2078         if (nl) {
2079             namelen = nl - namestr;
2080             x = nl + 1;
2081         }
2082         else {
2083             namelen = xend - namestr;
2084             x = xend;
2085         }
2086
2087         othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
2088         otherhv = MUTABLE_HV(SvRV(*othersvp));
2089         otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
2090         otherbits = (STRLEN)SvUV(*otherbitssvp);
2091         if (bits < otherbits)
2092             Perl_croak(aTHX_ "panic: swash_get found swatch size mismatch");
2093
2094         /* The "other" swatch must be destroyed after. */
2095         other = swash_get(*othersvp, start, span);
2096         o = (U8*)SvPV(other, olen);
2097
2098         if (!olen)
2099             Perl_croak(aTHX_ "panic: swash_get got improper swatch");
2100
2101         s = (U8*)SvPV(swatch, slen);
2102         if (bits == 1 && otherbits == 1) {
2103             if (slen != olen)
2104                 Perl_croak(aTHX_ "panic: swash_get found swatch length mismatch");
2105
2106             switch (opc) {
2107             case '+':
2108                 while (slen--)
2109                     *s++ |= *o++;
2110                 break;
2111             case '!':
2112                 while (slen--)
2113                     *s++ |= ~*o++;
2114                 break;
2115             case '-':
2116                 while (slen--)
2117                     *s++ &= ~*o++;
2118                 break;
2119             case '&':
2120                 while (slen--)
2121                     *s++ &= *o++;
2122                 break;
2123             default:
2124                 break;
2125             }
2126         }
2127         else {
2128             STRLEN otheroctets = otherbits >> 3;
2129             STRLEN offset = 0;
2130             U8* const send = s + slen;
2131
2132             while (s < send) {
2133                 UV otherval = 0;
2134
2135                 if (otherbits == 1) {
2136                     otherval = (o[offset >> 3] >> (offset & 7)) & 1;
2137                     ++offset;
2138                 }
2139                 else {
2140                     STRLEN vlen = otheroctets;
2141                     otherval = *o++;
2142                     while (--vlen) {
2143                         otherval <<= 8;
2144                         otherval |= *o++;
2145                     }
2146                 }
2147
2148                 if (opc == '+' && otherval)
2149                     NOOP;   /* replace with otherval */
2150                 else if (opc == '!' && !otherval)
2151                     otherval = 1;
2152                 else if (opc == '-' && otherval)
2153                     otherval = 0;
2154                 else if (opc == '&' && !otherval)
2155                     otherval = 0;
2156                 else {
2157                     s += octets; /* no replacement */
2158                     continue;
2159                 }
2160
2161                 if (bits == 8)
2162                     *s++ = (U8)( otherval & 0xff);
2163                 else if (bits == 16) {
2164                     *s++ = (U8)((otherval >>  8) & 0xff);
2165                     *s++ = (U8)( otherval        & 0xff);
2166                 }
2167                 else if (bits == 32) {
2168                     *s++ = (U8)((otherval >> 24) & 0xff);
2169                     *s++ = (U8)((otherval >> 16) & 0xff);
2170                     *s++ = (U8)((otherval >>  8) & 0xff);
2171                     *s++ = (U8)( otherval        & 0xff);
2172                 }
2173             }
2174         }
2175         sv_free(other); /* through with it! */
2176     } /* while */
2177     return swatch;
2178 }
2179
2180 /*
2181 =for apidoc uvchr_to_utf8
2182
2183 Adds the UTF-8 representation of the Native codepoint C<uv> to the end
2184 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
2185 bytes available. The return value is the pointer to the byte after the
2186 end of the new character. In other words,
2187
2188     d = uvchr_to_utf8(d, uv);
2189
2190 is the recommended wide native character-aware way of saying
2191
2192     *(d++) = uv;
2193
2194 =cut
2195 */
2196
2197 /* On ASCII machines this is normally a macro but we want a
2198    real function in case XS code wants it
2199 */
2200 U8 *
2201 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
2202 {
2203     PERL_ARGS_ASSERT_UVCHR_TO_UTF8;
2204
2205     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
2206 }
2207
2208 U8 *
2209 Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
2210 {
2211     PERL_ARGS_ASSERT_UVCHR_TO_UTF8_FLAGS;
2212
2213     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
2214 }
2215
2216 /*
2217 =for apidoc utf8n_to_uvchr
2218 flags
2219
2220 Returns the native character value of the first character in the string
2221 C<s>
2222 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
2223 length, in bytes, of that character.
2224
2225 Allows length and flags to be passed to low level routine.
2226
2227 =cut
2228 */
2229 /* On ASCII machines this is normally a macro but we want
2230    a real function in case XS code wants it
2231 */
2232 UV
2233 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
2234 U32 flags)
2235 {
2236     const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
2237
2238     PERL_ARGS_ASSERT_UTF8N_TO_UVCHR;
2239
2240     return UNI_TO_NATIVE(uv);
2241 }
2242
2243 /*
2244 =for apidoc pv_uni_display
2245
2246 Build to the scalar dsv a displayable version of the string spv,
2247 length len, the displayable version being at most pvlim bytes long
2248 (if longer, the rest is truncated and "..." will be appended).
2249
2250 The flags argument can have UNI_DISPLAY_ISPRINT set to display
2251 isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
2252 to display the \\[nrfta\\] as the backslashed versions (like '\n')
2253 (UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
2254 UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
2255 UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
2256
2257 The pointer to the PV of the dsv is returned.
2258
2259 =cut */
2260 char *
2261 Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
2262 {
2263     int truncated = 0;
2264     const char *s, *e;
2265
2266     PERL_ARGS_ASSERT_PV_UNI_DISPLAY;
2267
2268     sv_setpvs(dsv, "");
2269     SvUTF8_off(dsv);
2270     for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
2271          UV u;
2272           /* This serves double duty as a flag and a character to print after
2273              a \ when flags & UNI_DISPLAY_BACKSLASH is true.
2274           */
2275          char ok = 0;
2276
2277          if (pvlim && SvCUR(dsv) >= pvlim) {
2278               truncated++;
2279               break;
2280          }
2281          u = utf8_to_uvchr((U8*)s, 0);
2282          if (u < 256) {
2283              const unsigned char c = (unsigned char)u & 0xFF;
2284              if (flags & UNI_DISPLAY_BACKSLASH) {
2285                  switch (c) {
2286                  case '\n':
2287                      ok = 'n'; break;
2288                  case '\r':
2289                      ok = 'r'; break;
2290                  case '\t':
2291                      ok = 't'; break;
2292                  case '\f':
2293                      ok = 'f'; break;
2294                  case '\a':
2295                      ok = 'a'; break;
2296                  case '\\':
2297                      ok = '\\'; break;
2298                  default: break;
2299                  }
2300                  if (ok) {
2301                      const char string = ok;
2302                      sv_catpvs(dsv, "\\");
2303                      sv_catpvn(dsv, &string, 1);
2304                  }
2305              }
2306              /* isPRINT() is the locale-blind version. */
2307              if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
2308                  const char string = c;
2309                  sv_catpvn(dsv, &string, 1);
2310                  ok = 1;
2311              }
2312          }
2313          if (!ok)
2314              Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
2315     }
2316     if (truncated)
2317          sv_catpvs(dsv, "...");
2318
2319     return SvPVX(dsv);
2320 }
2321
2322 /*
2323 =for apidoc sv_uni_display
2324
2325 Build to the scalar dsv a displayable version of the scalar sv,
2326 the displayable version being at most pvlim bytes long
2327 (if longer, the rest is truncated and "..." will be appended).
2328
2329 The flags argument is as in pv_uni_display().
2330
2331 The pointer to the PV of the dsv is returned.
2332
2333 =cut
2334 */
2335 char *
2336 Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
2337 {
2338     PERL_ARGS_ASSERT_SV_UNI_DISPLAY;
2339
2340      return Perl_pv_uni_display(aTHX_ dsv, (const U8*)SvPVX_const(ssv),
2341                                 SvCUR(ssv), pvlim, flags);
2342 }
2343
2344 /*
2345 =for apidoc ibcmp_utf8
2346
2347 Return true if the strings s1 and s2 differ case-insensitively, false
2348 if not (if they are equal case-insensitively).  If u1 is true, the
2349 string s1 is assumed to be in UTF-8-encoded Unicode.  If u2 is true,
2350 the string s2 is assumed to be in UTF-8-encoded Unicode.  If u1 or u2
2351 are false, the respective string is assumed to be in native 8-bit
2352 encoding.
2353
2354 If the pe1 and pe2 are non-NULL, the scanning pointers will be copied
2355 in there (they will point at the beginning of the I<next> character).
2356 If the pointers behind pe1 or pe2 are non-NULL, they are the end
2357 pointers beyond which scanning will not continue under any
2358 circumstances.  If the byte lengths l1 and l2 are non-zero, s1+l1 and
2359 s2+l2 will be used as goal end pointers that will also stop the scan,
2360 and which qualify towards defining a successful match: all the scans
2361 that define an explicit length must reach their goal pointers for
2362 a match to succeed).
2363
2364 For case-insensitiveness, the "casefolding" of Unicode is used
2365 instead of upper/lowercasing both the characters, see
2366 http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
2367
2368 =cut */
2369 I32
2370 Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
2371 {
2372      dVAR;
2373      register const U8 *p1  = (const U8*)s1;
2374      register const U8 *p2  = (const U8*)s2;
2375      register const U8 *f1 = NULL;
2376      register const U8 *f2 = NULL;
2377      register U8 *e1 = NULL;
2378      register U8 *q1 = NULL;
2379      register U8 *e2 = NULL;
2380      register U8 *q2 = NULL;
2381      STRLEN n1 = 0, n2 = 0;
2382      U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
2383      U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
2384      U8 natbuf[1+1];
2385      STRLEN foldlen1, foldlen2;
2386      bool match;
2387
2388      PERL_ARGS_ASSERT_IBCMP_UTF8;
2389
2390      if (pe1)
2391           e1 = *(U8**)pe1;
2392      /* assert(e1 || l1); */
2393      if (e1 == 0 || (l1 && l1 < (UV)(e1 - (const U8*)s1)))
2394           f1 = (const U8*)s1 + l1;
2395      if (pe2)
2396           e2 = *(U8**)pe2;
2397      /* assert(e2 || l2); */
2398      if (e2 == 0 || (l2 && l2 < (UV)(e2 - (const U8*)s2)))
2399           f2 = (const U8*)s2 + l2;
2400
2401      /* This shouldn't happen. However, putting an assert() there makes some
2402       * tests fail. */
2403      /* assert((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0)); */
2404      if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0))
2405           return 1; /* mismatch; possible infinite loop or false positive */
2406
2407      if (!u1 || !u2)
2408           natbuf[1] = 0; /* Need to terminate the buffer. */
2409
2410      while ((e1 == 0 || p1 < e1) &&
2411             (f1 == 0 || p1 < f1) &&
2412             (e2 == 0 || p2 < e2) &&
2413             (f2 == 0 || p2 < f2)) {
2414           if (n1 == 0) {
2415                if (u1)
2416                     to_utf8_fold(p1, foldbuf1, &foldlen1);
2417                else {
2418                     uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p1)));
2419                     to_utf8_fold(natbuf, foldbuf1, &foldlen1);
2420                }
2421                q1 = foldbuf1;
2422                n1 = foldlen1;
2423           }
2424           if (n2 == 0) {
2425                if (u2)
2426                     to_utf8_fold(p2, foldbuf2, &foldlen2);
2427                else {
2428                     uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p2)));
2429                     to_utf8_fold(natbuf, foldbuf2, &foldlen2);
2430                }
2431                q2 = foldbuf2;
2432                n2 = foldlen2;
2433           }
2434           while (n1 && n2) {
2435                if ( UTF8SKIP(q1) != UTF8SKIP(q2) ||
2436                    (UTF8SKIP(q1) == 1 && *q1 != *q2) ||
2437                     memNE((char*)q1, (char*)q2, UTF8SKIP(q1)) )
2438                    return 1; /* mismatch */
2439                n1 -= UTF8SKIP(q1);
2440                q1 += UTF8SKIP(q1);
2441                n2 -= UTF8SKIP(q2);
2442                q2 += UTF8SKIP(q2);
2443           }
2444           if (n1 == 0)
2445                p1 += u1 ? UTF8SKIP(p1) : 1;
2446           if (n2 == 0)
2447                p2 += u2 ? UTF8SKIP(p2) : 1;
2448
2449      }
2450
2451      /* A match is defined by all the scans that specified
2452       * an explicit length reaching their final goals. */
2453      match = (f1 == 0 || p1 == f1) && (f2 == 0 || p2 == f2);
2454
2455      if (match) {
2456           if (pe1)
2457                *pe1 = (char*)p1;
2458           if (pe2)
2459                *pe2 = (char*)p2;
2460      }
2461
2462      return match ? 0 : 1; /* 0 match, 1 mismatch */
2463 }
2464
2465 /*
2466  * Local variables:
2467  * c-indentation-style: bsd
2468  * c-basic-offset: 4
2469  * indent-tabs-mode: t
2470  * End:
2471  *
2472  * ex: set ts=8 sts=4 sw=4 noet:
2473  */