doop.c

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