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