doop.c

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