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