doop.c

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