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");
  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");
 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");
 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         char *s;
 508
 509         sv_setpv(sv, "");
 510         if (*mark)
 511             sv_catsv(sv, *mark);
 512         mark++;
 513     }
 514     else
 515         sv_setpv(sv,"");
 516     len = delimlen;
 517     if (len) {
 518         for (; items > 0; items--,mark++) {
 519             sv_catpvn(sv,delim,len);
 520             sv_catsv(sv,*mark);
 521         }
 522     }
 523     else {
 524         for (; items > 0; items--,mark++)
 525             sv_catsv(sv,*mark);
 526     }
 527     SvSETMAGIC(sv);
 528 }
 529
 530 void
 531 Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
 532 {
 533     STRLEN patlen;
 534     char *pat = SvPV(*sarg, patlen);
 535     bool do_taint = FALSE;
 536
 537     sv_vsetpvfn(sv, pat, patlen, Null(va_list*), sarg + 1, len - 1, &do_taint);
 538     SvSETMAGIC(sv);
 539     if (do_taint)
 540         SvTAINTED_on(sv);
 541 }
 542
 543 /* currently converts input to bytes if possible, but doesn't sweat failure */
 544 UV
 545 Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
 546 {
 547     STRLEN srclen, len;
 548     unsigned char *s = (unsigned char *) SvPV(sv, srclen);
 549     UV retnum = 0;
 550
 551     if (offset < 0)
 552         return retnum;
 553     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
 554         Perl_croak(aTHX_ "Illegal number of bits in vec");
 555
 556     if (SvUTF8(sv))
 557         (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE);
 558
 559     offset *= size;     /* turn into bit offset */
 560     len = (offset + size + 7) / 8;      /* required number of bytes */
 561     if (len > srclen) {
 562         if (size <= 8)
 563             retnum = 0;
 564         else {
 565             offset >>= 3;       /* turn into byte offset */
 566             if (size == 16) {
 567                 if (offset >= srclen)
 568                     retnum = 0;
 569                 else
 570                     retnum = (UV) s[offset] <<  8;
 571             }
 572             else if (size == 32) {
 573                 if (offset >= srclen)
 574                     retnum = 0;
 575                 else if (offset + 1 >= srclen)
 576                     retnum =
 577                         ((UV) s[offset    ] << 24);
 578                 else if (offset + 2 >= srclen)
 579                     retnum =
 580                         ((UV) s[offset    ] << 24) +
 581                         ((UV) s[offset + 1] << 16);
 582                 else
 583                     retnum =
 584                         ((UV) s[offset    ] << 24) +
 585                         ((UV) s[offset + 1] << 16) +
 586                         (     s[offset + 2] <<  8);
 587             }
 588 #ifdef UV_IS_QUAD
 589             else if (size == 64) {
 590                 if (ckWARN(WARN_PORTABLE))
 591                     Perl_warner(aTHX_ WARN_PORTABLE,
 592                                 "Bit vector size > 32 non-portable");
 593                 if (offset >= srclen)
 594                     retnum = 0;
 595                 else if (offset + 1 >= srclen)
 596                     retnum =
 597                         (UV) s[offset     ] << 56;
 598                 else if (offset + 2 >= srclen)
 599                     retnum =
 600                         ((UV) s[offset    ] << 56) +
 601                         ((UV) s[offset + 1] << 48);
 602                 else if (offset + 3 >= srclen)
 603                     retnum =
 604                         ((UV) s[offset    ] << 56) +
 605                         ((UV) s[offset + 1] << 48) +
 606                         ((UV) s[offset + 2] << 40);
 607                 else if (offset + 4 >= srclen)
 608                     retnum =
 609                         ((UV) s[offset    ] << 56) +
 610                         ((UV) s[offset + 1] << 48) +
 611                         ((UV) s[offset + 2] << 40) +
 612                         ((UV) s[offset + 3] << 32);
 613                 else if (offset + 5 >= srclen)
 614                     retnum =
 615                         ((UV) s[offset    ] << 56) +
 616                         ((UV) s[offset + 1] << 48) +
 617                         ((UV) s[offset + 2] << 40) +
 618                         ((UV) s[offset + 3] << 32) +
 619                         (     s[offset + 4] << 24);
 620                 else if (offset + 6 >= srclen)
 621                     retnum =
 622                         ((UV) s[offset    ] << 56) +
 623                         ((UV) s[offset + 1] << 48) +
 624                         ((UV) s[offset + 2] << 40) +
 625                         ((UV) s[offset + 3] << 32) +
 626                         ((UV) s[offset + 4] << 24) +
 627                         ((UV) s[offset + 5] << 16);
 628                 else
 629                     retnum =
 630                         ((UV) s[offset    ] << 56) +
 631                         ((UV) s[offset + 1] << 48) +
 632                         ((UV) s[offset + 2] << 40) +
 633                         ((UV) s[offset + 3] << 32) +
 634                         ((UV) s[offset + 4] << 24) +
 635                         ((UV) s[offset + 5] << 16) +
 636                         (     s[offset + 6] <<  8);
 637             }
 638 #endif
 639         }
 640     }
 641     else if (size < 8)
 642         retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
 643     else {
 644         offset >>= 3;   /* turn into byte offset */
 645         if (size == 8)
 646             retnum = s[offset];
 647         else if (size == 16)
 648             retnum =
 649                 ((UV) s[offset] <<      8) +
 650                       s[offset + 1];
 651         else if (size == 32)
 652             retnum =
 653                 ((UV) s[offset    ] << 24) +
 654                 ((UV) s[offset + 1] << 16) +
 655                 (     s[offset + 2] <<  8) +
 656                       s[offset + 3];
 657 #ifdef UV_IS_QUAD
 658         else if (size == 64) {
 659             if (ckWARN(WARN_PORTABLE))
 660                 Perl_warner(aTHX_ WARN_PORTABLE,
 661                             "Bit vector size > 32 non-portable");
 662             retnum =
 663                 ((UV) s[offset    ] << 56) +
 664                 ((UV) s[offset + 1] << 48) +
 665                 ((UV) s[offset + 2] << 40) +
 666                 ((UV) s[offset + 3] << 32) +
 667                 ((UV) s[offset + 4] << 24) +
 668                 ((UV) s[offset + 5] << 16) +
 669                 (     s[offset + 6] <<  8) +
 670                       s[offset + 7];
 671         }
 672 #endif
 673     }
 674
 675     return retnum;
 676 }
 677
 678 /* currently converts input to bytes if possible but doesn't sweat failures,
 679  * although it does ensure that the string it clobbers is not marked as
 680  * utf8-valid any more
 681  */
 682 void
 683 Perl_do_vecset(pTHX_ SV *sv)
 684 {
 685     SV *targ = LvTARG(sv);
 686     register I32 offset;
 687     register I32 size;
 688     register unsigned char *s;
 689     register UV lval;
 690     I32 mask;
 691     STRLEN targlen;
 692     STRLEN len;
 693
 694     if (!targ)
 695         return;
 696     s = (unsigned char*)SvPV_force(targ, targlen);
 697     if (SvUTF8(targ)) {
 698         /* This is handled by the SvPOK_only below...
 699         if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
 700             SvUTF8_off(targ);
 701          */
 702         (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
 703     }
 704
 705     (void)SvPOK_only(targ);
 706     lval = SvUV(sv);
 707     offset = LvTARGOFF(sv);
 708     if (offset < 0)
 709         Perl_croak(aTHX_ "Assigning to negative offset in vec");
 710     size = LvTARGLEN(sv);
 711     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
 712         Perl_croak(aTHX_ "Illegal number of bits in vec");
 713
 714     offset *= size;                     /* turn into bit offset */
 715     len = (offset + size + 7) / 8;      /* required number of bytes */
 716     if (len > targlen) {
 717         s = (unsigned char*)SvGROW(targ, len + 1);
 718         (void)memzero((char *)(s + targlen), len - targlen + 1);
 719         SvCUR_set(targ, len);
 720     }
 721
 722     if (size < 8) {
 723         mask = (1 << size) - 1;
 724         size = offset & 7;
 725         lval &= mask;
 726         offset >>= 3;                   /* turn into byte offset */
 727         s[offset] &= ~(mask << size);
 728         s[offset] |= lval << size;
 729     }
 730     else {
 731         offset >>= 3;                   /* turn into byte offset */
 732         if (size == 8)
 733             s[offset  ] = lval         & 0xff;
 734         else if (size == 16) {
 735             s[offset  ] = (lval >>  8) & 0xff;
 736             s[offset+1] = lval         & 0xff;
 737         }
 738         else if (size == 32) {
 739             s[offset  ] = (lval >> 24) & 0xff;
 740             s[offset+1] = (lval >> 16) & 0xff;
 741             s[offset+2] = (lval >>  8) & 0xff;
 742             s[offset+3] =  lval        & 0xff;
 743         }
 744 #ifdef UV_IS_QUAD
 745         else if (size == 64) {
 746             if (ckWARN(WARN_PORTABLE))
 747                 Perl_warner(aTHX_ WARN_PORTABLE,
 748                             "Bit vector size > 32 non-portable");
 749             s[offset  ] = (lval >> 56) & 0xff;
 750             s[offset+1] = (lval >> 48) & 0xff;
 751             s[offset+2] = (lval >> 40) & 0xff;
 752             s[offset+3] = (lval >> 32) & 0xff;
 753             s[offset+4] = (lval >> 24) & 0xff;
 754             s[offset+5] = (lval >> 16) & 0xff;
 755             s[offset+6] = (lval >>  8) & 0xff;
 756             s[offset+7] =  lval        & 0xff;
 757         }
 758 #endif
 759     }
 760     SvSETMAGIC(targ);
 761 }
 762
 763 void
 764 Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
 765 {
 766     STRLEN len;
 767     char *s;
 768
 769     if (SvTYPE(sv) == SVt_PVAV) {
 770         register I32 i;
 771         I32 max;
 772         AV* av = (AV*)sv;
 773         max = AvFILL(av);
 774         for (i = 0; i <= max; i++) {
 775             sv = (SV*)av_fetch(av, i, FALSE);
 776             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
 777                 do_chop(astr, sv);
 778         }
 779         return;
 780     }
 781     else if (SvTYPE(sv) == SVt_PVHV) {
 782         HV* hv = (HV*)sv;
 783         HE* entry;
 784         (void)hv_iterinit(hv);
 785         /*SUPPRESS 560*/
 786         while ((entry = hv_iternext(hv)))
 787             do_chop(astr,hv_iterval(hv,entry));
 788         return;
 789     }
 790     else if (SvREADONLY(sv))
 791         Perl_croak(aTHX_ PL_no_modify);
 792     s = SvPV(sv, len);
 793     if (len && !SvPOK(sv))
 794         s = SvPV_force(sv, len);
 795     if (DO_UTF8(sv)) {
 796         if (s && len) {
 797             char *send = s + len;
 798             char *start = s;
 799             s = send - 1;
 800             while ((*s & 0xc0) == 0x80)
 801                 --s;
 802             if (UTF8SKIP(s) != send - s && ckWARN_d(WARN_UTF8))
 803                 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
 804             sv_setpvn(astr, s, send - s);
 805             *s = '\0';
 806             SvCUR_set(sv, s - start);
 807             SvNIOK_off(sv);
 808             SvUTF8_on(astr);
 809         }
 810         else
 811             sv_setpvn(astr, "", 0);
 812     }
 813     else if (s && len) {
 814         s += --len;
 815         sv_setpvn(astr, s, 1);
 816         *s = '\0';
 817         SvCUR_set(sv, len);
 818         SvUTF8_off(sv);
 819         SvNIOK_off(sv);
 820     }
 821     else
 822         sv_setpvn(astr, "", 0);
 823     SvSETMAGIC(sv);
 824 }
 825
 826 I32
 827 Perl_do_chomp(pTHX_ register SV *sv)
 828 {
 829     register I32 count;
 830     STRLEN len;
 831     char *s;
 832
 833     if (RsSNARF(PL_rs))
 834         return 0;
 835     if (RsRECORD(PL_rs))
 836       return 0;
 837     count = 0;
 838     if (SvTYPE(sv) == SVt_PVAV) {
 839         register I32 i;
 840         I32 max;
 841         AV* av = (AV*)sv;
 842         max = AvFILL(av);
 843         for (i = 0; i <= max; i++) {
 844             sv = (SV*)av_fetch(av, i, FALSE);
 845             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
 846                 count += do_chomp(sv);
 847         }
 848         return count;
 849     }
 850     else if (SvTYPE(sv) == SVt_PVHV) {
 851         HV* hv = (HV*)sv;
 852         HE* entry;
 853         (void)hv_iterinit(hv);
 854         /*SUPPRESS 560*/
 855         while ((entry = hv_iternext(hv)))
 856             count += do_chomp(hv_iterval(hv,entry));
 857         return count;
 858     }
 859     else if (SvREADONLY(sv))
 860         Perl_croak(aTHX_ PL_no_modify);
 861     s = SvPV(sv, len);
 862     if (len && !SvPOKp(sv))
 863         s = SvPV_force(sv, len);
 864     if (s && len) {
 865         s += --len;
 866         if (RsPARA(PL_rs)) {
 867             if (*s != '\n')
 868                 goto nope;
 869             ++count;
 870             while (len && s[-1] == '\n') {
 871                 --len;
 872                 --s;
 873                 ++count;
 874             }
 875         }
 876         else {
 877             STRLEN rslen;
 878             char *rsptr = SvPV(PL_rs, rslen);
 879             if (rslen == 1) {
 880                 if (*s != *rsptr)
 881                     goto nope;
 882                 ++count;
 883             }
 884             else {
 885                 if (len < rslen - 1)
 886                     goto nope;
 887                 len -= rslen - 1;
 888                 s -= rslen - 1;
 889                 if (memNE(s, rsptr, rslen))
 890                     goto nope;
 891                 count += rslen;
 892             }
 893         }
 894         *s = '\0';
 895         SvCUR_set(sv, len);
 896         SvNIOK_off(sv);
 897     }
 898   nope:
 899     SvSETMAGIC(sv);
 900     return count;
 901 }
 902
 903 void
 904 Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
 905 {
 906 #ifdef LIBERAL
 907     register long *dl;
 908     register long *ll;
 909     register long *rl;
 910 #endif
 911     register char *dc;
 912     STRLEN leftlen;
 913     STRLEN rightlen;
 914     register char *lc;
 915     register char *rc;
 916     register I32 len;
 917     I32 lensave;
 918     char *lsave;
 919     char *rsave;
 920     bool left_utf = DO_UTF8(left);
 921     bool right_utf = DO_UTF8(right);
 922     I32 needlen;
 923
 924     if (left_utf && !right_utf)
 925         sv_utf8_upgrade(right);
 926     else if (!left_utf && right_utf)
 927         sv_utf8_upgrade(left);
 928
 929     if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
 930         sv_setpvn(sv, "", 0);   /* avoid undef warning on |= and ^= */
 931     lsave = lc = SvPV(left, leftlen);
 932     rsave = rc = SvPV(right, rightlen);
 933     len = leftlen < rightlen ? leftlen : rightlen;
 934     lensave = len;
 935     if ((left_utf || right_utf) && (sv == left || sv == right)) {
 936         needlen = optype == OP_BIT_AND ? len : leftlen + rightlen;
 937         Newz(801, dc, needlen + 1, char);
 938     }
 939     else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
 940         STRLEN n_a;
 941         dc = SvPV_force(sv, n_a);
 942         if (SvCUR(sv) < len) {
 943             dc = SvGROW(sv, len + 1);
 944             (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
 945         }
 946         if (optype != OP_BIT_AND && (left_utf || right_utf))
 947             dc = SvGROW(sv, leftlen + rightlen + 1);
 948     }
 949     else {
 950         needlen = ((optype == OP_BIT_AND)
 951                     ? len : (leftlen > rightlen ? leftlen : rightlen));
 952         Newz(801, dc, needlen + 1, char);
 953         (void)sv_usepvn(sv, dc, needlen);
 954         dc = SvPVX(sv);         /* sv_usepvn() calls Renew() */
 955     }
 956     SvCUR_set(sv, len);
 957     (void)SvPOK_only(sv);
 958     if (left_utf || right_utf) {
 959         UV duc, luc, ruc;
 960         char *dcsave = dc;
 961         STRLEN lulen = leftlen;
 962         STRLEN rulen = rightlen;
 963         STRLEN ulen;
 964
 965         switch (optype) {
 966         case OP_BIT_AND:
 967             while (lulen && rulen) {
 968                 luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
 969                 lc += ulen;
 970                 lulen -= ulen;
 971                 ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
 972                 rc += ulen;
 973                 rulen -= ulen;
 974                 duc = luc & ruc;
 975                 dc = (char*)uv_to_utf8((U8*)dc, duc);
 976             }
 977             if (sv == left || sv == right)
 978                 (void)sv_usepvn(sv, dcsave, needlen);
 979             SvCUR_set(sv, dc - dcsave);
 980             break;
 981         case OP_BIT_XOR:
 982             while (lulen && rulen) {
 983                 luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
 984                 lc += ulen;
 985                 lulen -= ulen;
 986                 ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
 987                 rc += ulen;
 988                 rulen -= ulen;
 989                 duc = luc ^ ruc;
 990                 dc = (char*)uv_to_utf8((U8*)dc, duc);
 991             }
 992             goto mop_up_utf;
 993         case OP_BIT_OR:
 994             while (lulen && rulen) {
 995                 luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
 996                 lc += ulen;
 997                 lulen -= ulen;
 998                 ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
 999                 rc += ulen;
1000                 rulen -= ulen;
1001                 duc = luc | ruc;
1002                 dc = (char*)uv_to_utf8((U8*)dc, duc);
1003             }
1004           mop_up_utf:
1005             if (sv == left || sv == right)
1006                 (void)sv_usepvn(sv, dcsave, needlen);
1007             SvCUR_set(sv, dc - dcsave);
1008             if (rulen)
1009                 sv_catpvn(sv, rc, rulen);
1010             else if (lulen)
1011                 sv_catpvn(sv, lc, lulen);
1012             else
1013                 *SvEND(sv) = '\0';
1014             break;
1015         }
1016         SvUTF8_on(sv);
1017         goto finish;
1018     }
1019     else
1020 #ifdef LIBERAL
1021     if (len >= sizeof(long)*4 &&
1022         !((long)dc % sizeof(long)) &&
1023         !((long)lc % sizeof(long)) &&
1024         !((long)rc % sizeof(long)))     /* It's almost always aligned... */
1025     {
1026         I32 remainder = len % (sizeof(long)*4);
1027         len /= (sizeof(long)*4);
1028
1029         dl = (long*)dc;
1030         ll = (long*)lc;
1031         rl = (long*)rc;
1032
1033         switch (optype) {
1034         case OP_BIT_AND:
1035             while (len--) {
1036                 *dl++ = *ll++ & *rl++;
1037                 *dl++ = *ll++ & *rl++;
1038                 *dl++ = *ll++ & *rl++;
1039                 *dl++ = *ll++ & *rl++;
1040             }
1041             break;
1042         case OP_BIT_XOR:
1043             while (len--) {
1044                 *dl++ = *ll++ ^ *rl++;
1045                 *dl++ = *ll++ ^ *rl++;
1046                 *dl++ = *ll++ ^ *rl++;
1047                 *dl++ = *ll++ ^ *rl++;
1048             }
1049             break;
1050         case OP_BIT_OR:
1051             while (len--) {
1052                 *dl++ = *ll++ | *rl++;
1053                 *dl++ = *ll++ | *rl++;
1054                 *dl++ = *ll++ | *rl++;
1055                 *dl++ = *ll++ | *rl++;
1056             }
1057         }
1058
1059         dc = (char*)dl;
1060         lc = (char*)ll;
1061         rc = (char*)rl;
1062
1063         len = remainder;
1064     }
1065 #endif
1066     {
1067         switch (optype) {
1068         case OP_BIT_AND:
1069             while (len--)
1070                 *dc++ = *lc++ & *rc++;
1071             break;
1072         case OP_BIT_XOR:
1073             while (len--)
1074                 *dc++ = *lc++ ^ *rc++;
1075             goto mop_up;
1076         case OP_BIT_OR:
1077             while (len--)
1078                 *dc++ = *lc++ | *rc++;
1079           mop_up:
1080             len = lensave;
1081             if (rightlen > len)
1082                 sv_catpvn(sv, rsave + len, rightlen - len);
1083             else if (leftlen > len)
1084                 sv_catpvn(sv, lsave + len, leftlen - len);
1085             else
1086                 *SvEND(sv) = '\0';
1087             break;
1088         }
1089     }
1090 finish:
1091     SvTAINT(sv);
1092 }
1093
1094 OP *
1095 Perl_do_kv(pTHX)
1096 {
1097     djSP;
1098     HV *hv = (HV*)POPs;
1099     HV *keys;
1100     register HE *entry;
1101     SV *tmpstr;
1102     I32 gimme = GIMME_V;
1103     I32 dokeys =   (PL_op->op_type == OP_KEYS);
1104     I32 dovalues = (PL_op->op_type == OP_VALUES);
1105     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
1106
1107     if (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV)
1108         dokeys = dovalues = TRUE;
1109
1110     if (!hv) {
1111         if (PL_op->op_flags & OPf_MOD) {        /* lvalue */
1112             dTARGET;            /* make sure to clear its target here */
1113             if (SvTYPE(TARG) == SVt_PVLV)
1114                 LvTARG(TARG) = Nullsv;
1115             PUSHs(TARG);
1116         }
1117         RETURN;
1118     }
1119
1120     keys = realhv ? hv : avhv_keys((AV*)hv);
1121     (void)hv_iterinit(keys);    /* always reset iterator regardless */
1122
1123     if (gimme == G_VOID)
1124         RETURN;
1125
1126     if (gimme == G_SCALAR) {
1127         IV i;
1128         dTARGET;
1129
1130         if (PL_op->op_flags & OPf_MOD) {        /* lvalue */
1131             if (SvTYPE(TARG) < SVt_PVLV) {
1132                 sv_upgrade(TARG, SVt_PVLV);
1133                 sv_magic(TARG, Nullsv, 'k', Nullch, 0);
1134             }
1135             LvTYPE(TARG) = 'k';
1136             if (LvTARG(TARG) != (SV*)keys) {
1137                 if (LvTARG(TARG))
1138                     SvREFCNT_dec(LvTARG(TARG));
1139                 LvTARG(TARG) = SvREFCNT_inc(keys);
1140             }
1141             PUSHs(TARG);
1142             RETURN;
1143         }
1144
1145         if (! SvTIED_mg((SV*)keys, 'P'))
1146             i = HvKEYS(keys);
1147         else {
1148             i = 0;
1149             /*SUPPRESS 560*/
1150             while (hv_iternext(keys)) i++;
1151         }
1152         PUSHi( i );
1153         RETURN;
1154     }
1155
1156     EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
1157
1158     PUTBACK;    /* hv_iternext and hv_iterval might clobber stack_sp */
1159     while ((entry = hv_iternext(keys))) {
1160         SPAGAIN;
1161         if (dokeys)
1162             XPUSHs(hv_iterkeysv(entry));        /* won't clobber stack_sp */
1163         if (dovalues) {
1164             PUTBACK;
1165             tmpstr = realhv ?
1166                      hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry);
1167             DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
1168                             (unsigned long)HeHASH(entry),
1169                             HvMAX(keys)+1,
1170                             (unsigned long)(HeHASH(entry) & HvMAX(keys))));
1171             SPAGAIN;
1172             XPUSHs(tmpstr);
1173         }
1174         PUTBACK;
1175     }
1176     return NORMAL;
1177 }
1178