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