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