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