doop.c

   1 /*    doop.c
   2  *
   3  *    Copyright (c) 1991-2000, 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 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  19 #include <signal.h>
  20 #endif
  21
  22 STATIC I32
  23 S_do_trans_CC_simple(pTHX_ SV *sv)
  24 {
  25     dTHR;
  26     U8 *s;
  27     U8 *send;
  28     I32 matches = 0;
  29     STRLEN len;
  30     short *tbl;
  31     I32 ch;
  32
  33     tbl = (short*)cPVOP->op_pv;
  34     if (!tbl)
  35         Perl_croak(aTHX_ "panic: do_trans");
  36
  37     s = (U8*)SvPV(sv, len);
  38     send = s + len;
  39
  40     while (s < send) {
  41         if ((ch = tbl[*s]) >= 0) {
  42             matches++;
  43             *s = ch;
  44         }
  45         s++;
  46     }
  47     SvSETMAGIC(sv);
  48
  49     return matches;
  50 }
  51
  52 STATIC I32
  53 S_do_trans_CC_count(pTHX_ SV *sv)
  54 {
  55     dTHR;
  56     U8 *s;
  57     U8 *send;
  58     I32 matches = 0;
  59     STRLEN len;
  60     short *tbl;
  61
  62     tbl = (short*)cPVOP->op_pv;
  63     if (!tbl)
  64         Perl_croak(aTHX_ "panic: do_trans");
  65
  66     s = (U8*)SvPV(sv, len);
  67     send = s + len;
  68
  69     while (s < send) {
  70         if (tbl[*s] >= 0)
  71             matches++;
  72         s++;
  73     }
  74
  75     return matches;
  76 }
  77
  78 STATIC I32
  79 S_do_trans_CC_complex(pTHX_ SV *sv)
  80 {
  81     dTHR;
  82     U8 *s;
  83     U8 *send;
  84     U8 *d;
  85     I32 matches = 0;
  86     STRLEN len;
  87     short *tbl;
  88     I32 ch;
  89
  90     tbl = (short*)cPVOP->op_pv;
  91     if (!tbl)
  92         Perl_croak(aTHX_ "panic: do_trans");
  93
  94     s = (U8*)SvPV(sv, len);
  95     send = s + len;
  96
  97     d = s;
  98     if (PL_op->op_private & OPpTRANS_SQUASH) {
  99         U8* p = send;
 100
 101         while (s < send) {
 102             if ((ch = tbl[*s]) >= 0) {
 103                 *d = ch;
 104                 matches++;
 105                 if (p == d - 1 && *p == *d)
 106                     matches--;
 107                 else
 108                     p = d++;
 109             }
 110             else if (ch == -1)          /* -1 is unmapped character */
 111                 *d++ = *s;              /* -2 is delete character */
 112             s++;
 113         }
 114     }
 115     else {
 116         while (s < send) {
 117             if ((ch = tbl[*s]) >= 0) {
 118                 *d = ch;
 119                 matches++;
 120                 d++;
 121             }
 122             else if (ch == -1)          /* -1 is unmapped character */
 123                 *d++ = *s;              /* -2 is delete character */
 124             s++;
 125         }
 126     }
 127     matches += send - d;        /* account for disappeared chars */
 128     *d = '\0';
 129     SvCUR_set(sv, d - (U8*)SvPVX(sv));
 130     SvSETMAGIC(sv);
 131
 132     return matches;
 133 }
 134
 135 STATIC I32
 136 S_do_trans_UU_simple(pTHX_ SV *sv)
 137 {
 138     dTHR;
 139     U8 *s;
 140     U8 *send;
 141     U8 *d;
 142     I32 matches = 0;
 143     STRLEN len;
 144
 145     SV* rv = (SV*)cSVOP->op_sv;
 146     HV* hv = (HV*)SvRV(rv);
 147     SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
 148     UV none = svp ? SvUV(*svp) : 0x7fffffff;
 149     UV extra = none + 1;
 150     UV final;
 151     UV uv;
 152
 153     s = (U8*)SvPV(sv, len);
 154     send = s + len;
 155
 156     svp = hv_fetch(hv, "FINAL", 5, FALSE);
 157     if (svp)
 158         final = SvUV(*svp);
 159
 160     d = s;
 161     while (s < send) {
 162         if ((uv = swash_fetch(rv, s)) < none) {
 163             s += UTF8SKIP(s);
 164             matches++;
 165             d = uv_to_utf8(d, uv);
 166         }
 167         else if (uv == none) {
 168             int i;
 169             for (i = UTF8SKIP(s); i; i--)
 170                 *d++ = *s++;
 171         }
 172         else if (uv == extra) {
 173             s += UTF8SKIP(s);
 174             matches++;
 175             d = uv_to_utf8(d, final);
 176         }
 177         else
 178             s += UTF8SKIP(s);
 179     }
 180     *d = '\0';
 181     SvCUR_set(sv, d - (U8*)SvPVX(sv));
 182     SvSETMAGIC(sv);
 183
 184     return matches;
 185 }
 186
 187 STATIC I32
 188 S_do_trans_UU_count(pTHX_ SV *sv)
 189 {
 190     dTHR;
 191     U8 *s;
 192     U8 *send;
 193     I32 matches = 0;
 194     STRLEN len;
 195
 196     SV* rv = (SV*)cSVOP->op_sv;
 197     HV* hv = (HV*)SvRV(rv);
 198     SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
 199     UV none = svp ? SvUV(*svp) : 0x7fffffff;
 200     UV uv;
 201
 202     s = (U8*)SvPV(sv, len);
 203     send = s + len;
 204
 205     while (s < send) {
 206         if ((uv = swash_fetch(rv, s)) < none)
 207             matches++;
 208         s += UTF8SKIP(s);
 209     }
 210
 211     return matches;
 212 }
 213
 214 STATIC I32
 215 S_do_trans_UC_simple(pTHX_ SV *sv)
 216 {
 217     dTHR;
 218     U8 *s;
 219     U8 *send;
 220     U8 *d;
 221     I32 matches = 0;
 222     STRLEN len;
 223
 224     SV* rv = (SV*)cSVOP->op_sv;
 225     HV* hv = (HV*)SvRV(rv);
 226     SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
 227     UV none = svp ? SvUV(*svp) : 0x7fffffff;
 228     UV extra = none + 1;
 229     UV final;
 230     UV uv;
 231
 232     s = (U8*)SvPV(sv, len);
 233     send = s + len;
 234
 235     svp = hv_fetch(hv, "FINAL", 5, FALSE);
 236     if (svp)
 237         final = SvUV(*svp);
 238
 239     d = s;
 240     while (s < send) {
 241         if ((uv = swash_fetch(rv, s)) < none) {
 242             s += UTF8SKIP(s);
 243             matches++;
 244             *d++ = (U8)uv;
 245         }
 246         else if (uv == none) {
 247             I32 ulen;
 248             uv = utf8_to_uv(s, &ulen);
 249             s += ulen;
 250             *d++ = (U8)uv;
 251         }
 252         else if (uv == extra) {
 253             s += UTF8SKIP(s);
 254             matches++;
 255             *d++ = (U8)final;
 256         }
 257         else
 258             s += UTF8SKIP(s);
 259     }
 260     *d = '\0';
 261     SvCUR_set(sv, d - (U8*)SvPVX(sv));
 262     SvSETMAGIC(sv);
 263
 264     return matches;
 265 }
 266
 267 STATIC I32
 268 S_do_trans_CU_simple(pTHX_ SV *sv)
 269 {
 270     dTHR;
 271     U8 *s;
 272     U8 *send;
 273     U8 *d;
 274     U8 *dst;
 275     I32 matches = 0;
 276     STRLEN len;
 277
 278     SV* rv = (SV*)cSVOP->op_sv;
 279     HV* hv = (HV*)SvRV(rv);
 280     SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
 281     UV none = svp ? SvUV(*svp) : 0x7fffffff;
 282     UV extra = none + 1;
 283     UV final;
 284     UV uv;
 285     U8 tmpbuf[UTF8_MAXLEN];
 286     I32 bits = 16;
 287
 288     s = (U8*)SvPV(sv, len);
 289     send = s + len;
 290
 291     svp = hv_fetch(hv, "BITS", 4, FALSE);
 292     if (svp)
 293         bits = (I32)SvIV(*svp);
 294
 295     svp = hv_fetch(hv, "FINAL", 5, FALSE);
 296     if (svp)
 297         final = SvUV(*svp);
 298
 299     Newz(801, d, len * (bits >> 3) + 1, U8);
 300     dst = d;
 301
 302     while (s < send) {
 303         uv = *s++;
 304         if (uv < 0x80)
 305             tmpbuf[0] = uv;
 306         else {
 307             tmpbuf[0] = (( uv >>  6)         | 0xc0);
 308             tmpbuf[1] = (( uv        & 0x3f) | 0x80);
 309         }
 310
 311         if ((uv = swash_fetch(rv, tmpbuf)) < none) {
 312             matches++;
 313             d = uv_to_utf8(d, uv);
 314         }
 315         else if (uv == none)
 316             d = uv_to_utf8(d, s[-1]);
 317         else if (uv == extra) {
 318             matches++;
 319             d = uv_to_utf8(d, final);
 320         }
 321     }
 322     *d = '\0';
 323     sv_usepvn_mg(sv, (char*)dst, d - dst);
 324
 325     return matches;
 326 }
 327
 328 /* utf-8 to latin-1 */
 329
 330 STATIC I32
 331 S_do_trans_UC_trivial(pTHX_ SV *sv)
 332 {
 333     dTHR;
 334     U8 *s;
 335     U8 *send;
 336     U8 *d;
 337     STRLEN len;
 338
 339     s = (U8*)SvPV(sv, len);
 340     send = s + len;
 341
 342     d = s;
 343     while (s < send) {
 344         if (*s < 0x80)
 345             *d++ = *s++;
 346         else {
 347             I32 ulen;
 348             UV uv = utf8_to_uv(s, &ulen);
 349             s += ulen;
 350             *d++ = (U8)uv;
 351         }
 352     }
 353     *d = '\0';
 354     SvCUR_set(sv, d - (U8*)SvPVX(sv));
 355     SvSETMAGIC(sv);
 356
 357     return SvCUR(sv);
 358 }
 359
 360 /* latin-1 to utf-8 */
 361
 362 STATIC I32
 363 S_do_trans_CU_trivial(pTHX_ SV *sv)
 364 {
 365     dTHR;
 366     U8 *s;
 367     U8 *send;
 368     U8 *d;
 369     U8 *dst;
 370     I32 matches;
 371     STRLEN len;
 372
 373     s = (U8*)SvPV(sv, len);
 374     send = s + len;
 375
 376     Newz(801, d, len * 2 + 1, U8);
 377     dst = d;
 378
 379     matches = send - s;
 380
 381     while (s < send) {
 382         if (*s < 0x80)
 383             *d++ = *s++;
 384         else {
 385             UV uv = *s++;
 386             *d++ = (( uv >>  6)         | 0xc0);
 387             *d++ = (( uv        & 0x3f) | 0x80);
 388         }
 389     }
 390     *d = '\0';
 391     sv_usepvn_mg(sv, (char*)dst, d - dst);
 392
 393     return matches;
 394 }
 395
 396 STATIC I32
 397 S_do_trans_UU_complex(pTHX_ SV *sv)
 398 {
 399     dTHR;
 400     U8 *s;
 401     U8 *send;
 402     U8 *d;
 403     I32 matches = 0;
 404     I32 squash   = PL_op->op_private & OPpTRANS_SQUASH;
 405     I32 from_utf = PL_op->op_private & OPpTRANS_FROM_UTF;
 406     I32 to_utf   = PL_op->op_private & OPpTRANS_TO_UTF;
 407     I32 del      = PL_op->op_private & OPpTRANS_DELETE;
 408     SV* rv = (SV*)cSVOP->op_sv;
 409     HV* hv = (HV*)SvRV(rv);
 410     SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
 411     UV none = svp ? SvUV(*svp) : 0x7fffffff;
 412     UV extra = none + 1;
 413     UV final;
 414     UV uv;
 415     STRLEN len;
 416     U8 *dst;
 417
 418     s = (U8*)SvPV(sv, len);
 419     send = s + len;
 420
 421     svp = hv_fetch(hv, "FINAL", 5, FALSE);
 422     if (svp)
 423         final = SvUV(*svp);
 424
 425     if (PL_op->op_private & OPpTRANS_GROWS) {
 426         I32 bits = 16;
 427
 428         svp = hv_fetch(hv, "BITS", 4, FALSE);
 429         if (svp)
 430             bits = (I32)SvIV(*svp);
 431
 432         Newz(801, d, len * (bits >> 3) + 1, U8);
 433         dst = d;
 434     }
 435     else {
 436         d = s;
 437         dst = 0;
 438     }
 439
 440     if (squash) {
 441         UV puv = 0xfeedface;
 442         while (s < send) {
 443             if (from_utf) {
 444                 uv = swash_fetch(rv, s);
 445             }
 446             else {
 447                 U8 tmpbuf[2];
 448                 uv = *s++;
 449                 if (uv < 0x80)
 450                     tmpbuf[0] = uv;
 451                 else {
 452                     tmpbuf[0] = (( uv >>  6)         | 0xc0);
 453                     tmpbuf[1] = (( uv        & 0x3f) | 0x80);
 454                 }
 455                 uv = swash_fetch(rv, tmpbuf);
 456             }
 457             if (uv < none) {
 458                 matches++;
 459                 if (uv != puv) {
 460                     if (uv >= 0x80 && to_utf)
 461                         d = uv_to_utf8(d, uv);
 462                     else
 463                         *d++ = (U8)uv;
 464                     puv = uv;
 465                 }
 466                 if (from_utf)
 467                     s += UTF8SKIP(s);
 468                 continue;
 469             }
 470             else if (uv == none) {      /* "none" is unmapped character */
 471                 if (from_utf) {
 472                     if (*s < 0x80)
 473                         *d++ = *s++;
 474                     else if (to_utf) {
 475                         int i;
 476                         for (i = UTF8SKIP(s); i; --i)
 477                             *d++ = *s++;
 478                     }
 479                     else {
 480                         I32 ulen;
 481                         *d++ = (U8)utf8_to_uv(s, &ulen);
 482                         s += ulen;
 483                     }
 484                 }
 485                 else {  /* must be to_utf only */
 486                     d = uv_to_utf8(d, s[-1]);
 487                 }
 488                 puv = 0xfeedface;
 489                 continue;
 490             }
 491             else if (uv == extra && !del) {
 492                 matches++;
 493                 if (uv != puv) {
 494                     if (final >= 0x80 && to_utf)
 495                         d = uv_to_utf8(d, final);
 496                     else
 497                         *d++ = (U8)final;
 498                     puv = final;
 499                 }
 500                 if (from_utf)
 501                     s += UTF8SKIP(s);
 502                 continue;
 503             }
 504             matches++;          /* "none+1" is delete character */
 505             if (from_utf)
 506                 s += UTF8SKIP(s);
 507         }
 508     }
 509     else {
 510         while (s < send) {
 511             if (from_utf) {
 512                 uv = swash_fetch(rv, s);
 513             }
 514             else {
 515                 U8 tmpbuf[2];
 516                 uv = *s++;
 517                 if (uv < 0x80)
 518                     tmpbuf[0] = uv;
 519                 else {
 520                     tmpbuf[0] = (( uv >>  6)         | 0xc0);
 521                     tmpbuf[1] = (( uv        & 0x3f) | 0x80);
 522                 }
 523                 uv = swash_fetch(rv, tmpbuf);
 524             }
 525             if (uv < none) {
 526                 matches++;
 527                 if (uv >= 0x80 && to_utf)
 528                     d = uv_to_utf8(d, uv);
 529                 else
 530                     *d++ = (U8)uv;
 531                 if (from_utf)
 532                     s += UTF8SKIP(s);
 533                 continue;
 534             }
 535             else if (uv == none) {      /* "none" is unmapped character */
 536                 if (from_utf) {
 537                     if (*s < 0x80)
 538                         *d++ = *s++;
 539                     else if (to_utf) {
 540                         int i;
 541                         for (i = UTF8SKIP(s); i; --i)
 542                             *d++ = *s++;
 543                     }
 544                     else {
 545                         I32 ulen;
 546                         *d++ = (U8)utf8_to_uv(s, &ulen);
 547                         s += ulen;
 548                     }
 549                 }
 550                 else {  /* must be to_utf only */
 551                     d = uv_to_utf8(d, s[-1]);
 552                 }
 553                 continue;
 554             }
 555             else if (uv == extra && !del) {
 556                 matches++;
 557                 if (final >= 0x80 && to_utf)
 558                     d = uv_to_utf8(d, final);
 559                 else
 560                     *d++ = (U8)final;
 561                 if (from_utf)
 562                     s += UTF8SKIP(s);
 563                 continue;
 564             }
 565             matches++;          /* "none+1" is delete character */
 566             if (from_utf)
 567                 s += UTF8SKIP(s);
 568         }
 569     }
 570     if (dst)
 571         sv_usepvn(sv, (char*)dst, d - dst);
 572     else {
 573         *d = '\0';
 574         SvCUR_set(sv, d - (U8*)SvPVX(sv));
 575     }
 576     SvSETMAGIC(sv);
 577
 578     return matches;
 579 }
 580
 581 I32
 582 Perl_do_trans(pTHX_ SV *sv)
 583 {
 584     dTHR;
 585     STRLEN len;
 586
 587     if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
 588         Perl_croak(aTHX_ PL_no_modify);
 589
 590     (void)SvPV(sv, len);
 591     if (!len)
 592         return 0;
 593     if (!SvPOKp(sv))
 594         (void)SvPV_force(sv, len);
 595     if (!(PL_op->op_private & OPpTRANS_IDENTICAL))
 596         (void)SvPOK_only_UTF8(sv);
 597
 598     DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
 599
 600     switch (PL_op->op_private & 63) {
 601     case 0:
 602         return do_trans_CC_simple(sv);
 603
 604     case OPpTRANS_FROM_UTF:
 605         return do_trans_UC_simple(sv);
 606
 607     case OPpTRANS_TO_UTF:
 608         return do_trans_CU_simple(sv);
 609
 610     case OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF:
 611         return do_trans_UU_simple(sv);
 612
 613     case OPpTRANS_IDENTICAL:
 614         return do_trans_CC_count(sv);
 615
 616     case OPpTRANS_FROM_UTF|OPpTRANS_IDENTICAL:
 617         return do_trans_UC_trivial(sv);
 618
 619     case OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL:
 620         return do_trans_CU_trivial(sv);
 621
 622     case OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL:
 623         return do_trans_UU_count(sv);
 624
 625     default:
 626         if (PL_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
 627             return do_trans_UU_complex(sv); /* could be UC or CU too */
 628         else
 629             return do_trans_CC_complex(sv);
 630     }
 631 }
 632
 633 void
 634 Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **sp)
 635 {
 636     SV **oldmark = mark;
 637     register I32 items = sp - mark;
 638     register STRLEN len;
 639     STRLEN delimlen;
 640     register char *delim = SvPV(del, delimlen);
 641     STRLEN tmplen;
 642
 643     mark++;
 644     len = (items > 0 ? (delimlen * (items - 1) ) : 0);
 645     (void)SvUPGRADE(sv, SVt_PV);
 646     if (SvLEN(sv) < len + items) {      /* current length is way too short */
 647         while (items-- > 0) {
 648             if (*mark && !SvGMAGICAL(*mark) && SvOK(*mark)) {
 649                 SvPV(*mark, tmplen);
 650                 len += tmplen;
 651             }
 652             mark++;
 653         }
 654         SvGROW(sv, len + 1);            /* so try to pre-extend */
 655
 656         mark = oldmark;
 657         items = sp - mark;
 658         ++mark;
 659     }
 660
 661     if (items-- > 0) {
 662         char *s;
 663
 664         sv_setpv(sv, "");
 665         if (*mark)
 666             sv_catsv(sv, *mark);
 667         mark++;
 668     }
 669     else
 670         sv_setpv(sv,"");
 671     len = delimlen;
 672     if (len) {
 673         for (; items > 0; items--,mark++) {
 674             sv_catpvn(sv,delim,len);
 675             sv_catsv(sv,*mark);
 676         }
 677     }
 678     else {
 679         for (; items > 0; items--,mark++)
 680             sv_catsv(sv,*mark);
 681     }
 682     SvSETMAGIC(sv);
 683 }
 684
 685 void
 686 Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
 687 {
 688     STRLEN patlen;
 689     char *pat = SvPV(*sarg, patlen);
 690     bool do_taint = FALSE;
 691
 692     sv_vsetpvfn(sv, pat, patlen, Null(va_list*), sarg + 1, len - 1, &do_taint);
 693     SvSETMAGIC(sv);
 694     if (do_taint)
 695         SvTAINTED_on(sv);
 696 }
 697
 698 /* XXX SvUTF8 support missing! */
 699 UV
 700 Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
 701 {
 702     STRLEN srclen, len;
 703     unsigned char *s = (unsigned char *) SvPV(sv, srclen);
 704     UV retnum = 0;
 705
 706     if (offset < 0)
 707         return retnum;
 708     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
 709         Perl_croak(aTHX_ "Illegal number of bits in vec");
 710     offset *= size;     /* turn into bit offset */
 711     len = (offset + size + 7) / 8;      /* required number of bytes */
 712     if (len > srclen) {
 713         if (size <= 8)
 714             retnum = 0;
 715         else {
 716             offset >>= 3;       /* turn into byte offset */
 717             if (size == 16) {
 718                 if (offset >= srclen)
 719                     retnum = 0;
 720                 else
 721                     retnum = (UV) s[offset] <<  8;
 722             }
 723             else if (size == 32) {
 724                 if (offset >= srclen)
 725                     retnum = 0;
 726                 else if (offset + 1 >= srclen)
 727                     retnum =
 728                         ((UV) s[offset    ] << 24);
 729                 else if (offset + 2 >= srclen)
 730                     retnum =
 731                         ((UV) s[offset    ] << 24) +
 732                         ((UV) s[offset + 1] << 16);
 733                 else
 734                     retnum =
 735                         ((UV) s[offset    ] << 24) +
 736                         ((UV) s[offset + 1] << 16) +
 737                         (     s[offset + 2] <<  8);
 738             }
 739 #ifdef UV_IS_QUAD
 740             else if (size == 64) {
 741                 dTHR;
 742                 if (ckWARN(WARN_PORTABLE))
 743                     Perl_warner(aTHX_ WARN_PORTABLE,
 744                                 "Bit vector size > 32 non-portable");
 745                 if (offset >= srclen)
 746                     retnum = 0;
 747                 else if (offset + 1 >= srclen)
 748                     retnum =
 749                         (UV) s[offset     ] << 56;
 750                 else if (offset + 2 >= srclen)
 751                     retnum =
 752                         ((UV) s[offset    ] << 56) +
 753                         ((UV) s[offset + 1] << 48);
 754                 else if (offset + 3 >= srclen)
 755                     retnum =
 756                         ((UV) s[offset    ] << 56) +
 757                         ((UV) s[offset + 1] << 48) +
 758                         ((UV) s[offset + 2] << 40);
 759                 else if (offset + 4 >= srclen)
 760                     retnum =
 761                         ((UV) s[offset    ] << 56) +
 762                         ((UV) s[offset + 1] << 48) +
 763                         ((UV) s[offset + 2] << 40) +
 764                         ((UV) s[offset + 3] << 32);
 765                 else if (offset + 5 >= srclen)
 766                     retnum =
 767                         ((UV) s[offset    ] << 56) +
 768                         ((UV) s[offset + 1] << 48) +
 769                         ((UV) s[offset + 2] << 40) +
 770                         ((UV) s[offset + 3] << 32) +
 771                         (     s[offset + 4] << 24);
 772                 else if (offset + 6 >= srclen)
 773                     retnum =
 774                         ((UV) s[offset    ] << 56) +
 775                         ((UV) s[offset + 1] << 48) +
 776                         ((UV) s[offset + 2] << 40) +
 777                         ((UV) s[offset + 3] << 32) +
 778                         ((UV) s[offset + 4] << 24) +
 779                         ((UV) s[offset + 5] << 16);
 780                 else
 781                     retnum =
 782                         ((UV) s[offset    ] << 56) +
 783                         ((UV) s[offset + 1] << 48) +
 784                         ((UV) s[offset + 2] << 40) +
 785                         ((UV) s[offset + 3] << 32) +
 786                         ((UV) s[offset + 4] << 24) +
 787                         ((UV) s[offset + 5] << 16) +
 788                         (     s[offset + 6] <<  8);
 789             }
 790 #endif
 791         }
 792     }
 793     else if (size < 8)
 794         retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
 795     else {
 796         offset >>= 3;   /* turn into byte offset */
 797         if (size == 8)
 798             retnum = s[offset];
 799         else if (size == 16)
 800             retnum =
 801                 ((UV) s[offset] <<      8) +
 802                       s[offset + 1];
 803         else if (size == 32)
 804             retnum =
 805                 ((UV) s[offset    ] << 24) +
 806                 ((UV) s[offset + 1] << 16) +
 807                 (     s[offset + 2] <<  8) +
 808                       s[offset + 3];
 809 #ifdef UV_IS_QUAD
 810         else if (size == 64) {
 811             dTHR;
 812             if (ckWARN(WARN_PORTABLE))
 813                 Perl_warner(aTHX_ WARN_PORTABLE,
 814                             "Bit vector size > 32 non-portable");
 815             retnum =
 816                 ((UV) s[offset    ] << 56) +
 817                 ((UV) s[offset + 1] << 48) +
 818                 ((UV) s[offset + 2] << 40) +
 819                 ((UV) s[offset + 3] << 32) +
 820                 ((UV) s[offset + 4] << 24) +
 821                 ((UV) s[offset + 5] << 16) +
 822                 (     s[offset + 6] <<  8) +
 823                       s[offset + 7];
 824         }
 825 #endif
 826     }
 827
 828     return retnum;
 829 }
 830
 831 /* XXX SvUTF8 support missing! */
 832 void
 833 Perl_do_vecset(pTHX_ SV *sv)
 834 {
 835     SV *targ = LvTARG(sv);
 836     register I32 offset;
 837     register I32 size;
 838     register unsigned char *s;
 839     register UV lval;
 840     I32 mask;
 841     STRLEN targlen;
 842     STRLEN len;
 843
 844     if (!targ)
 845         return;
 846     s = (unsigned char*)SvPV_force(targ, targlen);
 847     (void)SvPOK_only(targ);
 848     lval = SvUV(sv);
 849     offset = LvTARGOFF(sv);
 850     size = LvTARGLEN(sv);
 851     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
 852         Perl_croak(aTHX_ "Illegal number of bits in vec");
 853
 854     offset *= size;                     /* turn into bit offset */
 855     len = (offset + size + 7) / 8;      /* required number of bytes */
 856     if (len > targlen) {
 857         s = (unsigned char*)SvGROW(targ, len + 1);
 858         (void)memzero(s + targlen, len - targlen + 1);
 859         SvCUR_set(targ, len);
 860     }
 861
 862     if (size < 8) {
 863         mask = (1 << size) - 1;
 864         size = offset & 7;
 865         lval &= mask;
 866         offset >>= 3;                   /* turn into byte offset */
 867         s[offset] &= ~(mask << size);
 868         s[offset] |= lval << size;
 869     }
 870     else {
 871         offset >>= 3;                   /* turn into byte offset */
 872         if (size == 8)
 873             s[offset  ] = lval         & 0xff;
 874         else if (size == 16) {
 875             s[offset  ] = (lval >>  8) & 0xff;
 876             s[offset+1] = lval         & 0xff;
 877         }
 878         else if (size == 32) {
 879             s[offset  ] = (lval >> 24) & 0xff;
 880             s[offset+1] = (lval >> 16) & 0xff;
 881             s[offset+2] = (lval >>  8) & 0xff;
 882             s[offset+3] =  lval        & 0xff;
 883         }
 884 #ifdef UV_IS_QUAD
 885         else if (size == 64) {
 886             dTHR;
 887             if (ckWARN(WARN_PORTABLE))
 888                 Perl_warner(aTHX_ WARN_PORTABLE,
 889                             "Bit vector size > 32 non-portable");
 890             s[offset  ] = (lval >> 56) & 0xff;
 891             s[offset+1] = (lval >> 48) & 0xff;
 892             s[offset+2] = (lval >> 40) & 0xff;
 893             s[offset+3] = (lval >> 32) & 0xff;
 894             s[offset+4] = (lval >> 24) & 0xff;
 895             s[offset+5] = (lval >> 16) & 0xff;
 896             s[offset+6] = (lval >>  8) & 0xff;
 897             s[offset+7] =  lval        & 0xff;
 898         }
 899 #endif
 900     }
 901     SvSETMAGIC(targ);
 902 }
 903
 904 void
 905 Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
 906 {
 907     STRLEN len;
 908     char *s;
 909     dTHR;
 910
 911     if (SvTYPE(sv) == SVt_PVAV) {
 912         register I32 i;
 913         I32 max;
 914         AV* av = (AV*)sv;
 915         max = AvFILL(av);
 916         for (i = 0; i <= max; i++) {
 917             sv = (SV*)av_fetch(av, i, FALSE);
 918             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
 919                 do_chop(astr, sv);
 920         }
 921         return;
 922     }
 923     else if (SvTYPE(sv) == SVt_PVHV) {
 924         HV* hv = (HV*)sv;
 925         HE* entry;
 926         (void)hv_iterinit(hv);
 927         /*SUPPRESS 560*/
 928         while ((entry = hv_iternext(hv)))
 929             do_chop(astr,hv_iterval(hv,entry));
 930         return;
 931     }
 932     else if (SvREADONLY(sv))
 933         Perl_croak(aTHX_ PL_no_modify);
 934     s = SvPV(sv, len);
 935     if (len && !SvPOK(sv))
 936         s = SvPV_force(sv, len);
 937     if (DO_UTF8(sv)) {
 938         if (s && len) {
 939             char *send = s + len;
 940             char *start = s;
 941             s = send - 1;
 942             while ((*s & 0xc0) == 0x80)
 943                 --s;
 944             if (UTF8SKIP(s) != send - s && ckWARN_d(WARN_UTF8))
 945                 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
 946             sv_setpvn(astr, s, send - s);
 947             *s = '\0';
 948             SvCUR_set(sv, s - start);
 949             SvNIOK_off(sv);
 950             SvUTF8_on(astr);
 951         }
 952         else
 953             sv_setpvn(astr, "", 0);
 954     }
 955     else if (s && len) {
 956         s += --len;
 957         sv_setpvn(astr, s, 1);
 958         *s = '\0';
 959         SvCUR_set(sv, len);
 960         SvUTF8_off(sv);
 961         SvNIOK_off(sv);
 962     }
 963     else
 964         sv_setpvn(astr, "", 0);
 965     SvSETMAGIC(sv);
 966 }
 967
 968 I32
 969 Perl_do_chomp(pTHX_ register SV *sv)
 970 {
 971     dTHR;
 972     register I32 count;
 973     STRLEN len;
 974     char *s;
 975
 976     if (RsSNARF(PL_rs))
 977         return 0;
 978     if (RsRECORD(PL_rs))
 979       return 0;
 980     count = 0;
 981     if (SvTYPE(sv) == SVt_PVAV) {
 982         register I32 i;
 983         I32 max;
 984         AV* av = (AV*)sv;
 985         max = AvFILL(av);
 986         for (i = 0; i <= max; i++) {
 987             sv = (SV*)av_fetch(av, i, FALSE);
 988             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
 989                 count += do_chomp(sv);
 990         }
 991         return count;
 992     }
 993     else if (SvTYPE(sv) == SVt_PVHV) {
 994         HV* hv = (HV*)sv;
 995         HE* entry;
 996         (void)hv_iterinit(hv);
 997         /*SUPPRESS 560*/
 998         while ((entry = hv_iternext(hv)))
 999             count += do_chomp(hv_iterval(hv,entry));
1000         return count;
1001     }
1002     else if (SvREADONLY(sv))
1003         Perl_croak(aTHX_ PL_no_modify);
1004     s = SvPV(sv, len);
1005     if (len && !SvPOKp(sv))
1006         s = SvPV_force(sv, len);
1007     if (s && len) {
1008         s += --len;
1009         if (RsPARA(PL_rs)) {
1010             if (*s != '\n')
1011                 goto nope;
1012             ++count;
1013             while (len && s[-1] == '\n') {
1014                 --len;
1015                 --s;
1016                 ++count;
1017             }
1018         }
1019         else {
1020             STRLEN rslen;
1021             char *rsptr = SvPV(PL_rs, rslen);
1022             if (rslen == 1) {
1023                 if (*s != *rsptr)
1024                     goto nope;
1025                 ++count;
1026             }
1027             else {
1028                 if (len < rslen - 1)
1029                     goto nope;
1030                 len -= rslen - 1;
1031                 s -= rslen - 1;
1032                 if (memNE(s, rsptr, rslen))
1033                     goto nope;
1034                 count += rslen;
1035             }
1036         }
1037         *s = '\0';
1038         SvCUR_set(sv, len);
1039         SvNIOK_off(sv);
1040     }
1041   nope:
1042     SvSETMAGIC(sv);
1043     return count;
1044 }
1045
1046 void
1047 Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
1048 {
1049     dTHR;       /* just for taint */
1050 #ifdef LIBERAL
1051     register long *dl;
1052     register long *ll;
1053     register long *rl;
1054 #endif
1055     register char *dc;
1056     STRLEN leftlen;
1057     STRLEN rightlen;
1058     register char *lc;
1059     register char *rc;
1060     register I32 len;
1061     I32 lensave;
1062     char *lsave;
1063     char *rsave;
1064     bool left_utf = DO_UTF8(left);
1065     bool right_utf = DO_UTF8(right);
1066
1067     if (left_utf && !right_utf)
1068         sv_utf8_upgrade(right);
1069     if (!left_utf && right_utf)
1070         sv_utf8_upgrade(left);
1071
1072     if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
1073         sv_setpvn(sv, "", 0);   /* avoid undef warning on |= and ^= */
1074     lsave = lc = SvPV(left, leftlen);
1075     rsave = rc = SvPV(right, rightlen);
1076     len = leftlen < rightlen ? leftlen : rightlen;
1077     lensave = len;
1078     if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
1079         STRLEN n_a;
1080         dc = SvPV_force(sv, n_a);
1081         if (SvCUR(sv) < len) {
1082             dc = SvGROW(sv, len + 1);
1083             (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
1084         }
1085     }
1086     else {
1087         I32 needlen = ((optype == OP_BIT_AND)
1088                         ? len : (leftlen > rightlen ? leftlen : rightlen));
1089         Newz(801, dc, needlen + 1, char);
1090         (void)sv_usepvn(sv, dc, needlen);
1091         dc = SvPVX(sv);         /* sv_usepvn() calls Renew() */
1092     }
1093     SvCUR_set(sv, len);
1094     (void)SvPOK_only(sv);
1095     if (left_utf || right_utf) {
1096         UV duc, luc, ruc;
1097         STRLEN lulen = leftlen;
1098         STRLEN rulen = rightlen;
1099         STRLEN dulen = 0;
1100         I32 ulen;
1101
1102         if (optype != OP_BIT_AND)
1103             dc = SvGROW(sv, leftlen+rightlen+1);
1104
1105         switch (optype) {
1106         case OP_BIT_AND:
1107             while (lulen && rulen) {
1108                 luc = utf8_to_uv((U8*)lc, &ulen);
1109                 lc += ulen;
1110                 lulen -= ulen;
1111                 ruc = utf8_to_uv((U8*)rc, &ulen);
1112                 rc += ulen;
1113                 rulen -= ulen;
1114                 duc = luc & ruc;
1115                 dc = (char*)uv_to_utf8((U8*)dc, duc);
1116             }
1117             dulen = dc - SvPVX(sv);
1118             SvCUR_set(sv, dulen);
1119             break;
1120         case OP_BIT_XOR:
1121             while (lulen && rulen) {
1122                 luc = utf8_to_uv((U8*)lc, &ulen);
1123                 lc += ulen;
1124                 lulen -= ulen;
1125                 ruc = utf8_to_uv((U8*)rc, &ulen);
1126                 rc += ulen;
1127                 rulen -= ulen;
1128                 duc = luc ^ ruc;
1129                 dc = (char*)uv_to_utf8((U8*)dc, duc);
1130             }
1131             goto mop_up_utf;
1132         case OP_BIT_OR:
1133             while (lulen && rulen) {
1134                 luc = utf8_to_uv((U8*)lc, &ulen);
1135                 lc += ulen;
1136                 lulen -= ulen;
1137                 ruc = utf8_to_uv((U8*)rc, &ulen);
1138                 rc += ulen;
1139                 rulen -= ulen;
1140                 duc = luc | ruc;
1141                 dc = (char*)uv_to_utf8((U8*)dc, duc);
1142             }
1143           mop_up_utf:
1144             dulen = dc - SvPVX(sv);
1145             SvCUR_set(sv, dulen);
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     djSP;
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) {        /* 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) {        /* 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