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