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