doop.c

   1 /*    doop.c
   2  *
   3  *    Copyright (c) 1991-2001, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "'So that was the job I felt I had to do when I started,' thought Sam."
  12  */
  13
  14 #include "EXTERN.h"
  15 #define PERL_IN_DOOP_C
  16 #include "perl.h"
  17
  18 #ifndef PERL_MICRO
  19 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  20 #include <signal.h>
  21 #endif
  22 #endif
  23
  24 STATIC I32
  25 S_do_trans_simple(pTHX_ SV *sv)
  26 {
  27     U8 *s;
  28     U8 *d;
  29     U8 *send;
  30     U8 *dstart;
  31     I32 matches = 0;
  32     I32 grows = PL_op->op_private & OPpTRANS_GROWS;
  33     STRLEN len;
  34     short *tbl;
  35     I32 ch;
  36
  37     tbl = (short*)cPVOP->op_pv;
  38     if (!tbl)
  39         Perl_croak(aTHX_ "panic: do_trans_simple");
  40
  41     s = (U8*)SvPV(sv, len);
  42     send = s + len;
  43
  44     /* First, take care of non-UTF8 input strings, because they're easy */
  45     if (!SvUTF8(sv)) {
  46         while (s < send) {
  47             if ((ch = tbl[*s]) >= 0) {
  48                 matches++;
  49                 *s++ = ch;
  50             }
  51             else
  52                 s++;
  53         }
  54         SvSETMAGIC(sv);
  55         return matches;
  56     }
  57
  58     /* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */
  59     if (grows)
  60         New(0, d, len*2+1, U8);
  61     else
  62         d = s;
  63     dstart = d;
  64     while (s < send) {
  65         STRLEN ulen;
  66         UV c;
  67
  68         /* Need to check this, otherwise 128..255 won't match */
  69         c = utf8_to_uv(s, send - s, &ulen, 0);
  70         if (c < 0x100 && (ch = tbl[c]) >= 0) {
  71             matches++;
  72             d = uv_to_utf8(d, ch);
  73             s += ulen;
  74         }
  75         else { /* No match -> copy */
  76             Copy(s, d, ulen, U8);
  77             d += ulen;
  78             s += ulen;
  79         }
  80     }
  81     if (grows) {
  82         sv_setpvn(sv, (char*)dstart, d - dstart);
  83         Safefree(dstart);
  84     }
  85     else {
  86         *d = '\0';
  87         SvCUR_set(sv, d - dstart);
  88     }
  89     SvUTF8_on(sv);
  90     SvSETMAGIC(sv);
  91     return matches;
  92 }
  93
  94 STATIC I32
  95 S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */
  96 {
  97     U8 *s;
  98     U8 *send;
  99     I32 matches = 0;
 100     STRLEN len;
 101     short *tbl;
 102
 103     tbl = (short*)cPVOP->op_pv;
 104     if (!tbl)
 105         Perl_croak(aTHX_ "panic: do_trans_count");
 106
 107     s = (U8*)SvPV(sv, len);
 108     send = s + len;
 109
 110     if (!SvUTF8(sv))
 111         while (s < send) {
 112             if (tbl[*s++] >= 0)
 113                 matches++;
 114         }
 115     else
 116         while (s < send) {
 117             UV c;
 118             STRLEN ulen;
 119             c = utf8_to_uv(s, send - s, &ulen, 0);
 120             if (c < 0x100 && tbl[c] >= 0)
 121                 matches++;
 122             s += ulen;
 123         }
 124
 125     return matches;
 126 }
 127
 128 STATIC I32
 129 S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
 130 {
 131     U8 *s;
 132     U8 *send;
 133     U8 *d;
 134     U8 *dstart;
 135     I32 isutf8;
 136     I32 matches = 0;
 137     I32 grows = PL_op->op_private & OPpTRANS_GROWS;
 138     STRLEN len;
 139     short *tbl;
 140     I32 ch;
 141
 142     tbl = (short*)cPVOP->op_pv;
 143     if (!tbl)
 144         Perl_croak(aTHX_ "panic: do_trans_complex");
 145
 146     s = (U8*)SvPV(sv, len);
 147     isutf8 = SvUTF8(sv);
 148     send = s + len;
 149
 150     if (!isutf8) {
 151         dstart = d = s;
 152         if (PL_op->op_private & OPpTRANS_SQUASH) {
 153             U8* p = send;
 154             while (s < send) {
 155                 if ((ch = tbl[*s]) >= 0) {
 156                     *d = ch;
 157                     matches++;
 158                     if (p != d - 1 || *p != *d)
 159                         p = d++;
 160                 }
 161                 else if (ch == -1)      /* -1 is unmapped character */
 162                     *d++ = *s;
 163                 else if (ch == -2)      /* -2 is delete character */
 164                     matches++;
 165                 s++;
 166             }
 167         }
 168         else {
 169             while (s < send) {
 170                 if ((ch = tbl[*s]) >= 0) {
 171                     matches++;
 172                     *d++ = ch;
 173                 }
 174                 else if (ch == -1)      /* -1 is unmapped character */
 175                     *d++ = *s;
 176                 else if (ch == -2)      /* -2 is delete character */
 177                     matches++;
 178                 s++;
 179             }
 180         }
 181         SvCUR_set(sv, d - dstart);
 182     }
 183     else { /* isutf8 */
 184         if (grows)
 185             New(0, d, len*2+1, U8);
 186         else
 187             d = s;
 188         dstart = d;
 189
 190 #ifdef MACOS_TRADITIONAL
 191 #define comp CoMP   /* "comp" is a keyword in some compilers ... */
 192 #endif
 193
 194         if (PL_op->op_private & OPpTRANS_SQUASH) {
 195             U8* p = send;
 196             UV pch = 0xfeedface;
 197             while (s < send) {
 198                 STRLEN len;
 199                 UV comp = utf8_to_uv_simple(s, &len);
 200
 201                 if (comp > 0xff) {      /* always unmapped */
 202                     Copy(s, d, len, U8);
 203                     d += len;
 204                 }
 205                 else if ((ch = tbl[comp]) >= 0) {
 206                     matches++;
 207                     if (ch != pch) {
 208                         d = uv_to_utf8(d, ch);
 209                         pch = ch;
 210                     }
 211                     s += len;
 212                     continue;
 213                 }
 214                 else if (ch == -1) {    /* -1 is unmapped character */
 215                     Copy(s, d, len, U8);
 216                     d += len;
 217                 }
 218                 else if (ch == -2)      /* -2 is delete character */
 219                     matches++;
 220                 s += len;
 221                 pch = 0xfeedface;
 222             }
 223         }
 224         else {
 225             while (s < send) {
 226                 STRLEN len;
 227                 UV comp = utf8_to_uv_simple(s, &len);
 228                 if (comp > 0xff) {      /* always unmapped */
 229                     Copy(s, d, len, U8);
 230                     d += len;
 231                 }
 232                 else if ((ch = tbl[comp]) >= 0) {
 233                     d = uv_to_utf8(d, ch);
 234                     matches++;
 235                 }
 236                 else if (ch == -1) {    /* -1 is unmapped character */
 237                     Copy(s, d, len, U8);
 238                     d += len;
 239                 }
 240                 else if (ch == -2)      /* -2 is delete character */
 241                     matches++;
 242                 s += len;
 243             }
 244         }
 245         if (grows) {
 246             sv_setpvn(sv, (char*)dstart, d - dstart);
 247             Safefree(dstart);
 248         }
 249         else {
 250             *d = '\0';
 251             SvCUR_set(sv, d - dstart);
 252         }
 253         SvUTF8_on(sv);
 254     }
 255     SvSETMAGIC(sv);
 256     return matches;
 257 }
 258
 259 STATIC I32
 260 S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */
 261 {
 262     U8 *s;
 263     U8 *send;
 264     U8 *d;
 265     U8 *start;
 266     U8 *dstart, *dend;
 267     I32 matches = 0;
 268     I32 grows = PL_op->op_private & OPpTRANS_GROWS;
 269     STRLEN len;
 270
 271     SV* rv = (SV*)cSVOP->op_sv;
 272     HV* hv = (HV*)SvRV(rv);
 273     SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
 274     UV none = svp ? SvUV(*svp) : 0x7fffffff;
 275     UV extra = none + 1;
 276     UV final;
 277     UV uv;
 278     I32 isutf8;
 279     U8 hibit = 0;
 280
 281     s = (U8*)SvPV(sv, len);
 282     isutf8 = SvUTF8(sv);
 283     if (!isutf8) {
 284         U8 *t = s, *e = s + len;
 285         while (t < e)
 286             if ((hibit = UTF8_IS_CONTINUED(*t++)))
 287                 break;
 288         if (hibit)
 289             s = bytes_to_utf8(s, &len);
 290     }
 291     send = s + len;
 292     start = s;
 293
 294     svp = hv_fetch(hv, "FINAL", 5, FALSE);
 295     if (svp)
 296         final = SvUV(*svp);
 297
 298     if (grows) {
 299         /* d needs to be bigger than s, in case e.g. upgrading is required */
 300         New(0, d, len*3+UTF8_MAXLEN, U8);
 301         dend = d + len * 3;
 302         dstart = d;
 303     }
 304     else {
 305         dstart = d = s;
 306         dend = d + len;
 307     }
 308
 309     while (s < send) {
 310         if ((uv = swash_fetch(rv, s)) < none) {
 311             s += UTF8SKIP(s);
 312             matches++;
 313             d = uv_to_utf8(d, uv);
 314         }
 315         else if (uv == none) {
 316             int i = UTF8SKIP(s);
 317             Copy(s, d, i, U8);
 318             d += i;
 319             s += i;
 320         }
 321         else if (uv == extra) {
 322             int i = UTF8SKIP(s);
 323             s += i;
 324             matches++;
 325             d = uv_to_utf8(d, final);
 326         }
 327         else
 328             s += UTF8SKIP(s);
 329
 330         if (d > dend) {
 331             STRLEN clen = d - dstart;
 332             STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
 333             if (!grows)
 334                 Perl_croak(aTHX_ "panic: do_trans_complex_utf8");
 335             Renew(dstart, nlen+UTF8_MAXLEN, U8);
 336             d = dstart + clen;
 337             dend = dstart + nlen;
 338         }
 339     }
 340     if (grows || hibit) {
 341         sv_setpvn(sv, (char*)dstart, d - dstart);
 342         Safefree(dstart);
 343         if (grows && hibit)
 344             Safefree(start);
 345     }
 346     else {
 347         *d = '\0';
 348         SvCUR_set(sv, d - dstart);
 349     }
 350     SvSETMAGIC(sv);
 351     SvUTF8_on(sv);
 352     if (!isutf8 && !(PL_hints & HINT_UTF8))
 353         sv_utf8_downgrade(sv, TRUE);
 354
 355     return matches;
 356 }
 357
 358 STATIC I32
 359 S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */
 360 {
 361     U8 *s;
 362     U8 *start, *send;
 363     I32 matches = 0;
 364     STRLEN len;
 365
 366     SV* rv = (SV*)cSVOP->op_sv;
 367     HV* hv = (HV*)SvRV(rv);
 368     SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
 369     UV none = svp ? SvUV(*svp) : 0x7fffffff;
 370     UV uv;
 371     U8 hibit = 0;
 372
 373     s = (U8*)SvPV(sv, len);
 374     if (!SvUTF8(sv)) {
 375         U8 *t = s, *e = s + len;
 376         while (t < e)
 377             if ((hibit = !UTF8_IS_ASCII(*t++)))
 378                 break;
 379         if (hibit)
 380             start = s = bytes_to_utf8(s, &len);
 381     }
 382     send = s + len;
 383
 384     while (s < send) {
 385         if ((uv = swash_fetch(rv, s)) < none)
 386             matches++;
 387         s += UTF8SKIP(s);
 388     }
 389     if (hibit)
 390         Safefree(start);
 391
 392     return matches;
 393 }
 394
 395 STATIC I32
 396 S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
 397 {
 398     U8 *s;
 399     U8 *start, *send;
 400     U8 *d;
 401     I32 matches = 0;
 402     I32 squash   = PL_op->op_private & OPpTRANS_SQUASH;
 403     I32 del      = PL_op->op_private & OPpTRANS_DELETE;
 404     I32 grows    = PL_op->op_private & OPpTRANS_GROWS;
 405     SV* rv = (SV*)cSVOP->op_sv;
 406     HV* hv = (HV*)SvRV(rv);
 407     SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
 408     UV none = svp ? SvUV(*svp) : 0x7fffffff;
 409     UV extra = none + 1;
 410     UV final;
 411     UV uv;
 412     STRLEN len;
 413     U8 *dstart, *dend;
 414     I32 isutf8;
 415     U8 hibit = 0;
 416
 417     s = (U8*)SvPV(sv, len);
 418     isutf8 = SvUTF8(sv);
 419     if (!isutf8) {
 420         U8 *t = s, *e = s + len;
 421         while (t < e)
 422             if ((hibit = !UTF8_IS_ASCII(*t++)))
 423                 break;
 424         if (hibit)
 425             s = bytes_to_utf8(s, &len);
 426     }
 427     send = s + len;
 428     start = s;
 429
 430     svp = hv_fetch(hv, "FINAL", 5, FALSE);
 431     if (svp)
 432         final = SvUV(*svp);
 433
 434     if (grows) {
 435         /* d needs to be bigger than s, in case e.g. upgrading is required */
 436         New(0, d, len*3+UTF8_MAXLEN, U8);
 437         dend = d + len * 3;
 438         dstart = d;
 439     }
 440     else {
 441         dstart = d = s;
 442         dend = d + len;
 443     }
 444
 445     if (squash) {
 446         UV puv = 0xfeedface;
 447         while (s < send) {
 448             uv = swash_fetch(rv, s);
 449
 450             if (d > dend) {
 451                 STRLEN clen = d - dstart;
 452                 STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
 453                 if (!grows)
 454                     Perl_croak(aTHX_ "panic: do_trans_complex_utf8");
 455                 Renew(dstart, nlen+UTF8_MAXLEN, U8);
 456                 d = dstart + clen;
 457                 dend = dstart + nlen;
 458             }
 459             if (uv < none) {
 460                 matches++;
 461                 if (uv != puv) {
 462                     d = uv_to_utf8(d, uv);
 463                     puv = uv;
 464                 }
 465                 s += UTF8SKIP(s);
 466                 continue;
 467             }
 468             else if (uv == none) {      /* "none" is unmapped character */
 469                 int i = UTF8SKIP(s);
 470                 Copy(s, d, i, U8);
 471                 d += i;
 472                 s += i;
 473                 puv = 0xfeedface;
 474                 continue;
 475             }
 476             else if (uv == extra && !del) {
 477                 matches++;
 478                 if (uv != puv) {
 479                     d = uv_to_utf8(d, final);
 480                     puv = final;
 481                 }
 482                 s += UTF8SKIP(s);
 483                 continue;
 484             }
 485             matches++;                  /* "none+1" is delete character */
 486             s += UTF8SKIP(s);
 487         }
 488     }
 489     else {
 490         while (s < send) {
 491             uv = swash_fetch(rv, s);
 492             if (d > dend) {
 493                 STRLEN clen = d - dstart;
 494                 STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
 495                 if (!grows)
 496                     Perl_croak(aTHX_ "panic: do_trans_complex_utf8");
 497                 Renew(dstart, nlen+UTF8_MAXLEN, U8);
 498                 d = dstart + clen;
 499                 dend = dstart + nlen;
 500             }
 501             if (uv < none) {
 502                 matches++;
 503                 d = uv_to_utf8(d, uv);
 504                 s += UTF8SKIP(s);
 505                 continue;
 506             }
 507             else if (uv == none) {      /* "none" is unmapped character */
 508                 int i = UTF8SKIP(s);
 509                 Copy(s, d, i, U8);
 510                 d += i;
 511                 s += i;
 512                 continue;
 513             }
 514             else if (uv == extra && !del) {
 515                 matches++;
 516                 d = uv_to_utf8(d, final);
 517                 s += UTF8SKIP(s);
 518                 continue;
 519             }
 520             matches++;                  /* "none+1" is delete character */
 521             s += UTF8SKIP(s);
 522         }
 523     }
 524     if (grows || hibit) {
 525         sv_setpvn(sv, (char*)dstart, d - dstart);
 526         Safefree(dstart);
 527         if (grows && hibit)
 528             Safefree(start);
 529     }
 530     else {
 531         *d = '\0';
 532         SvCUR_set(sv, d - dstart);
 533     }
 534     SvUTF8_on(sv);
 535     if (!isutf8 && !(PL_hints & HINT_UTF8))
 536         sv_utf8_downgrade(sv, TRUE);
 537     SvSETMAGIC(sv);
 538
 539     return matches;
 540 }
 541
 542 I32
 543 Perl_do_trans(pTHX_ SV *sv)
 544 {
 545     STRLEN len;
 546     I32 hasutf = (PL_op->op_private &
 547                     (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
 548
 549     if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
 550         Perl_croak(aTHX_ PL_no_modify);
 551
 552     (void)SvPV(sv, len);
 553     if (!len)
 554         return 0;
 555     if (!SvPOKp(sv))
 556         (void)SvPV_force(sv, len);
 557     if (!(PL_op->op_private & OPpTRANS_IDENTICAL))
 558         (void)SvPOK_only_UTF8(sv);
 559
 560     DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
 561
 562     switch (PL_op->op_private & ~hasutf & 63) {
 563     case 0:
 564         if (hasutf)
 565             return do_trans_simple_utf8(sv);
 566         else
 567             return do_trans_simple(sv);
 568
 569     case OPpTRANS_IDENTICAL:
 570         if (hasutf)
 571             return do_trans_count_utf8(sv);
 572         else
 573             return do_trans_count(sv);
 574
 575     default:
 576         if (hasutf)
 577             return do_trans_complex_utf8(sv);
 578         else
 579             return do_trans_complex(sv);
 580     }
 581 }
 582
 583 void
 584 Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **sp)
 585 {
 586     SV **oldmark = mark;
 587     register I32 items = sp - mark;
 588     register STRLEN len;
 589     STRLEN delimlen;
 590     register char *delim = SvPV(del, delimlen);
 591     STRLEN tmplen;
 592
 593     mark++;
 594     len = (items > 0 ? (delimlen * (items - 1) ) : 0);
 595     (void)SvUPGRADE(sv, SVt_PV);
 596     if (SvLEN(sv) < len + items) {      /* current length is way too short */
 597         while (items-- > 0) {
 598             if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) {
 599                 SvPV(*mark, tmplen);
 600                 len += tmplen;
 601             }
 602             mark++;
 603         }
 604         SvGROW(sv, len + 1);            /* so try to pre-extend */
 605
 606         mark = oldmark;
 607         items = sp - mark;
 608         ++mark;
 609     }
 610
 611     if (items-- > 0) {
 612         sv_setpv(sv, "");
 613         if (*mark)
 614             sv_catsv(sv, *mark);
 615         mark++;
 616     }
 617     else
 618         sv_setpv(sv,"");
 619     if (delimlen) {
 620         for (; items > 0; items--,mark++) {
 621             sv_catsv(sv,del);
 622             sv_catsv(sv,*mark);
 623         }
 624     }
 625     else {
 626         for (; items > 0; items--,mark++)
 627             sv_catsv(sv,*mark);
 628     }
 629     SvSETMAGIC(sv);
 630 }
 631
 632 void
 633 Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
 634 {
 635     STRLEN patlen;
 636     char *pat = SvPV(*sarg, patlen);
 637     bool do_taint = FALSE;
 638
 639     sv_vsetpvfn(sv, pat, patlen, Null(va_list*), sarg + 1, len - 1, &do_taint);
 640     SvSETMAGIC(sv);
 641     if (do_taint)
 642         SvTAINTED_on(sv);
 643 }
 644
 645 /* currently converts input to bytes if possible, but doesn't sweat failure */
 646 UV
 647 Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
 648 {
 649     STRLEN srclen, len;
 650     unsigned char *s = (unsigned char *) SvPV(sv, srclen);
 651     UV retnum = 0;
 652
 653     if (offset < 0)
 654         return retnum;
 655     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
 656         Perl_croak(aTHX_ "Illegal number of bits in vec");
 657
 658     if (SvUTF8(sv))
 659         (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE);
 660
 661     offset *= size;     /* turn into bit offset */
 662     len = (offset + size + 7) / 8;      /* required number of bytes */
 663     if (len > srclen) {
 664         if (size <= 8)
 665             retnum = 0;
 666         else {
 667             offset >>= 3;       /* turn into byte offset */
 668             if (size == 16) {
 669                 if (offset >= srclen)
 670                     retnum = 0;
 671                 else
 672                     retnum = (UV) s[offset] <<  8;
 673             }
 674             else if (size == 32) {
 675                 if (offset >= srclen)
 676                     retnum = 0;
 677                 else if (offset + 1 >= srclen)
 678                     retnum =
 679                         ((UV) s[offset    ] << 24);
 680                 else if (offset + 2 >= srclen)
 681                     retnum =
 682                         ((UV) s[offset    ] << 24) +
 683                         ((UV) s[offset + 1] << 16);
 684                 else
 685                     retnum =
 686                         ((UV) s[offset    ] << 24) +
 687                         ((UV) s[offset + 1] << 16) +
 688                         (     s[offset + 2] <<  8);
 689             }
 690 #ifdef UV_IS_QUAD
 691             else if (size == 64) {
 692                 if (ckWARN(WARN_PORTABLE))
 693                     Perl_warner(aTHX_ WARN_PORTABLE,
 694                                 "Bit vector size > 32 non-portable");
 695                 if (offset >= srclen)
 696                     retnum = 0;
 697                 else if (offset + 1 >= srclen)
 698                     retnum =
 699                         (UV) s[offset     ] << 56;
 700                 else if (offset + 2 >= srclen)
 701                     retnum =
 702                         ((UV) s[offset    ] << 56) +
 703                         ((UV) s[offset + 1] << 48);
 704                 else if (offset + 3 >= srclen)
 705                     retnum =
 706                         ((UV) s[offset    ] << 56) +
 707                         ((UV) s[offset + 1] << 48) +
 708                         ((UV) s[offset + 2] << 40);
 709                 else if (offset + 4 >= srclen)
 710                     retnum =
 711                         ((UV) s[offset    ] << 56) +
 712                         ((UV) s[offset + 1] << 48) +
 713                         ((UV) s[offset + 2] << 40) +
 714                         ((UV) s[offset + 3] << 32);
 715                 else if (offset + 5 >= srclen)
 716                     retnum =
 717                         ((UV) s[offset    ] << 56) +
 718                         ((UV) s[offset + 1] << 48) +
 719                         ((UV) s[offset + 2] << 40) +
 720                         ((UV) s[offset + 3] << 32) +
 721                         (     s[offset + 4] << 24);
 722                 else if (offset + 6 >= srclen)
 723                     retnum =
 724                         ((UV) s[offset    ] << 56) +
 725                         ((UV) s[offset + 1] << 48) +
 726                         ((UV) s[offset + 2] << 40) +
 727                         ((UV) s[offset + 3] << 32) +
 728                         ((UV) s[offset + 4] << 24) +
 729                         ((UV) s[offset + 5] << 16);
 730                 else
 731                     retnum =
 732                         ((UV) s[offset    ] << 56) +
 733                         ((UV) s[offset + 1] << 48) +
 734                         ((UV) s[offset + 2] << 40) +
 735                         ((UV) s[offset + 3] << 32) +
 736                         ((UV) s[offset + 4] << 24) +
 737                         ((UV) s[offset + 5] << 16) +
 738                         (     s[offset + 6] <<  8);
 739             }
 740 #endif
 741         }
 742     }
 743     else if (size < 8)
 744         retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
 745     else {
 746         offset >>= 3;   /* turn into byte offset */
 747         if (size == 8)
 748             retnum = s[offset];
 749         else if (size == 16)
 750             retnum =
 751                 ((UV) s[offset] <<      8) +
 752                       s[offset + 1];
 753         else if (size == 32)
 754             retnum =
 755                 ((UV) s[offset    ] << 24) +
 756                 ((UV) s[offset + 1] << 16) +
 757                 (     s[offset + 2] <<  8) +
 758                       s[offset + 3];
 759 #ifdef UV_IS_QUAD
 760         else if (size == 64) {
 761             if (ckWARN(WARN_PORTABLE))
 762                 Perl_warner(aTHX_ WARN_PORTABLE,
 763                             "Bit vector size > 32 non-portable");
 764             retnum =
 765                 ((UV) s[offset    ] << 56) +
 766                 ((UV) s[offset + 1] << 48) +
 767                 ((UV) s[offset + 2] << 40) +
 768                 ((UV) s[offset + 3] << 32) +
 769                 ((UV) s[offset + 4] << 24) +
 770                 ((UV) s[offset + 5] << 16) +
 771                 (     s[offset + 6] <<  8) +
 772                       s[offset + 7];
 773         }
 774 #endif
 775     }
 776
 777     return retnum;
 778 }
 779
 780 /* currently converts input to bytes if possible but doesn't sweat failures,
 781  * although it does ensure that the string it clobbers is not marked as
 782  * utf8-valid any more
 783  */
 784 void
 785 Perl_do_vecset(pTHX_ SV *sv)
 786 {
 787     SV *targ = LvTARG(sv);
 788     register I32 offset;
 789     register I32 size;
 790     register unsigned char *s;
 791     register UV lval;
 792     I32 mask;
 793     STRLEN targlen;
 794     STRLEN len;
 795
 796     if (!targ)
 797         return;
 798     s = (unsigned char*)SvPV_force(targ, targlen);
 799     if (SvUTF8(targ)) {
 800         /* This is handled by the SvPOK_only below...
 801         if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
 802             SvUTF8_off(targ);
 803          */
 804         (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
 805     }
 806
 807     (void)SvPOK_only(targ);
 808     lval = SvUV(sv);
 809     offset = LvTARGOFF(sv);
 810     if (offset < 0)
 811         Perl_croak(aTHX_ "Assigning to negative offset in vec");
 812     size = LvTARGLEN(sv);
 813     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
 814         Perl_croak(aTHX_ "Illegal number of bits in vec");
 815
 816     offset *= size;                     /* turn into bit offset */
 817     len = (offset + size + 7) / 8;      /* required number of bytes */
 818     if (len > targlen) {
 819         s = (unsigned char*)SvGROW(targ, len + 1);
 820         (void)memzero((char *)(s + targlen), len - targlen + 1);
 821         SvCUR_set(targ, len);
 822     }
 823
 824     if (size < 8) {
 825         mask = (1 << size) - 1;
 826         size = offset & 7;
 827         lval &= mask;
 828         offset >>= 3;                   /* turn into byte offset */
 829         s[offset] &= ~(mask << size);
 830         s[offset] |= lval << size;
 831     }
 832     else {
 833         offset >>= 3;                   /* turn into byte offset */
 834         if (size == 8)
 835             s[offset  ] = lval         & 0xff;
 836         else if (size == 16) {
 837             s[offset  ] = (lval >>  8) & 0xff;
 838             s[offset+1] = lval         & 0xff;
 839         }
 840         else if (size == 32) {
 841             s[offset  ] = (lval >> 24) & 0xff;
 842             s[offset+1] = (lval >> 16) & 0xff;
 843             s[offset+2] = (lval >>  8) & 0xff;
 844             s[offset+3] =  lval        & 0xff;
 845         }
 846 #ifdef UV_IS_QUAD
 847         else if (size == 64) {
 848             if (ckWARN(WARN_PORTABLE))
 849                 Perl_warner(aTHX_ WARN_PORTABLE,
 850                             "Bit vector size > 32 non-portable");
 851             s[offset  ] = (lval >> 56) & 0xff;
 852             s[offset+1] = (lval >> 48) & 0xff;
 853             s[offset+2] = (lval >> 40) & 0xff;
 854             s[offset+3] = (lval >> 32) & 0xff;
 855             s[offset+4] = (lval >> 24) & 0xff;
 856             s[offset+5] = (lval >> 16) & 0xff;
 857             s[offset+6] = (lval >>  8) & 0xff;
 858             s[offset+7] =  lval        & 0xff;
 859         }
 860 #endif
 861     }
 862     SvSETMAGIC(targ);
 863 }
 864
 865 void
 866 Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
 867 {
 868     STRLEN len;
 869     char *s;
 870
 871     if (SvTYPE(sv) == SVt_PVAV) {
 872         register I32 i;
 873         I32 max;
 874         AV* av = (AV*)sv;
 875         max = AvFILL(av);
 876         for (i = 0; i <= max; i++) {
 877             sv = (SV*)av_fetch(av, i, FALSE);
 878             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
 879                 do_chop(astr, sv);
 880         }
 881         return;
 882     }
 883     else if (SvTYPE(sv) == SVt_PVHV) {
 884         HV* hv = (HV*)sv;
 885         HE* entry;
 886         (void)hv_iterinit(hv);
 887         /*SUPPRESS 560*/
 888         while ((entry = hv_iternext(hv)))
 889             do_chop(astr,hv_iterval(hv,entry));
 890         return;
 891     }
 892     else if (SvREADONLY(sv))
 893         Perl_croak(aTHX_ PL_no_modify);
 894     s = SvPV(sv, len);
 895     if (len && !SvPOK(sv))
 896         s = SvPV_force(sv, len);
 897     if (DO_UTF8(sv)) {
 898         if (s && len) {
 899             char *send = s + len;
 900             char *start = s;
 901             s = send - 1;
 902             while (s > start && UTF8_IS_CONTINUATION(*s))
 903                 s--;
 904             if (utf8_to_uv_simple((U8*)s, 0)) {
 905                 sv_setpvn(astr, s, send - s);
 906                 *s = '\0';
 907                 SvCUR_set(sv, s - start);
 908                 SvNIOK_off(sv);
 909                 SvUTF8_on(astr);
 910             }
 911         }
 912         else
 913             sv_setpvn(astr, "", 0);
 914     }
 915     else if (s && len) {
 916         s += --len;
 917         sv_setpvn(astr, s, 1);
 918         *s = '\0';
 919         SvCUR_set(sv, len);
 920         SvUTF8_off(sv);
 921         SvNIOK_off(sv);
 922     }
 923     else
 924         sv_setpvn(astr, "", 0);
 925     SvSETMAGIC(sv);
 926 }
 927
 928 I32
 929 Perl_do_chomp(pTHX_ register SV *sv)
 930 {
 931     register I32 count;
 932     STRLEN len;
 933     char *s;
 934
 935     if (RsSNARF(PL_rs))
 936         return 0;
 937     if (RsRECORD(PL_rs))
 938       return 0;
 939     count = 0;
 940     if (SvTYPE(sv) == SVt_PVAV) {
 941         register I32 i;
 942         I32 max;
 943         AV* av = (AV*)sv;
 944         max = AvFILL(av);
 945         for (i = 0; i <= max; i++) {
 946             sv = (SV*)av_fetch(av, i, FALSE);
 947             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
 948                 count += do_chomp(sv);
 949         }
 950         return count;
 951     }
 952     else if (SvTYPE(sv) == SVt_PVHV) {
 953         HV* hv = (HV*)sv;
 954         HE* entry;
 955         (void)hv_iterinit(hv);
 956         /*SUPPRESS 560*/
 957         while ((entry = hv_iternext(hv)))
 958             count += do_chomp(hv_iterval(hv,entry));
 959         return count;
 960     }
 961     else if (SvREADONLY(sv))
 962         Perl_croak(aTHX_ PL_no_modify);
 963     s = SvPV(sv, len);
 964     if (len && !SvPOKp(sv))
 965         s = SvPV_force(sv, len);
 966     if (s && len) {
 967         s += --len;
 968         if (RsPARA(PL_rs)) {
 969             if (*s != '\n')
 970                 goto nope;
 971             ++count;
 972             while (len && s[-1] == '\n') {
 973                 --len;
 974                 --s;
 975                 ++count;
 976             }
 977         }
 978         else {
 979             STRLEN rslen;
 980             char *rsptr = SvPV(PL_rs, rslen);
 981             if (rslen == 1) {
 982                 if (*s != *rsptr)
 983                     goto nope;
 984                 ++count;
 985             }
 986             else {
 987                 if (len < rslen - 1)
 988                     goto nope;
 989                 len -= rslen - 1;
 990                 s -= rslen - 1;
 991                 if (memNE(s, rsptr, rslen))
 992                     goto nope;
 993                 count += rslen;
 994             }
 995         }
 996         *s = '\0';
 997         SvCUR_set(sv, len);
 998         SvNIOK_off(sv);
 999     }
1000   nope:
1001     SvSETMAGIC(sv);
1002     return count;
1003 }
1004
1005 void
1006 Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
1007 {
1008 #ifdef LIBERAL
1009     register long *dl;
1010     register long *ll;
1011     register long *rl;
1012 #endif
1013     register char *dc;
1014     STRLEN leftlen;
1015     STRLEN rightlen;
1016     register char *lc;
1017     register char *rc;
1018     register I32 len;
1019     I32 lensave;
1020     char *lsave;
1021     char *rsave;
1022     bool left_utf = DO_UTF8(left);
1023     bool right_utf = DO_UTF8(right);
1024     I32 needlen;
1025
1026     if (left_utf && !right_utf)
1027         sv_utf8_upgrade(right);
1028     else if (!left_utf && right_utf)
1029         sv_utf8_upgrade(left);
1030
1031     if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
1032         sv_setpvn(sv, "", 0);   /* avoid undef warning on |= and ^= */
1033     lsave = lc = SvPV(left, leftlen);
1034     rsave = rc = SvPV(right, rightlen);
1035     len = leftlen < rightlen ? leftlen : rightlen;
1036     lensave = len;
1037     if ((left_utf || right_utf) && (sv == left || sv == right)) {
1038         needlen = optype == OP_BIT_AND ? len : leftlen + rightlen;
1039         Newz(801, dc, needlen + 1, char);
1040     }
1041     else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
1042         STRLEN n_a;
1043         dc = SvPV_force(sv, n_a);
1044         if (SvCUR(sv) < len) {
1045             dc = SvGROW(sv, len + 1);
1046             (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
1047         }
1048         if (optype != OP_BIT_AND && (left_utf || right_utf))
1049             dc = SvGROW(sv, leftlen + rightlen + 1);
1050     }
1051     else {
1052         needlen = ((optype == OP_BIT_AND)
1053                     ? len : (leftlen > rightlen ? leftlen : rightlen));
1054         Newz(801, dc, needlen + 1, char);
1055         (void)sv_usepvn(sv, dc, needlen);
1056         dc = SvPVX(sv);         /* sv_usepvn() calls Renew() */
1057     }
1058     SvCUR_set(sv, len);
1059     (void)SvPOK_only(sv);
1060     if (left_utf || right_utf) {
1061         UV duc, luc, ruc;
1062         char *dcsave = dc;
1063         STRLEN lulen = leftlen;
1064         STRLEN rulen = rightlen;
1065         STRLEN ulen;
1066
1067         switch (optype) {
1068         case OP_BIT_AND:
1069             while (lulen && rulen) {
1070                 luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1071                 lc += ulen;
1072                 lulen -= ulen;
1073                 ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1074                 rc += ulen;
1075                 rulen -= ulen;
1076                 duc = luc & ruc;
1077                 dc = (char*)uv_to_utf8((U8*)dc, duc);
1078             }
1079             if (sv == left || sv == right)
1080                 (void)sv_usepvn(sv, dcsave, needlen);
1081             SvCUR_set(sv, dc - dcsave);
1082             break;
1083         case OP_BIT_XOR:
1084             while (lulen && rulen) {
1085                 luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1086                 lc += ulen;
1087                 lulen -= ulen;
1088                 ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1089                 rc += ulen;
1090                 rulen -= ulen;
1091                 duc = luc ^ ruc;
1092                 dc = (char*)uv_to_utf8((U8*)dc, duc);
1093             }
1094             goto mop_up_utf;
1095         case OP_BIT_OR:
1096             while (lulen && rulen) {
1097                 luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1098                 lc += ulen;
1099                 lulen -= ulen;
1100                 ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1101                 rc += ulen;
1102                 rulen -= ulen;
1103                 duc = luc | ruc;
1104                 dc = (char*)uv_to_utf8((U8*)dc, duc);
1105             }
1106           mop_up_utf:
1107             if (sv == left || sv == right)
1108                 (void)sv_usepvn(sv, dcsave, needlen);
1109             SvCUR_set(sv, dc - dcsave);
1110             if (rulen)
1111                 sv_catpvn(sv, rc, rulen);
1112             else if (lulen)
1113                 sv_catpvn(sv, lc, lulen);
1114             else
1115                 *SvEND(sv) = '\0';
1116             break;
1117         }
1118         SvUTF8_on(sv);
1119         goto finish;
1120     }
1121     else
1122 #ifdef LIBERAL
1123     if (len >= sizeof(long)*4 &&
1124         !((long)dc % sizeof(long)) &&
1125         !((long)lc % sizeof(long)) &&
1126         !((long)rc % sizeof(long)))     /* It's almost always aligned... */
1127     {
1128         I32 remainder = len % (sizeof(long)*4);
1129         len /= (sizeof(long)*4);
1130
1131         dl = (long*)dc;
1132         ll = (long*)lc;
1133         rl = (long*)rc;
1134
1135         switch (optype) {
1136         case OP_BIT_AND:
1137             while (len--) {
1138                 *dl++ = *ll++ & *rl++;
1139                 *dl++ = *ll++ & *rl++;
1140                 *dl++ = *ll++ & *rl++;
1141                 *dl++ = *ll++ & *rl++;
1142             }
1143             break;
1144         case OP_BIT_XOR:
1145             while (len--) {
1146                 *dl++ = *ll++ ^ *rl++;
1147                 *dl++ = *ll++ ^ *rl++;
1148                 *dl++ = *ll++ ^ *rl++;
1149                 *dl++ = *ll++ ^ *rl++;
1150             }
1151             break;
1152         case OP_BIT_OR:
1153             while (len--) {
1154                 *dl++ = *ll++ | *rl++;
1155                 *dl++ = *ll++ | *rl++;
1156                 *dl++ = *ll++ | *rl++;
1157                 *dl++ = *ll++ | *rl++;
1158             }
1159         }
1160
1161         dc = (char*)dl;
1162         lc = (char*)ll;
1163         rc = (char*)rl;
1164
1165         len = remainder;
1166     }
1167 #endif
1168     {
1169         switch (optype) {
1170         case OP_BIT_AND:
1171             while (len--)
1172                 *dc++ = *lc++ & *rc++;
1173             break;
1174         case OP_BIT_XOR:
1175             while (len--)
1176                 *dc++ = *lc++ ^ *rc++;
1177             goto mop_up;
1178         case OP_BIT_OR:
1179             while (len--)
1180                 *dc++ = *lc++ | *rc++;
1181           mop_up:
1182             len = lensave;
1183             if (rightlen > len)
1184                 sv_catpvn(sv, rsave + len, rightlen - len);
1185             else if (leftlen > len)
1186                 sv_catpvn(sv, lsave + len, leftlen - len);
1187             else
1188                 *SvEND(sv) = '\0';
1189             break;
1190         }
1191     }
1192 finish:
1193     SvTAINT(sv);
1194 }
1195
1196 OP *
1197 Perl_do_kv(pTHX)
1198 {
1199     djSP;
1200     HV *hv = (HV*)POPs;
1201     HV *keys;
1202     register HE *entry;
1203     SV *tmpstr;
1204     I32 gimme = GIMME_V;
1205     I32 dokeys =   (PL_op->op_type == OP_KEYS);
1206     I32 dovalues = (PL_op->op_type == OP_VALUES);
1207     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
1208
1209     if (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV)
1210         dokeys = dovalues = TRUE;
1211
1212     if (!hv) {
1213         if (PL_op->op_flags & OPf_MOD || LVRET) {       /* lvalue */
1214             dTARGET;            /* make sure to clear its target here */
1215             if (SvTYPE(TARG) == SVt_PVLV)
1216                 LvTARG(TARG) = Nullsv;
1217             PUSHs(TARG);
1218         }
1219         RETURN;
1220     }
1221
1222     keys = realhv ? hv : avhv_keys((AV*)hv);
1223     (void)hv_iterinit(keys);    /* always reset iterator regardless */
1224
1225     if (gimme == G_VOID)
1226         RETURN;
1227
1228     if (gimme == G_SCALAR) {
1229         IV i;
1230         dTARGET;
1231
1232         if (PL_op->op_flags & OPf_MOD || LVRET) {       /* lvalue */
1233             if (SvTYPE(TARG) < SVt_PVLV) {
1234                 sv_upgrade(TARG, SVt_PVLV);
1235                 sv_magic(TARG, Nullsv, 'k', Nullch, 0);
1236             }
1237             LvTYPE(TARG) = 'k';
1238             if (LvTARG(TARG) != (SV*)keys) {
1239                 if (LvTARG(TARG))
1240                     SvREFCNT_dec(LvTARG(TARG));
1241                 LvTARG(TARG) = SvREFCNT_inc(keys);
1242             }
1243             PUSHs(TARG);
1244             RETURN;
1245         }
1246
1247         if (! SvTIED_mg((SV*)keys, 'P'))
1248             i = HvKEYS(keys);
1249         else {
1250             i = 0;
1251             /*SUPPRESS 560*/
1252             while (hv_iternext(keys)) i++;
1253         }
1254         PUSHi( i );
1255         RETURN;
1256     }
1257
1258     EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
1259
1260     PUTBACK;    /* hv_iternext and hv_iterval might clobber stack_sp */
1261     while ((entry = hv_iternext(keys))) {
1262         SPAGAIN;
1263         if (dokeys)
1264             XPUSHs(hv_iterkeysv(entry));        /* won't clobber stack_sp */
1265         if (dovalues) {
1266             PUTBACK;
1267             tmpstr = realhv ?
1268                      hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry);
1269             DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
1270                             (unsigned long)HeHASH(entry),
1271                             HvMAX(keys)+1,
1272                             (unsigned long)(HeHASH(entry) & HvMAX(keys))));
1273             SPAGAIN;
1274             XPUSHs(tmpstr);
1275         }
1276         PUTBACK;
1277     }
1278     return NORMAL;
1279 }
1280