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