utf8.c

   1 /*    utf8.c
   2  *
   3  *    Copyright (c) 1998-1999, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * 'What a fix!' said Sam. 'That's the one place in all the lands we've ever
  12  * heard of that we don't want to see any closer; and that's the one place
  13  * we're trying to get to!  And that's just where we can't get, nohow.'
  14  *
  15  * 'Well do I understand your speech,' he answered in the same language;
  16  * 'yet few strangers do so.  Why then do you not speak in the Common Tongue,
  17  * as is the custom in the West, if you wish to be answered?'
  18  *
  19  * ...the travellers perceived that the floor was paved with stones of many
  20  * hues; branching runes and strange devices intertwined beneath their feet.
  21  */
  22
  23 #include "EXTERN.h"
  24 #define PERL_IN_UTF8_C
  25 #include "perl.h"
  26
  27 /* Unicode support */
  28
  29 U8 *
  30 Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
  31 {
  32     if (uv < 0x80) {
  33         *d++ = uv;
  34         return d;
  35     }
  36     if (uv < 0x800) {
  37         *d++ = (( uv >>  6)         | 0xc0);
  38         *d++ = (( uv        & 0x3f) | 0x80);
  39         return d;
  40     }
  41     if (uv < 0x10000) {
  42         *d++ = (( uv >> 12)         | 0xe0);
  43         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  44         *d++ = (( uv        & 0x3f) | 0x80);
  45         return d;
  46     }
  47     if (uv < 0x200000) {
  48         *d++ = (( uv >> 18)         | 0xf0);
  49         *d++ = (((uv >> 12) & 0x3f) | 0x80);
  50         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  51         *d++ = (( uv        & 0x3f) | 0x80);
  52         return d;
  53     }
  54     if (uv < 0x4000000) {
  55         *d++ = (( uv >> 24)         | 0xf8);
  56         *d++ = (((uv >> 18) & 0x3f) | 0x80);
  57         *d++ = (((uv >> 12) & 0x3f) | 0x80);
  58         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  59         *d++ = (( uv        & 0x3f) | 0x80);
  60         return d;
  61     }
  62     if (uv < 0x80000000) {
  63         *d++ = (( uv >> 30)         | 0xfc);
  64         *d++ = (((uv >> 24) & 0x3f) | 0x80);
  65         *d++ = (((uv >> 18) & 0x3f) | 0x80);
  66         *d++ = (((uv >> 12) & 0x3f) | 0x80);
  67         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  68         *d++ = (( uv        & 0x3f) | 0x80);
  69         return d;
  70     }
  71 #ifdef Quad_t
  72     if (uv < 0x2000000000)
  73 #endif
  74     {
  75         *d++ =                        0xfe;     /* Can't match U+FEFF! */
  76         *d++ = (((uv >> 30) & 0x3f) | 0x80);
  77         *d++ = (((uv >> 24) & 0x3f) | 0x80);
  78         *d++ = (((uv >> 18) & 0x3f) | 0x80);
  79         *d++ = (((uv >> 12) & 0x3f) | 0x80);
  80         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  81         *d++ = (( uv        & 0x3f) | 0x80);
  82         return d;
  83     }
  84 #ifdef Quad_t
  85     {
  86         *d++ =                        0xff;     /* Can't match U+FFFE! */
  87         *d++ = (((uv >> 36) & 0x3f) | 0x80);
  88         *d++ = (((uv >> 30) & 0x3f) | 0x80);
  89         *d++ = (((uv >> 24) & 0x3f) | 0x80);
  90         *d++ = (((uv >> 18) & 0x3f) | 0x80);
  91         *d++ = (((uv >> 12) & 0x3f) | 0x80);
  92         *d++ = (((uv >>  6) & 0x3f) | 0x80);
  93         *d++ = (( uv        & 0x3f) | 0x80);
  94         return d;
  95     }
  96 #endif
  97 }
  98
  99 UV
 100 Perl_utf8_to_uv(pTHX_ U8* s, I32* retlen)
 101 {
 102     UV uv = *s;
 103     int len;
 104     if (!(uv & 0x80)) {
 105         if (retlen)
 106             *retlen = 1;
 107         return *s;
 108     }
 109     if (!(uv & 0x40)) {
 110         Perl_warn(aTHX_ "Malformed UTF-8 character");
 111         if (retlen)
 112             *retlen = 1;
 113         return *s;
 114     }
 115
 116     if      (!(uv & 0x20))      { len = 2; uv &= 0x1f; }
 117     else if (!(uv & 0x10))      { len = 3; uv &= 0x0f; }
 118     else if (!(uv & 0x08))      { len = 4; uv &= 0x07; }
 119     else if (!(uv & 0x04))      { len = 5; uv &= 0x03; }
 120     else if (!(uv & 0x02))      { len = 6; uv &= 0x01; }
 121     else if (!(uv & 0x01))      { len = 7; uv &= 0x00; }
 122     else                          len = 8;      /* whoa! */
 123
 124     if (retlen)
 125         *retlen = len;
 126     --len;
 127     s++;
 128     while (len--) {
 129         if ((*s & 0xc0) != 0x80) {
 130             Perl_warn(aTHX_ "Malformed UTF-8 character");
 131             if (retlen)
 132                 *retlen -= len + 1;
 133             return 0xfffd;
 134         }
 135         else
 136             uv = (uv << 6) | (*s++ & 0x3f);
 137     }
 138     return uv;
 139 }
 140
 141 /* utf8_distance(a,b) is intended to be a - b in pointer arithmetic */
 142
 143 I32
 144 Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
 145 {
 146     I32 off = 0;
 147     if (a < b) {
 148         while (a < b) {
 149             a += UTF8SKIP(a);
 150             off--;
 151         }
 152     }
 153     else {
 154         while (b < a) {
 155             b += UTF8SKIP(b);
 156             off++;
 157         }
 158     }
 159     return off;
 160 }
 161
 162 /* WARNING: do not use the following unless you *know* off is within bounds */
 163
 164 U8 *
 165 Perl_utf8_hop(pTHX_ U8 *s, I32 off)
 166 {
 167     if (off >= 0) {
 168         while (off--)
 169             s += UTF8SKIP(s);
 170     }
 171     else {
 172         while (off++) {
 173             s--;
 174             if (*s & 0x80) {
 175                 while ((*s & 0xc0) == 0x80)
 176                     s--;
 177             }
 178         }
 179     }
 180     return s;
 181 }
 182
 183 /* XXX NOTHING CALLS THE FOLLOWING TWO ROUTINES YET!!! */
 184 /*
 185  * Convert native or reversed UTF-16 to UTF-8.
 186  *
 187  * Destination must be pre-extended to 3/2 source.  Do not use in-place.
 188  * We optimize for native, for obvious reasons. */
 189
 190 U8*
 191 Perl_utf16_to_utf8(pTHX_ U16* p, U8* d, I32 bytelen)
 192 {
 193     U16* pend = p + bytelen / 2;
 194     while (p < pend) {
 195         UV uv = *p++;
 196         if (uv < 0x80) {
 197             *d++ = uv;
 198             continue;
 199         }
 200         if (uv < 0x800) {
 201             *d++ = (( uv >>  6)         | 0xc0);
 202             *d++ = (( uv        & 0x3f) | 0x80);
 203             continue;
 204         }
 205         if (uv >= 0xd800 && uv < 0xdbff) {      /* surrogates */
 206             int low = *p++;
 207             if (low < 0xdc00 || low >= 0xdfff) {
 208                 Perl_warn(aTHX_ "Malformed UTF-16 surrogate");
 209                 p--;
 210                 uv = 0xfffd;
 211             }
 212             uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
 213         }
 214         if (uv < 0x10000) {
 215             *d++ = (( uv >> 12)         | 0xe0);
 216             *d++ = (((uv >>  6) & 0x3f) | 0x80);
 217             *d++ = (( uv        & 0x3f) | 0x80);
 218             continue;
 219         }
 220         else {
 221             *d++ = (( uv >> 18)         | 0xf0);
 222             *d++ = (((uv >> 12) & 0x3f) | 0x80);
 223             *d++ = (((uv >>  6) & 0x3f) | 0x80);
 224             *d++ = (( uv        & 0x3f) | 0x80);
 225             continue;
 226         }
 227     }
 228     return d;
 229 }
 230
 231 /* Note: this one is slightly destructive of the source. */
 232
 233 U8*
 234 Perl_utf16_to_utf8_reversed(pTHX_ U16* p, U8* d, I32 bytelen)
 235 {
 236     U8* s = (U8*)p;
 237     U8* send = s + bytelen;
 238     while (s < send) {
 239         U8 tmp = s[0];
 240         s[0] = s[1];
 241         s[1] = tmp;
 242         s += 2;
 243     }
 244     return utf16_to_utf8(p, d, bytelen);
 245 }
 246
 247 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
 248
 249 bool
 250 Perl_is_uni_alnum(pTHX_ U32 c)
 251 {
 252     U8 tmpbuf[10];
 253     uv_to_utf8(tmpbuf, (UV)c);
 254     return is_utf8_alnum(tmpbuf);
 255 }
 256
 257 bool
 258 Perl_is_uni_idfirst(pTHX_ U32 c)
 259 {
 260     U8 tmpbuf[10];
 261     uv_to_utf8(tmpbuf, (UV)c);
 262     return is_utf8_idfirst(tmpbuf);
 263 }
 264
 265 bool
 266 Perl_is_uni_alpha(pTHX_ U32 c)
 267 {
 268     U8 tmpbuf[10];
 269     uv_to_utf8(tmpbuf, (UV)c);
 270     return is_utf8_alpha(tmpbuf);
 271 }
 272
 273 bool
 274 Perl_is_uni_space(pTHX_ U32 c)
 275 {
 276     U8 tmpbuf[10];
 277     uv_to_utf8(tmpbuf, (UV)c);
 278     return is_utf8_space(tmpbuf);
 279 }
 280
 281 bool
 282 Perl_is_uni_digit(pTHX_ U32 c)
 283 {
 284     U8 tmpbuf[10];
 285     uv_to_utf8(tmpbuf, (UV)c);
 286     return is_utf8_digit(tmpbuf);
 287 }
 288
 289 bool
 290 Perl_is_uni_upper(pTHX_ U32 c)
 291 {
 292     U8 tmpbuf[10];
 293     uv_to_utf8(tmpbuf, (UV)c);
 294     return is_utf8_upper(tmpbuf);
 295 }
 296
 297 bool
 298 Perl_is_uni_lower(pTHX_ U32 c)
 299 {
 300     U8 tmpbuf[10];
 301     uv_to_utf8(tmpbuf, (UV)c);
 302     return is_utf8_lower(tmpbuf);
 303 }
 304
 305 bool
 306 Perl_is_uni_print(pTHX_ U32 c)
 307 {
 308     U8 tmpbuf[10];
 309     uv_to_utf8(tmpbuf, (UV)c);
 310     return is_utf8_print(tmpbuf);
 311 }
 312
 313 U32
 314 Perl_to_uni_upper(pTHX_ U32 c)
 315 {
 316     U8 tmpbuf[10];
 317     uv_to_utf8(tmpbuf, (UV)c);
 318     return to_utf8_upper(tmpbuf);
 319 }
 320
 321 U32
 322 Perl_to_uni_title(pTHX_ U32 c)
 323 {
 324     U8 tmpbuf[10];
 325     uv_to_utf8(tmpbuf, (UV)c);
 326     return to_utf8_title(tmpbuf);
 327 }
 328
 329 U32
 330 Perl_to_uni_lower(pTHX_ U32 c)
 331 {
 332     U8 tmpbuf[10];
 333     uv_to_utf8(tmpbuf, (UV)c);
 334     return to_utf8_lower(tmpbuf);
 335 }
 336
 337 /* for now these all assume no locale info available for Unicode > 255 */
 338
 339 bool
 340 Perl_is_uni_alnum_lc(pTHX_ U32 c)
 341 {
 342     return is_uni_alnum(c);     /* XXX no locale support yet */
 343 }
 344
 345 bool
 346 Perl_is_uni_idfirst_lc(pTHX_ U32 c)
 347 {
 348     return is_uni_idfirst(c);   /* XXX no locale support yet */
 349 }
 350
 351 bool
 352 Perl_is_uni_alpha_lc(pTHX_ U32 c)
 353 {
 354     return is_uni_alpha(c);     /* XXX no locale support yet */
 355 }
 356
 357 bool
 358 Perl_is_uni_space_lc(pTHX_ U32 c)
 359 {
 360     return is_uni_space(c);     /* XXX no locale support yet */
 361 }
 362
 363 bool
 364 Perl_is_uni_digit_lc(pTHX_ U32 c)
 365 {
 366     return is_uni_digit(c);     /* XXX no locale support yet */
 367 }
 368
 369 bool
 370 Perl_is_uni_upper_lc(pTHX_ U32 c)
 371 {
 372     return is_uni_upper(c);     /* XXX no locale support yet */
 373 }
 374
 375 bool
 376 Perl_is_uni_lower_lc(pTHX_ U32 c)
 377 {
 378     return is_uni_lower(c);     /* XXX no locale support yet */
 379 }
 380
 381 bool
 382 Perl_is_uni_print_lc(pTHX_ U32 c)
 383 {
 384     return is_uni_print(c);     /* XXX no locale support yet */
 385 }
 386
 387 U32
 388 Perl_to_uni_upper_lc(pTHX_ U32 c)
 389 {
 390     return to_uni_upper(c);     /* XXX no locale support yet */
 391 }
 392
 393 U32
 394 Perl_to_uni_title_lc(pTHX_ U32 c)
 395 {
 396     return to_uni_title(c);     /* XXX no locale support yet */
 397 }
 398
 399 U32
 400 Perl_to_uni_lower_lc(pTHX_ U32 c)
 401 {
 402     return to_uni_lower(c);     /* XXX no locale support yet */
 403 }
 404
 405
 406 bool
 407 Perl_is_utf8_alnum(pTHX_ U8 *p)
 408 {
 409     if (!PL_utf8_alnum)
 410         PL_utf8_alnum = swash_init("utf8", "IsAlnum", &PL_sv_undef, 0, 0);
 411     return swash_fetch(PL_utf8_alnum, p);
 412 /*    return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */
 413 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
 414     if (!PL_utf8_alnum)
 415         PL_utf8_alnum = swash_init("utf8", "",
 416             sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
 417     return swash_fetch(PL_utf8_alnum, p);
 418 #endif
 419 }
 420
 421 bool
 422 Perl_is_utf8_idfirst(pTHX_ U8 *p)
 423 {
 424     return *p == '_' || is_utf8_alpha(p);
 425 }
 426
 427 bool
 428 Perl_is_utf8_alpha(pTHX_ U8 *p)
 429 {
 430     if (!PL_utf8_alpha)
 431         PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0);
 432     return swash_fetch(PL_utf8_alpha, p);
 433 }
 434
 435 bool
 436 Perl_is_utf8_space(pTHX_ U8 *p)
 437 {
 438     if (!PL_utf8_space)
 439         PL_utf8_space = swash_init("utf8", "IsSpace", &PL_sv_undef, 0, 0);
 440     return swash_fetch(PL_utf8_space, p);
 441 }
 442
 443 bool
 444 Perl_is_utf8_digit(pTHX_ U8 *p)
 445 {
 446     if (!PL_utf8_digit)
 447         PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0);
 448     return swash_fetch(PL_utf8_digit, p);
 449 }
 450
 451 bool
 452 Perl_is_utf8_upper(pTHX_ U8 *p)
 453 {
 454     if (!PL_utf8_upper)
 455         PL_utf8_upper = swash_init("utf8", "IsUpper", &PL_sv_undef, 0, 0);
 456     return swash_fetch(PL_utf8_upper, p);
 457 }
 458
 459 bool
 460 Perl_is_utf8_lower(pTHX_ U8 *p)
 461 {
 462     if (!PL_utf8_lower)
 463         PL_utf8_lower = swash_init("utf8", "IsLower", &PL_sv_undef, 0, 0);
 464     return swash_fetch(PL_utf8_lower, p);
 465 }
 466
 467 bool
 468 Perl_is_utf8_print(pTHX_ U8 *p)
 469 {
 470     if (!PL_utf8_print)
 471         PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0);
 472     return swash_fetch(PL_utf8_print, p);
 473 }
 474
 475 bool
 476 Perl_is_utf8_mark(pTHX_ U8 *p)
 477 {
 478     if (!PL_utf8_mark)
 479         PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0);
 480     return swash_fetch(PL_utf8_mark, p);
 481 }
 482
 483 UV
 484 Perl_to_utf8_upper(pTHX_ U8 *p)
 485 {
 486     UV uv;
 487
 488     if (!PL_utf8_toupper)
 489         PL_utf8_toupper = swash_init("utf8", "ToUpper", &PL_sv_undef, 4, 0);
 490     uv = swash_fetch(PL_utf8_toupper, p);
 491     return uv ? uv : utf8_to_uv(p,0);
 492 }
 493
 494 UV
 495 Perl_to_utf8_title(pTHX_ U8 *p)
 496 {
 497     UV uv;
 498
 499     if (!PL_utf8_totitle)
 500         PL_utf8_totitle = swash_init("utf8", "ToTitle", &PL_sv_undef, 4, 0);
 501     uv = swash_fetch(PL_utf8_totitle, p);
 502     return uv ? uv : utf8_to_uv(p,0);
 503 }
 504
 505 UV
 506 Perl_to_utf8_lower(pTHX_ U8 *p)
 507 {
 508     UV uv;
 509
 510     if (!PL_utf8_tolower)
 511         PL_utf8_tolower = swash_init("utf8", "ToLower", &PL_sv_undef, 4, 0);
 512     uv = swash_fetch(PL_utf8_tolower, p);
 513     return uv ? uv : utf8_to_uv(p,0);
 514 }
 515
 516 /* a "swash" is a swatch hash */
 517
 518 SV*
 519 Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
 520 {
 521     SV* retval;
 522     char tmpbuf[256];
 523     dSP;
 524     PUSHSTACKi(PERLSI_MAGIC);
 525     PUSHMARK(SP);
 526     EXTEND(SP,5);
 527     PUSHs(sv_2mortal(newSVpvn(pkg, strlen(pkg))));
 528     PUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
 529     PUSHs(listsv);
 530     PUSHs(sv_2mortal(newSViv(minbits)));
 531     PUSHs(sv_2mortal(newSViv(none)));
 532     PUTBACK;
 533     ENTER;
 534     SAVEI32(PL_hints);
 535     PL_hints = 0;
 536     save_re_context();
 537     if (PL_curcop == &PL_compiling)     /* XXX ought to be handled by lex_start */
 538         strncpy(tmpbuf, PL_tokenbuf, sizeof tmpbuf);
 539     if (call_method("SWASHNEW", G_SCALAR))
 540         retval = newSVsv(*PL_stack_sp--);
 541     else
 542         retval = &PL_sv_undef;
 543     LEAVE;
 544     POPSTACK;
 545     if (PL_curcop == &PL_compiling) {
 546         strncpy(PL_tokenbuf, tmpbuf, sizeof tmpbuf);
 547         PL_curcop->op_private = PL_hints;
 548     }
 549     if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV)
 550         Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
 551     return retval;
 552 }
 553
 554 UV
 555 Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr)
 556 {
 557     HV* hv = (HV*)SvRV(sv);
 558     U32 klen = UTF8SKIP(ptr) - 1;
 559     U32 off = ptr[klen] & 127;  /* NB: 64 bit always 0 when len > 1 */
 560     STRLEN slen;
 561     STRLEN needents = (klen ? 64 : 128);
 562     U8 *tmps;
 563     U32 bit;
 564     SV *retval;
 565
 566     /*
 567      * This single-entry cache saves about 1/3 of the utf8 overhead in test
 568      * suite.  (That is, only 7-8% overall over just a hash cache.  Still,
 569      * it's nothing to sniff at.)  Pity we usually come through at least
 570      * two function calls to get here...
 571      *
 572      * NB: this code assumes that swatches are never modified, once generated!
 573      */
 574
 575     if (hv == PL_last_swash_hv &&
 576         klen == PL_last_swash_klen &&
 577         (!klen || memEQ(ptr,PL_last_swash_key,klen)) )
 578     {
 579         tmps = PL_last_swash_tmps;
 580         slen = PL_last_swash_slen;
 581     }
 582     else {
 583         /* Try our second-level swatch cache, kept in a hash. */
 584         SV** svp = hv_fetch(hv, (char*)ptr, klen, FALSE);
 585
 586         /* If not cached, generate it via utf8::SWASHGET */
 587         if (!svp || !SvPOK(*svp) || !(tmps = (U8*)SvPV(*svp, slen))) {
 588             dSP;
 589             ENTER;
 590             SAVETMPS;
 591             save_re_context();
 592             PUSHSTACKi(PERLSI_MAGIC);
 593             PUSHMARK(SP);
 594             EXTEND(SP,3);
 595             PUSHs((SV*)sv);
 596             PUSHs(sv_2mortal(newSViv(utf8_to_uv(ptr, 0) & ~(needents - 1))));
 597             PUSHs(sv_2mortal(newSViv(needents)));
 598             PUTBACK;
 599             if (call_method("SWASHGET", G_SCALAR))
 600                 retval = newSVsv(*PL_stack_sp--);
 601             else
 602                 retval = &PL_sv_undef;
 603             POPSTACK;
 604             FREETMPS;
 605             LEAVE;
 606             if (PL_curcop == &PL_compiling)
 607                 PL_curcop->op_private = PL_hints;
 608
 609             svp = hv_store(hv, (char*)ptr, klen, retval, 0);
 610
 611             if (!svp || !(tmps = (U8*)SvPV(*svp, slen)) || slen < 8)
 612                 Perl_croak(aTHX_ "SWASHGET didn't return result of proper length");
 613         }
 614
 615         PL_last_swash_hv = hv;
 616         PL_last_swash_klen = klen;
 617         PL_last_swash_tmps = tmps;
 618         PL_last_swash_slen = slen;
 619         if (klen)
 620             Copy(ptr, PL_last_swash_key, klen, U8);
 621     }
 622
 623     switch ((slen << 3) / needents) {
 624     case 1:
 625         bit = 1 << (off & 7);
 626         off >>= 3;
 627         return (tmps[off] & bit) != 0;
 628     case 8:
 629         return tmps[off];
 630     case 16:
 631         off <<= 1;
 632         return (tmps[off] << 8) + tmps[off + 1] ;
 633     case 32:
 634         off <<= 2;
 635         return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
 636     }
 637     Perl_croak(aTHX_ "panic: swash_fetch");
 638     return 0;
 639 }