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 non-character 0x%04"UVxf" is illegal for interchange", 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 (PL_op)
 735             Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
 736                              "%s in %s", unees, OP_DESC(PL_op));
 737         else
 738             Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), unees);
 739     }
 740
 741     return len;
 742 }
 743
 744 /*
 745 =for apidoc utf8_distance
 746
 747 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
 748 and C<b>.
 749
 750 WARNING: use only if you *know* that the pointers point inside the
 751 same UTF-8 buffer.
 752
 753 =cut
 754 */
 755
 756 IV
 757 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
 758 {
 759     PERL_ARGS_ASSERT_UTF8_DISTANCE;
 760
 761     return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
 762 }
 763
 764 /*
 765 =for apidoc utf8_hop
 766
 767 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
 768 forward or backward.
 769
 770 WARNING: do not use the following unless you *know* C<off> is within
 771 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
 772 on the first byte of character or just after the last byte of a character.
 773
 774 =cut
 775 */
 776
 777 U8 *
 778 Perl_utf8_hop(pTHX_ const U8 *s, I32 off)
 779 {
 780     PERL_ARGS_ASSERT_UTF8_HOP;
 781
 782     PERL_UNUSED_CONTEXT;
 783     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
 784      * the bitops (especially ~) can create illegal UTF-8.
 785      * In other words: in Perl UTF-8 is not just for Unicode. */
 786
 787     if (off >= 0) {
 788         while (off--)
 789             s += UTF8SKIP(s);
 790     }
 791     else {
 792         while (off++) {
 793             s--;
 794             while (UTF8_IS_CONTINUATION(*s))
 795                 s--;
 796         }
 797     }
 798     return (U8 *)s;
 799 }
 800
 801 /*
 802 =for apidoc utf8_to_bytes
 803
 804 Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
 805 Unlike C<bytes_to_utf8>, this over-writes the original string, and
 806 updates len to contain the new length.
 807 Returns zero on failure, setting C<len> to -1.
 808
 809 If you need a copy of the string, see C<bytes_from_utf8>.
 810
 811 =cut
 812 */
 813
 814 U8 *
 815 Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
 816 {
 817     U8 * const save = s;
 818     U8 * const send = s + *len;
 819     U8 *d;
 820
 821     PERL_ARGS_ASSERT_UTF8_TO_BYTES;
 822
 823     /* ensure valid UTF-8 and chars < 256 before updating string */
 824     while (s < send) {
 825         U8 c = *s++;
 826
 827         if (!UTF8_IS_INVARIANT(c) &&
 828             (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
 829              || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
 830             *len = ((STRLEN) -1);
 831             return 0;
 832         }
 833     }
 834
 835     d = s = save;
 836     while (s < send) {
 837         STRLEN ulen;
 838         *d++ = (U8)utf8_to_uvchr(s, &ulen);
 839         s += ulen;
 840     }
 841     *d = '\0';
 842     *len = d - save;
 843     return save;
 844 }
 845
 846 /*
 847 =for apidoc bytes_from_utf8
 848
 849 Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
 850 Unlike C<utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
 851 the newly-created string, and updates C<len> to contain the new
 852 length.  Returns the original string if no conversion occurs, C<len>
 853 is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
 854 0 if C<s> is converted or consisted entirely of characters that are invariant
 855 in utf8 (i.e., US-ASCII on non-EBCDIC machines).
 856
 857 =cut
 858 */
 859
 860 U8 *
 861 Perl_bytes_from_utf8(pTHX_ const U8 *s, STRLEN *len, bool *is_utf8)
 862 {
 863     U8 *d;
 864     const U8 *start = s;
 865     const U8 *send;
 866     I32 count = 0;
 867
 868     PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
 869
 870     PERL_UNUSED_CONTEXT;
 871     if (!*is_utf8)
 872         return (U8 *)start;
 873
 874     /* ensure valid UTF-8 and chars < 256 before converting string */
 875     for (send = s + *len; s < send;) {
 876         U8 c = *s++;
 877         if (!UTF8_IS_INVARIANT(c)) {
 878             if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
 879                 (c = *s++) && UTF8_IS_CONTINUATION(c))
 880                 count++;
 881             else
 882                 return (U8 *)start;
 883         }
 884     }
 885
 886     *is_utf8 = FALSE;
 887
 888     Newx(d, (*len) - count + 1, U8);
 889     s = start; start = d;
 890     while (s < send) {
 891         U8 c = *s++;
 892         if (!UTF8_IS_INVARIANT(c)) {
 893             /* Then it is two-byte encoded */
 894             c = UTF8_ACCUMULATE(NATIVE_TO_UTF(c), *s++);
 895             c = ASCII_TO_NATIVE(c);
 896         }
 897         *d++ = c;
 898     }
 899     *d = '\0';
 900     *len = d - start;
 901     return (U8 *)start;
 902 }
 903
 904 /*
 905 =for apidoc bytes_to_utf8
 906
 907 Converts a string C<s> of length C<len> from the native encoding into UTF-8.
 908 Returns a pointer to the newly-created string, and sets C<len> to
 909 reflect the new length.
 910
 911 A NUL character will be written after the end of the string.
 912
 913 If you want to convert to UTF-8 from encodings other than
 914 the native (Latin1 or EBCDIC),
 915 see sv_recode_to_utf8().
 916
 917 =cut
 918 */
 919
 920 U8*
 921 Perl_bytes_to_utf8(pTHX_ const U8 *s, STRLEN *len)
 922 {
 923     const U8 * const send = s + (*len);
 924     U8 *d;
 925     U8 *dst;
 926
 927     PERL_ARGS_ASSERT_BYTES_TO_UTF8;
 928     PERL_UNUSED_CONTEXT;
 929
 930     Newx(d, (*len) * 2 + 1, U8);
 931     dst = d;
 932
 933     while (s < send) {
 934         const UV uv = NATIVE_TO_ASCII(*s++);
 935         if (UNI_IS_INVARIANT(uv))
 936             *d++ = (U8)UTF_TO_NATIVE(uv);
 937         else {
 938             *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
 939             *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
 940         }
 941     }
 942     *d = '\0';
 943     *len = d-dst;
 944     return dst;
 945 }
 946
 947 /*
 948  * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
 949  *
 950  * Destination must be pre-extended to 3/2 source.  Do not use in-place.
 951  * We optimize for native, for obvious reasons. */
 952
 953 U8*
 954 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 955 {
 956     U8* pend;
 957     U8* dstart = d;
 958
 959     PERL_ARGS_ASSERT_UTF16_TO_UTF8;
 960
 961     if (bytelen == 1 && p[0] == 0) { /* Be understanding. */
 962          d[0] = 0;
 963          *newlen = 1;
 964          return d;
 965     }
 966
 967     if (bytelen & 1)
 968         Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %"UVuf, (UV)bytelen);
 969
 970     pend = p + bytelen;
 971
 972     while (p < pend) {
 973         UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
 974         p += 2;
 975         if (uv < 0x80) {
 976 #ifdef EBCDIC
 977             *d++ = UNI_TO_NATIVE(uv);
 978 #else
 979             *d++ = (U8)uv;
 980 #endif
 981             continue;
 982         }
 983         if (uv < 0x800) {
 984             *d++ = (U8)(( uv >>  6)         | 0xc0);
 985             *d++ = (U8)(( uv        & 0x3f) | 0x80);
 986             continue;
 987         }
 988         if (uv >= 0xd800 && uv <= 0xdbff) {     /* surrogates */
 989             if (p >= pend) {
 990                 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
 991             } else {
 992                 UV low = (p[0] << 8) + p[1];
 993                 p += 2;
 994                 if (low < 0xdc00 || low > 0xdfff)
 995                     Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
 996                 uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
 997             }
 998         } else if (uv >= 0xdc00 && uv <= 0xdfff) {
 999             Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
1000         }
1001         if (uv < 0x10000) {
1002             *d++ = (U8)(( uv >> 12)         | 0xe0);
1003             *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
1004             *d++ = (U8)(( uv        & 0x3f) | 0x80);
1005             continue;
1006         }
1007         else {
1008             *d++ = (U8)(( uv >> 18)         | 0xf0);
1009             *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
1010             *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
1011             *d++ = (U8)(( uv        & 0x3f) | 0x80);
1012             continue;
1013         }
1014     }
1015     *newlen = d - dstart;
1016     return d;
1017 }
1018
1019 /* Note: this one is slightly destructive of the source. */
1020
1021 U8*
1022 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
1023 {
1024     U8* s = (U8*)p;
1025     U8* const send = s + bytelen;
1026
1027     PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED;
1028
1029     if (bytelen & 1)
1030         Perl_croak(aTHX_ "panic: utf16_to_utf8_reversed: odd bytelen %"UVuf,
1031                    (UV)bytelen);
1032
1033     while (s < send) {
1034         const U8 tmp = s[0];
1035         s[0] = s[1];
1036         s[1] = tmp;
1037         s += 2;
1038     }
1039     return utf16_to_utf8(p, d, bytelen, newlen);
1040 }
1041
1042 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
1043
1044 bool
1045 Perl_is_uni_alnum(pTHX_ UV c)
1046 {
1047     U8 tmpbuf[UTF8_MAXBYTES+1];
1048     uvchr_to_utf8(tmpbuf, c);
1049     return is_utf8_alnum(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_idfirst_lc(pTHX_ UV c)
1194 {
1195     return is_uni_idfirst(c);   /* XXX no locale support yet */
1196 }
1197
1198 bool
1199 Perl_is_uni_alpha_lc(pTHX_ UV c)
1200 {
1201     return is_uni_alpha(c);     /* XXX no locale support yet */
1202 }
1203
1204 bool
1205 Perl_is_uni_ascii_lc(pTHX_ UV c)
1206 {
1207     return is_uni_ascii(c);     /* XXX no locale support yet */
1208 }
1209
1210 bool
1211 Perl_is_uni_space_lc(pTHX_ UV c)
1212 {
1213     return is_uni_space(c);     /* XXX no locale support yet */
1214 }
1215
1216 bool
1217 Perl_is_uni_digit_lc(pTHX_ UV c)
1218 {
1219     return is_uni_digit(c);     /* XXX no locale support yet */
1220 }
1221
1222 bool
1223 Perl_is_uni_upper_lc(pTHX_ UV c)
1224 {
1225     return is_uni_upper(c);     /* XXX no locale support yet */
1226 }
1227
1228 bool
1229 Perl_is_uni_lower_lc(pTHX_ UV c)
1230 {
1231     return is_uni_lower(c);     /* XXX no locale support yet */
1232 }
1233
1234 bool
1235 Perl_is_uni_cntrl_lc(pTHX_ UV c)
1236 {
1237     return is_uni_cntrl(c);     /* XXX no locale support yet */
1238 }
1239
1240 bool
1241 Perl_is_uni_graph_lc(pTHX_ UV c)
1242 {
1243     return is_uni_graph(c);     /* XXX no locale support yet */
1244 }
1245
1246 bool
1247 Perl_is_uni_print_lc(pTHX_ UV c)
1248 {
1249     return is_uni_print(c);     /* XXX no locale support yet */
1250 }
1251
1252 bool
1253 Perl_is_uni_punct_lc(pTHX_ UV c)
1254 {
1255     return is_uni_punct(c);     /* XXX no locale support yet */
1256 }
1257
1258 bool
1259 Perl_is_uni_xdigit_lc(pTHX_ UV c)
1260 {
1261     return is_uni_xdigit(c);    /* XXX no locale support yet */
1262 }
1263
1264 U32
1265 Perl_to_uni_upper_lc(pTHX_ U32 c)
1266 {
1267     /* XXX returns only the first character -- do not use XXX */
1268     /* XXX no locale support yet */
1269     STRLEN len;
1270     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1271     return (U32)to_uni_upper(c, tmpbuf, &len);
1272 }
1273
1274 U32
1275 Perl_to_uni_title_lc(pTHX_ U32 c)
1276 {
1277     /* XXX returns only the first character XXX -- do not use XXX */
1278     /* XXX no locale support yet */
1279     STRLEN len;
1280     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1281     return (U32)to_uni_title(c, tmpbuf, &len);
1282 }
1283
1284 U32
1285 Perl_to_uni_lower_lc(pTHX_ U32 c)
1286 {
1287     /* XXX returns only the first character -- do not use XXX */
1288     /* XXX no locale support yet */
1289     STRLEN len;
1290     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1291     return (U32)to_uni_lower(c, tmpbuf, &len);
1292 }
1293
1294 static bool
1295 S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
1296                  const char *const swashname)
1297 {
1298     dVAR;
1299
1300     PERL_ARGS_ASSERT_IS_UTF8_COMMON;
1301
1302     if (!is_utf8_char(p))
1303         return FALSE;
1304     if (!*swash)
1305         *swash = swash_init("utf8", swashname, &PL_sv_undef, 1, 0);
1306     return swash_fetch(*swash, p, TRUE) != 0;
1307 }
1308
1309 bool
1310 Perl_is_utf8_alnum(pTHX_ const U8 *p)
1311 {
1312     dVAR;
1313
1314     PERL_ARGS_ASSERT_IS_UTF8_ALNUM;
1315
1316     /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1317      * descendant of isalnum(3), in other words, it doesn't
1318      * contain the '_'. --jhi */
1319     return is_utf8_common(p, &PL_utf8_alnum, "IsWord");
1320 }
1321
1322 bool
1323 Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
1324 {
1325     dVAR;
1326
1327     PERL_ARGS_ASSERT_IS_UTF8_IDFIRST;
1328
1329     if (*p == '_')
1330         return TRUE;
1331     /* is_utf8_idstart would be more logical. */
1332     return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
1333 }
1334
1335 bool
1336 Perl_is_utf8_idcont(pTHX_ const U8 *p)
1337 {
1338     dVAR;
1339
1340     PERL_ARGS_ASSERT_IS_UTF8_IDCONT;
1341
1342     if (*p == '_')
1343         return TRUE;
1344     return is_utf8_common(p, &PL_utf8_idcont, "IdContinue");
1345 }
1346
1347 bool
1348 Perl_is_utf8_alpha(pTHX_ const U8 *p)
1349 {
1350     dVAR;
1351
1352     PERL_ARGS_ASSERT_IS_UTF8_ALPHA;
1353
1354     return is_utf8_common(p, &PL_utf8_alpha, "IsAlpha");
1355 }
1356
1357 bool
1358 Perl_is_utf8_ascii(pTHX_ const U8 *p)
1359 {
1360     dVAR;
1361
1362     PERL_ARGS_ASSERT_IS_UTF8_ASCII;
1363
1364     return is_utf8_common(p, &PL_utf8_ascii, "IsAscii");
1365 }
1366
1367 bool
1368 Perl_is_utf8_space(pTHX_ const U8 *p)
1369 {
1370     dVAR;
1371
1372     PERL_ARGS_ASSERT_IS_UTF8_SPACE;
1373
1374     return is_utf8_common(p, &PL_utf8_space, "IsSpacePerl");
1375 }
1376
1377 bool
1378 Perl_is_utf8_perl_space(pTHX_ const U8 *p)
1379 {
1380     dVAR;
1381
1382     PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE;
1383
1384     return is_utf8_common(p, &PL_utf8_perl_space, "IsPerlSpace");
1385 }
1386
1387 bool
1388 Perl_is_utf8_perl_word(pTHX_ const U8 *p)
1389 {
1390     dVAR;
1391
1392     PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD;
1393
1394     return is_utf8_common(p, &PL_utf8_perl_word, "IsPerlWord");
1395 }
1396
1397 bool
1398 Perl_is_utf8_digit(pTHX_ const U8 *p)
1399 {
1400     dVAR;
1401
1402     PERL_ARGS_ASSERT_IS_UTF8_DIGIT;
1403
1404     return is_utf8_common(p, &PL_utf8_digit, "IsDigit");
1405 }
1406
1407 bool
1408 Perl_is_utf8_posix_digit(pTHX_ const U8 *p)
1409 {
1410     dVAR;
1411
1412     PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT;
1413
1414     return is_utf8_common(p, &PL_utf8_posix_digit, "IsPosixDigit");
1415 }
1416
1417 bool
1418 Perl_is_utf8_upper(pTHX_ const U8 *p)
1419 {
1420     dVAR;
1421
1422     PERL_ARGS_ASSERT_IS_UTF8_UPPER;
1423
1424     return is_utf8_common(p, &PL_utf8_upper, "IsUppercase");
1425 }
1426
1427 bool
1428 Perl_is_utf8_lower(pTHX_ const U8 *p)
1429 {
1430     dVAR;
1431
1432     PERL_ARGS_ASSERT_IS_UTF8_LOWER;
1433
1434     return is_utf8_common(p, &PL_utf8_lower, "IsLowercase");
1435 }
1436
1437 bool
1438 Perl_is_utf8_cntrl(pTHX_ const U8 *p)
1439 {
1440     dVAR;
1441
1442     PERL_ARGS_ASSERT_IS_UTF8_CNTRL;
1443
1444     return is_utf8_common(p, &PL_utf8_cntrl, "IsCntrl");
1445 }
1446
1447 bool
1448 Perl_is_utf8_graph(pTHX_ const U8 *p)
1449 {
1450     dVAR;
1451
1452     PERL_ARGS_ASSERT_IS_UTF8_GRAPH;
1453
1454     return is_utf8_common(p, &PL_utf8_graph, "IsGraph");
1455 }
1456
1457 bool
1458 Perl_is_utf8_print(pTHX_ const U8 *p)
1459 {
1460     dVAR;
1461
1462     PERL_ARGS_ASSERT_IS_UTF8_PRINT;
1463
1464     return is_utf8_common(p, &PL_utf8_print, "IsPrint");
1465 }
1466
1467 bool
1468 Perl_is_utf8_punct(pTHX_ const U8 *p)
1469 {
1470     dVAR;
1471
1472     PERL_ARGS_ASSERT_IS_UTF8_PUNCT;
1473
1474     return is_utf8_common(p, &PL_utf8_punct, "IsPunct");
1475 }
1476
1477 bool
1478 Perl_is_utf8_xdigit(pTHX_ const U8 *p)
1479 {
1480     dVAR;
1481
1482     PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
1483
1484     return is_utf8_common(p, &PL_utf8_xdigit, "IsXDigit");
1485 }
1486
1487 bool
1488 Perl_is_utf8_mark(pTHX_ const U8 *p)
1489 {
1490     dVAR;
1491
1492     PERL_ARGS_ASSERT_IS_UTF8_MARK;
1493
1494     return is_utf8_common(p, &PL_utf8_mark, "IsM");
1495 }
1496
1497 /*
1498 =for apidoc to_utf8_case
1499
1500 The "p" contains the pointer to the UTF-8 string encoding
1501 the character that is being converted.
1502
1503 The "ustrp" is a pointer to the character buffer to put the
1504 conversion result to.  The "lenp" is a pointer to the length
1505 of the result.
1506
1507 The "swashp" is a pointer to the swash to use.
1508
1509 Both the special and normal mappings are stored lib/unicore/To/Foo.pl,
1510 and loaded by SWASHNEW, using lib/utf8_heavy.pl.  The special (usually,
1511 but not always, a multicharacter mapping), is tried first.
1512
1513 The "special" is a string like "utf8::ToSpecLower", which means the
1514 hash %utf8::ToSpecLower.  The access to the hash is through
1515 Perl_to_utf8_case().
1516
1517 The "normal" is a string like "ToLower" which means the swash
1518 %utf8::ToLower.
1519
1520 =cut */
1521
1522 UV
1523 Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
1524                         SV **swashp, const char *normal, const char *special)
1525 {
1526     dVAR;
1527     U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
1528     STRLEN len = 0;
1529     const UV uv0 = utf8_to_uvchr(p, NULL);
1530     /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
1531      * are necessary in EBCDIC, they are redundant no-ops
1532      * in ASCII-ish platforms, and hopefully optimized away. */
1533     const UV uv1 = NATIVE_TO_UNI(uv0);
1534
1535     PERL_ARGS_ASSERT_TO_UTF8_CASE;
1536
1537     uvuni_to_utf8(tmpbuf, uv1);
1538
1539     if (!*swashp) /* load on-demand */
1540          *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1541
1542     /* The 0xDF is the only special casing Unicode code point below 0x100. */
1543     if (special && (uv1 == 0xDF || uv1 > 0xFF)) {
1544          /* It might be "special" (sometimes, but not always,
1545           * a multicharacter mapping) */
1546          HV * const hv = get_hv(special, 0);
1547          SV **svp;
1548
1549          if (hv &&
1550              (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
1551              (*svp)) {
1552              const char *s;
1553
1554               s = SvPV_const(*svp, len);
1555               if (len == 1)
1556                    len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
1557               else {
1558 #ifdef EBCDIC
1559                    /* If we have EBCDIC we need to remap the characters
1560                     * since any characters in the low 256 are Unicode
1561                     * code points, not EBCDIC. */
1562                    U8 *t = (U8*)s, *tend = t + len, *d;
1563
1564                    d = tmpbuf;
1565                    if (SvUTF8(*svp)) {
1566                         STRLEN tlen = 0;
1567
1568                         while (t < tend) {
1569                              const UV c = utf8_to_uvchr(t, &tlen);
1570                              if (tlen > 0) {
1571                                   d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
1572                                   t += tlen;
1573                              }
1574                              else
1575                                   break;
1576                         }
1577                    }
1578                    else {
1579                         while (t < tend) {
1580                              d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
1581                              t++;
1582                         }
1583                    }
1584                    len = d - tmpbuf;
1585                    Copy(tmpbuf, ustrp, len, U8);
1586 #else
1587                    Copy(s, ustrp, len, U8);
1588 #endif
1589               }
1590          }
1591     }
1592
1593     if (!len && *swashp) {
1594         const UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
1595
1596          if (uv2) {
1597               /* It was "normal" (a single character mapping). */
1598               const UV uv3 = UNI_TO_NATIVE(uv2);
1599               len = uvchr_to_utf8(ustrp, uv3) - ustrp;
1600          }
1601     }
1602
1603     if (!len) /* Neither: just copy. */
1604          len = uvchr_to_utf8(ustrp, uv0) - ustrp;
1605
1606     if (lenp)
1607          *lenp = len;
1608
1609     return len ? utf8_to_uvchr(ustrp, 0) : 0;
1610 }
1611
1612 /*
1613 =for apidoc to_utf8_upper
1614
1615 Convert the UTF-8 encoded character at p to its uppercase version and
1616 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1617 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
1618 the uppercase version may be longer than the original character.
1619
1620 The first character of the uppercased version is returned
1621 (but note, as explained above, that there may be more.)
1622
1623 =cut */
1624
1625 UV
1626 Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1627 {
1628     dVAR;
1629
1630     PERL_ARGS_ASSERT_TO_UTF8_UPPER;
1631
1632     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1633                              &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
1634 }
1635
1636 /*
1637 =for apidoc to_utf8_title
1638
1639 Convert the UTF-8 encoded character at p to its titlecase version and
1640 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1641 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1642 titlecase version may be longer than the original character.
1643
1644 The first character of the titlecased version is returned
1645 (but note, as explained above, that there may be more.)
1646
1647 =cut */
1648
1649 UV
1650 Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1651 {
1652     dVAR;
1653
1654     PERL_ARGS_ASSERT_TO_UTF8_TITLE;
1655
1656     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1657                              &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
1658 }
1659
1660 /*
1661 =for apidoc to_utf8_lower
1662
1663 Convert the UTF-8 encoded character at p to its lowercase version and
1664 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1665 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1666 lowercase version may be longer than the original character.
1667
1668 The first character of the lowercased version is returned
1669 (but note, as explained above, that there may be more.)
1670
1671 =cut */
1672
1673 UV
1674 Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1675 {
1676     dVAR;
1677
1678     PERL_ARGS_ASSERT_TO_UTF8_LOWER;
1679
1680     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1681                              &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
1682 }
1683
1684 /*
1685 =for apidoc to_utf8_fold
1686
1687 Convert the UTF-8 encoded character at p to its foldcase version and
1688 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1689 that the ustrp needs to be at least UTF8_MAXBYTES_CASE+1 bytes since the
1690 foldcase version may be longer than the original character (up to
1691 three characters).
1692
1693 The first character of the foldcased version is returned
1694 (but note, as explained above, that there may be more.)
1695
1696 =cut */
1697
1698 UV
1699 Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
1700 {
1701     dVAR;
1702
1703     PERL_ARGS_ASSERT_TO_UTF8_FOLD;
1704
1705     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1706                              &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
1707 }
1708
1709 /* Note:
1710  * A "swash" is a swatch hash.
1711  * A "swatch" is a bit vector generated by utf8.c:S_swash_get().
1712  * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
1713  * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
1714  */
1715 SV*
1716 Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
1717 {
1718     dVAR;
1719     SV* retval;
1720     dSP;
1721     const size_t pkg_len = strlen(pkg);
1722     const size_t name_len = strlen(name);
1723     HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
1724     SV* errsv_save;
1725
1726     PERL_ARGS_ASSERT_SWASH_INIT;
1727
1728     PUSHSTACKi(PERLSI_MAGIC);
1729     ENTER;
1730     SAVEI32(PL_hints);
1731     PL_hints = 0;
1732     save_re_context();
1733     if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) {      /* demand load utf8 */
1734         ENTER;
1735         errsv_save = newSVsv(ERRSV);
1736         /* It is assumed that callers of this routine are not passing in any
1737            user derived data.  */
1738         /* Need to do this after save_re_context() as it will set PL_tainted to
1739            1 while saving $1 etc (see the code after getrx: in Perl_magic_get).
1740            Even line to create errsv_save can turn on PL_tainted.  */
1741         SAVEBOOL(PL_tainted);
1742         PL_tainted = 0;
1743         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
1744                          NULL);
1745         if (!SvTRUE(ERRSV))
1746             sv_setsv(ERRSV, errsv_save);
1747         SvREFCNT_dec(errsv_save);
1748         LEAVE;
1749     }
1750     SPAGAIN;
1751     PUSHMARK(SP);
1752     EXTEND(SP,5);
1753     mPUSHp(pkg, pkg_len);
1754     mPUSHp(name, name_len);
1755     PUSHs(listsv);
1756     mPUSHi(minbits);
1757     mPUSHi(none);
1758     PUTBACK;
1759     errsv_save = newSVsv(ERRSV);
1760     if (call_method("SWASHNEW", G_SCALAR))
1761         retval = newSVsv(*PL_stack_sp--);
1762     else
1763         retval = &PL_sv_undef;
1764     if (!SvTRUE(ERRSV))
1765         sv_setsv(ERRSV, errsv_save);
1766     SvREFCNT_dec(errsv_save);
1767     LEAVE;
1768     POPSTACK;
1769     if (IN_PERL_COMPILETIME) {
1770         CopHINTS_set(PL_curcop, PL_hints);
1771     }
1772     if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
1773         if (SvPOK(retval))
1774             Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
1775                        SVfARG(retval));
1776         Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
1777     }
1778     return retval;
1779 }
1780
1781
1782 /* This API is wrong for special case conversions since we may need to
1783  * return several Unicode characters for a single Unicode character
1784  * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
1785  * the lower-level routine, and it is similarly broken for returning
1786  * multiple values.  --jhi */
1787 /* Now SWASHGET is recasted into S_swash_get in this file. */
1788
1789 /* Note:
1790  * Returns the value of property/mapping C<swash> for the first character
1791  * of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
1792  * assumed to be in utf8. If C<do_utf8> is false, the string C<ptr> is
1793  * assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
1794  */
1795 UV
1796 Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
1797 {
1798     dVAR;
1799     HV *const hv = MUTABLE_HV(SvRV(swash));
1800     U32 klen;
1801     U32 off;
1802     STRLEN slen;
1803     STRLEN needents;
1804     const U8 *tmps = NULL;
1805     U32 bit;
1806     SV *swatch;
1807     U8 tmputf8[2];
1808     const UV c = NATIVE_TO_ASCII(*ptr);
1809
1810     PERL_ARGS_ASSERT_SWASH_FETCH;
1811
1812     if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
1813         tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
1814         tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
1815         ptr = tmputf8;
1816     }
1817     /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
1818      * then the "swatch" is a vec() for al the chars which start
1819      * with 0xAA..0xYY
1820      * So the key in the hash (klen) is length of encoded char -1
1821      */
1822     klen = UTF8SKIP(ptr) - 1;
1823     off  = ptr[klen];
1824
1825     if (klen == 0) {
1826       /* If char in invariant then swatch is for all the invariant chars
1827        * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
1828        */
1829         needents = UTF_CONTINUATION_MARK;
1830         off      = NATIVE_TO_UTF(ptr[klen]);
1831     }
1832     else {
1833       /* If char is encoded then swatch is for the prefix */
1834         needents = (1 << UTF_ACCUMULATION_SHIFT);
1835         off      = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
1836     }
1837
1838     /*
1839      * This single-entry cache saves about 1/3 of the utf8 overhead in test
1840      * suite.  (That is, only 7-8% overall over just a hash cache.  Still,
1841      * it's nothing to sniff at.)  Pity we usually come through at least
1842      * two function calls to get here...
1843      *
1844      * NB: this code assumes that swatches are never modified, once generated!
1845      */
1846
1847     if (hv   == PL_last_swash_hv &&
1848         klen == PL_last_swash_klen &&
1849         (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
1850     {
1851         tmps = PL_last_swash_tmps;
1852         slen = PL_last_swash_slen;
1853     }
1854     else {
1855         /* Try our second-level swatch cache, kept in a hash. */
1856         SV** svp = hv_fetch(hv, (const char*)ptr, klen, FALSE);
1857
1858         /* If not cached, generate it via swash_get */
1859         if (!svp || !SvPOK(*svp)
1860                  || !(tmps = (const U8*)SvPV_const(*svp, slen))) {
1861             /* We use utf8n_to_uvuni() as we want an index into
1862                Unicode tables, not a native character number.
1863              */
1864             const UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXBYTES, 0,
1865                                            ckWARN(WARN_UTF8) ?
1866                                            0 : UTF8_ALLOW_ANY);
1867             swatch = swash_get(swash,
1868                     /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
1869                                 (klen) ? (code_point & ~(needents - 1)) : 0,
1870                                 needents);
1871
1872             if (IN_PERL_COMPILETIME)
1873                 CopHINTS_set(PL_curcop, PL_hints);
1874
1875             svp = hv_store(hv, (const char *)ptr, klen, swatch, 0);
1876
1877             if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
1878                      || (slen << 3) < needents)
1879                 Perl_croak(aTHX_ "panic: swash_fetch got improper swatch");
1880         }
1881
1882         PL_last_swash_hv = hv;
1883         assert(klen <= sizeof(PL_last_swash_key));
1884         PL_last_swash_klen = (U8)klen;
1885         /* FIXME change interpvar.h?  */
1886         PL_last_swash_tmps = (U8 *) tmps;
1887         PL_last_swash_slen = slen;
1888         if (klen)
1889             Copy(ptr, PL_last_swash_key, klen, U8);
1890     }
1891
1892     switch ((int)((slen << 3) / needents)) {
1893     case 1:
1894         bit = 1 << (off & 7);
1895         off >>= 3;
1896         return (tmps[off] & bit) != 0;
1897     case 8:
1898         return tmps[off];
1899     case 16:
1900         off <<= 1;
1901         return (tmps[off] << 8) + tmps[off + 1] ;
1902     case 32:
1903         off <<= 2;
1904         return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1905     }
1906     Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width");
1907     NORETURN_FUNCTION_END;
1908 }
1909
1910 /* Note:
1911  * Returns a swatch (a bit vector string) for a code point sequence
1912  * that starts from the value C<start> and comprises the number C<span>.
1913  * A C<swash> must be an object created by SWASHNEW (see lib/utf8_heavy.pl).
1914  * Should be used via swash_fetch, which will cache the swatch in C<swash>.
1915  */
1916 STATIC SV*
1917 S_swash_get(pTHX_ SV* swash, UV start, UV span)
1918 {
1919     SV *swatch;
1920     U8 *l, *lend, *x, *xend, *s;
1921     STRLEN lcur, xcur, scur;
1922     HV *const hv = MUTABLE_HV(SvRV(swash));
1923     SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
1924     SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
1925     SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
1926     SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
1927     SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
1928     const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
1929     const int  typeto  = typestr[0] == 'T' && typestr[1] == 'o';
1930     const STRLEN bits  = SvUV(*bitssvp);
1931     const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
1932     const UV     none  = SvUV(*nonesvp);
1933     const UV     end   = start + span;
1934
1935     PERL_ARGS_ASSERT_SWASH_GET;
1936
1937     if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
1938         Perl_croak(aTHX_ "panic: swash_get doesn't expect bits %"UVuf,
1939                                                  (UV)bits);
1940     }
1941
1942     /* create and initialize $swatch */
1943     scur   = octets ? (span * octets) : (span + 7) / 8;
1944     swatch = newSV(scur);
1945     SvPOK_on(swatch);
1946     s = (U8*)SvPVX(swatch);
1947     if (octets && none) {
1948         const U8* const e = s + scur;
1949         while (s < e) {
1950             if (bits == 8)
1951                 *s++ = (U8)(none & 0xff);
1952             else if (bits == 16) {
1953                 *s++ = (U8)((none >>  8) & 0xff);
1954                 *s++ = (U8)( none        & 0xff);
1955             }
1956             else if (bits == 32) {
1957                 *s++ = (U8)((none >> 24) & 0xff);
1958                 *s++ = (U8)((none >> 16) & 0xff);
1959                 *s++ = (U8)((none >>  8) & 0xff);
1960                 *s++ = (U8)( none        & 0xff);
1961             }
1962         }
1963         *s = '\0';
1964     }
1965     else {
1966         (void)memzero((U8*)s, scur + 1);
1967     }
1968     SvCUR_set(swatch, scur);
1969     s = (U8*)SvPVX(swatch);
1970
1971     /* read $swash->{LIST} */
1972     l = (U8*)SvPV(*listsvp, lcur);
1973     lend = l + lcur;
1974     while (l < lend) {
1975         UV min, max, val;
1976         STRLEN numlen;
1977         I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1978
1979         U8* const nl = (U8*)memchr(l, '\n', lend - l);
1980
1981         numlen = lend - l;
1982         min = grok_hex((char *)l, &numlen, &flags, NULL);
1983         if (numlen)
1984             l += numlen;
1985         else if (nl) {
1986             l = nl + 1; /* 1 is length of "\n" */
1987             continue;
1988         }
1989         else {
1990             l = lend; /* to LIST's end at which \n is not found */
1991             break;
1992         }
1993
1994         if (isBLANK(*l)) {
1995             ++l;
1996             flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
1997             numlen = lend - l;
1998             max = grok_hex((char *)l, &numlen, &flags, NULL);
1999             if (numlen)
2000                 l += numlen;
2001             else
2002                 max = min;
2003
2004             if (octets) {
2005                 if (isBLANK(*l)) {
2006                     ++l;
2007                     flags = PERL_SCAN_SILENT_ILLDIGIT |
2008                             PERL_SCAN_DISALLOW_PREFIX;
2009                     numlen = lend - l;
2010                     val = grok_hex((char *)l, &numlen, &flags, NULL);
2011                     if (numlen)
2012                         l += numlen;
2013                     else
2014                         val = 0;
2015                 }
2016                 else {
2017                     val = 0;
2018                     if (typeto) {
2019                         Perl_croak(aTHX_ "%s: illegal mapping '%s'",
2020                                          typestr, l);
2021                     }
2022                 }
2023             }
2024             else
2025                 val = 0; /* bits == 1, then val should be ignored */
2026         }
2027         else {
2028             max = min;
2029             if (octets) {
2030                 val = 0;
2031                 if (typeto) {
2032                     Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
2033                 }
2034             }
2035             else
2036                 val = 0; /* bits == 1, then val should be ignored */
2037         }
2038
2039         if (nl)
2040             l = nl + 1;
2041         else
2042             l = lend;
2043
2044         if (max < start)
2045             continue;
2046
2047         if (octets) {
2048             UV key;
2049             if (min < start) {
2050                 if (!none || val < none) {
2051                     val += start - min;
2052                 }
2053                 min = start;
2054             }
2055             for (key = min; key <= max; key++) {
2056                 STRLEN offset;
2057                 if (key >= end)
2058                     goto go_out_list;
2059                 /* offset must be non-negative (start <= min <= key < end) */
2060                 offset = octets * (key - start);
2061                 if (bits == 8)
2062                     s[offset] = (U8)(val & 0xff);
2063                 else if (bits == 16) {
2064                     s[offset    ] = (U8)((val >>  8) & 0xff);
2065                     s[offset + 1] = (U8)( val        & 0xff);
2066                 }
2067                 else if (bits == 32) {
2068                     s[offset    ] = (U8)((val >> 24) & 0xff);
2069                     s[offset + 1] = (U8)((val >> 16) & 0xff);
2070                     s[offset + 2] = (U8)((val >>  8) & 0xff);
2071                     s[offset + 3] = (U8)( val        & 0xff);
2072                 }
2073
2074                 if (!none || val < none)
2075                     ++val;
2076             }
2077         }
2078         else { /* bits == 1, then val should be ignored */
2079             UV key;
2080             if (min < start)
2081                 min = start;
2082             for (key = min; key <= max; key++) {
2083                 const STRLEN offset = (STRLEN)(key - start);
2084                 if (key >= end)
2085                     goto go_out_list;
2086                 s[offset >> 3] |= 1 << (offset & 7);
2087             }
2088         }
2089     } /* while */
2090   go_out_list:
2091
2092     /* read $swash->{EXTRAS} */
2093     x = (U8*)SvPV(*extssvp, xcur);
2094     xend = x + xcur;
2095     while (x < xend) {
2096         STRLEN namelen;
2097         U8 *namestr;
2098         SV** othersvp;
2099         HV* otherhv;
2100         STRLEN otherbits;
2101         SV **otherbitssvp, *other;
2102         U8 *s, *o, *nl;
2103         STRLEN slen, olen;
2104
2105         const U8 opc = *x++;
2106         if (opc == '\n')
2107             continue;
2108
2109         nl = (U8*)memchr(x, '\n', xend - x);
2110
2111         if (opc != '-' && opc != '+' && opc != '!' && opc != '&') {
2112             if (nl) {
2113                 x = nl + 1; /* 1 is length of "\n" */
2114                 continue;
2115             }
2116             else {
2117                 x = xend; /* to EXTRAS' end at which \n is not found */
2118                 break;
2119             }
2120         }
2121
2122         namestr = x;
2123         if (nl) {
2124             namelen = nl - namestr;
2125             x = nl + 1;
2126         }
2127         else {
2128             namelen = xend - namestr;
2129             x = xend;
2130         }
2131
2132         othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
2133         otherhv = MUTABLE_HV(SvRV(*othersvp));
2134         otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
2135         otherbits = (STRLEN)SvUV(*otherbitssvp);
2136         if (bits < otherbits)
2137             Perl_croak(aTHX_ "panic: swash_get found swatch size mismatch");
2138
2139         /* The "other" swatch must be destroyed after. */
2140         other = swash_get(*othersvp, start, span);
2141         o = (U8*)SvPV(other, olen);
2142
2143         if (!olen)
2144             Perl_croak(aTHX_ "panic: swash_get got improper swatch");
2145
2146         s = (U8*)SvPV(swatch, slen);
2147         if (bits == 1 && otherbits == 1) {
2148             if (slen != olen)
2149                 Perl_croak(aTHX_ "panic: swash_get found swatch length mismatch");
2150
2151             switch (opc) {
2152             case '+':
2153                 while (slen--)
2154                     *s++ |= *o++;
2155                 break;
2156             case '!':
2157                 while (slen--)
2158                     *s++ |= ~*o++;
2159                 break;
2160             case '-':
2161                 while (slen--)
2162                     *s++ &= ~*o++;
2163                 break;
2164             case '&':
2165                 while (slen--)
2166                     *s++ &= *o++;
2167                 break;
2168             default:
2169                 break;
2170             }
2171         }
2172         else {
2173             STRLEN otheroctets = otherbits >> 3;
2174             STRLEN offset = 0;
2175             U8* const send = s + slen;
2176
2177             while (s < send) {
2178                 UV otherval = 0;
2179
2180                 if (otherbits == 1) {
2181                     otherval = (o[offset >> 3] >> (offset & 7)) & 1;
2182                     ++offset;
2183                 }
2184                 else {
2185                     STRLEN vlen = otheroctets;
2186                     otherval = *o++;
2187                     while (--vlen) {
2188                         otherval <<= 8;
2189                         otherval |= *o++;
2190                     }
2191                 }
2192
2193                 if (opc == '+' && otherval)
2194                     NOOP;   /* replace with otherval */
2195                 else if (opc == '!' && !otherval)
2196                     otherval = 1;
2197                 else if (opc == '-' && otherval)
2198                     otherval = 0;
2199                 else if (opc == '&' && !otherval)
2200                     otherval = 0;
2201                 else {
2202                     s += octets; /* no replacement */
2203                     continue;
2204                 }
2205
2206                 if (bits == 8)
2207                     *s++ = (U8)( otherval & 0xff);
2208                 else if (bits == 16) {
2209                     *s++ = (U8)((otherval >>  8) & 0xff);
2210                     *s++ = (U8)( otherval        & 0xff);
2211                 }
2212                 else if (bits == 32) {
2213                     *s++ = (U8)((otherval >> 24) & 0xff);
2214                     *s++ = (U8)((otherval >> 16) & 0xff);
2215                     *s++ = (U8)((otherval >>  8) & 0xff);
2216                     *s++ = (U8)( otherval        & 0xff);
2217                 }
2218             }
2219         }
2220         sv_free(other); /* through with it! */
2221     } /* while */
2222     return swatch;
2223 }
2224
2225 /*
2226 =for apidoc uvchr_to_utf8
2227
2228 Adds the UTF-8 representation of the Native codepoint C<uv> to the end
2229 of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
2230 bytes available. The return value is the pointer to the byte after the
2231 end of the new character. In other words,
2232
2233     d = uvchr_to_utf8(d, uv);
2234
2235 is the recommended wide native character-aware way of saying
2236
2237     *(d++) = uv;
2238
2239 =cut
2240 */
2241
2242 /* On ASCII machines this is normally a macro but we want a
2243    real function in case XS code wants it
2244 */
2245 U8 *
2246 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
2247 {
2248     PERL_ARGS_ASSERT_UVCHR_TO_UTF8;
2249
2250     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
2251 }
2252
2253 U8 *
2254 Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
2255 {
2256     PERL_ARGS_ASSERT_UVCHR_TO_UTF8_FLAGS;
2257
2258     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
2259 }
2260
2261 /*
2262 =for apidoc utf8n_to_uvchr
2263 flags
2264
2265 Returns the native character value of the first character in the string
2266 C<s>
2267 which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
2268 length, in bytes, of that character.
2269
2270 Allows length and flags to be passed to low level routine.
2271
2272 =cut
2273 */
2274 /* On ASCII machines this is normally a macro but we want
2275    a real function in case XS code wants it
2276 */
2277 UV
2278 Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
2279 U32 flags)
2280 {
2281     const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
2282
2283     PERL_ARGS_ASSERT_UTF8N_TO_UVCHR;
2284
2285     return UNI_TO_NATIVE(uv);
2286 }
2287
2288 /*
2289 =for apidoc pv_uni_display
2290
2291 Build to the scalar dsv a displayable version of the string spv,
2292 length len, the displayable version being at most pvlim bytes long
2293 (if longer, the rest is truncated and "..." will be appended).
2294
2295 The flags argument can have UNI_DISPLAY_ISPRINT set to display
2296 isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
2297 to display the \\[nrfta\\] as the backslashed versions (like '\n')
2298 (UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
2299 UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
2300 UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
2301
2302 The pointer to the PV of the dsv is returned.
2303
2304 =cut */
2305 char *
2306 Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
2307 {
2308     int truncated = 0;
2309     const char *s, *e;
2310
2311     PERL_ARGS_ASSERT_PV_UNI_DISPLAY;
2312
2313     sv_setpvs(dsv, "");
2314     SvUTF8_off(dsv);
2315     for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
2316          UV u;
2317           /* This serves double duty as a flag and a character to print after
2318              a \ when flags & UNI_DISPLAY_BACKSLASH is true.
2319           */
2320          char ok = 0;
2321
2322          if (pvlim && SvCUR(dsv) >= pvlim) {
2323               truncated++;
2324               break;
2325          }
2326          u = utf8_to_uvchr((U8*)s, 0);
2327          if (u < 256) {
2328              const unsigned char c = (unsigned char)u & 0xFF;
2329              if (flags & UNI_DISPLAY_BACKSLASH) {
2330                  switch (c) {
2331                  case '\n':
2332                      ok = 'n'; break;
2333                  case '\r':
2334                      ok = 'r'; break;
2335                  case '\t':
2336                      ok = 't'; break;
2337                  case '\f':
2338                      ok = 'f'; break;
2339                  case '\a':
2340                      ok = 'a'; break;
2341                  case '\\':
2342                      ok = '\\'; break;
2343                  default: break;
2344                  }
2345                  if (ok) {
2346                      const char string = ok;
2347                      sv_catpvs(dsv, "\\");
2348                      sv_catpvn(dsv, &string, 1);
2349                  }
2350              }
2351              /* isPRINT() is the locale-blind version. */
2352              if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
2353                  const char string = c;
2354                  sv_catpvn(dsv, &string, 1);
2355                  ok = 1;
2356              }
2357          }
2358          if (!ok)
2359              Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
2360     }
2361     if (truncated)
2362          sv_catpvs(dsv, "...");
2363
2364     return SvPVX(dsv);
2365 }
2366
2367 /*
2368 =for apidoc sv_uni_display
2369
2370 Build to the scalar dsv a displayable version of the scalar sv,
2371 the displayable version being at most pvlim bytes long
2372 (if longer, the rest is truncated and "..." will be appended).
2373
2374 The flags argument is as in pv_uni_display().
2375
2376 The pointer to the PV of the dsv is returned.
2377
2378 =cut
2379 */
2380 char *
2381 Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
2382 {
2383     PERL_ARGS_ASSERT_SV_UNI_DISPLAY;
2384
2385      return Perl_pv_uni_display(aTHX_ dsv, (const U8*)SvPVX_const(ssv),
2386                                 SvCUR(ssv), pvlim, flags);
2387 }
2388
2389 /*
2390 =for apidoc ibcmp_utf8
2391
2392 Return true if the strings s1 and s2 differ case-insensitively, false
2393 if not (if they are equal case-insensitively).  If u1 is true, the
2394 string s1 is assumed to be in UTF-8-encoded Unicode.  If u2 is true,
2395 the string s2 is assumed to be in UTF-8-encoded Unicode.  If u1 or u2
2396 are false, the respective string is assumed to be in native 8-bit
2397 encoding.
2398
2399 If the pe1 and pe2 are non-NULL, the scanning pointers will be copied
2400 in there (they will point at the beginning of the I<next> character).
2401 If the pointers behind pe1 or pe2 are non-NULL, they are the end
2402 pointers beyond which scanning will not continue under any
2403 circumstances.  If the byte lengths l1 and l2 are non-zero, s1+l1 and
2404 s2+l2 will be used as goal end pointers that will also stop the scan,
2405 and which qualify towards defining a successful match: all the scans
2406 that define an explicit length must reach their goal pointers for
2407 a match to succeed).
2408
2409 For case-insensitiveness, the "casefolding" of Unicode is used
2410 instead of upper/lowercasing both the characters, see
2411 http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
2412
2413 =cut */
2414 I32
2415 Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
2416 {
2417      dVAR;
2418      register const U8 *p1  = (const U8*)s1;
2419      register const U8 *p2  = (const U8*)s2;
2420      register const U8 *f1 = NULL;
2421      register const U8 *f2 = NULL;
2422      register U8 *e1 = NULL;
2423      register U8 *q1 = NULL;
2424      register U8 *e2 = NULL;
2425      register U8 *q2 = NULL;
2426      STRLEN n1 = 0, n2 = 0;
2427      U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
2428      U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
2429      U8 natbuf[1+1];
2430      STRLEN foldlen1, foldlen2;
2431      bool match;
2432
2433      PERL_ARGS_ASSERT_IBCMP_UTF8;
2434
2435      if (pe1)
2436           e1 = *(U8**)pe1;
2437      /* assert(e1 || l1); */
2438      if (e1 == 0 || (l1 && l1 < (UV)(e1 - (const U8*)s1)))
2439           f1 = (const U8*)s1 + l1;
2440      if (pe2)
2441           e2 = *(U8**)pe2;
2442      /* assert(e2 || l2); */
2443      if (e2 == 0 || (l2 && l2 < (UV)(e2 - (const U8*)s2)))
2444           f2 = (const U8*)s2 + l2;
2445
2446      /* This shouldn't happen. However, putting an assert() there makes some
2447       * tests fail. */
2448      /* assert((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0)); */
2449      if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0))
2450           return 1; /* mismatch; possible infinite loop or false positive */
2451
2452      if (!u1 || !u2)
2453           natbuf[1] = 0; /* Need to terminate the buffer. */
2454
2455      while ((e1 == 0 || p1 < e1) &&
2456             (f1 == 0 || p1 < f1) &&
2457             (e2 == 0 || p2 < e2) &&
2458             (f2 == 0 || p2 < f2)) {
2459           if (n1 == 0) {
2460                if (u1)
2461                     to_utf8_fold(p1, foldbuf1, &foldlen1);
2462                else {
2463                     uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p1)));
2464                     to_utf8_fold(natbuf, foldbuf1, &foldlen1);
2465                }
2466                q1 = foldbuf1;
2467                n1 = foldlen1;
2468           }
2469           if (n2 == 0) {
2470                if (u2)
2471                     to_utf8_fold(p2, foldbuf2, &foldlen2);
2472                else {
2473                     uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p2)));
2474                     to_utf8_fold(natbuf, foldbuf2, &foldlen2);
2475                }
2476                q2 = foldbuf2;
2477                n2 = foldlen2;
2478           }
2479           while (n1 && n2) {
2480                if ( UTF8SKIP(q1) != UTF8SKIP(q2) ||
2481                    (UTF8SKIP(q1) == 1 && *q1 != *q2) ||
2482                     memNE((char*)q1, (char*)q2, UTF8SKIP(q1)) )
2483                    return 1; /* mismatch */
2484                n1 -= UTF8SKIP(q1);
2485                q1 += UTF8SKIP(q1);
2486                n2 -= UTF8SKIP(q2);
2487                q2 += UTF8SKIP(q2);
2488           }
2489           if (n1 == 0)
2490                p1 += u1 ? UTF8SKIP(p1) : 1;
2491           if (n2 == 0)
2492                p2 += u2 ? UTF8SKIP(p2) : 1;
2493
2494      }
2495
2496      /* A match is defined by all the scans that specified
2497       * an explicit length reaching their final goals. */
2498      match = (f1 == 0 || p1 == f1) && (f2 == 0 || p2 == f2);
2499
2500      if (match) {
2501           if (pe1)
2502                *pe1 = (char*)p1;
2503           if (pe2)
2504                *pe2 = (char*)p2;
2505      }
2506
2507      return match ? 0 : 1; /* 0 match, 1 mismatch */
2508 }
2509
2510 /*
2511  * Local variables:
2512  * c-indentation-style: bsd
2513  * c-basic-offset: 4
2514  * indent-tabs-mode: t
2515  * End:
2516  *
2517  * ex: set ts=8 sts=4 sw=4 noet:
2518  */