doop.c

   1 /*    doop.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2004, 2005, 2006, 2007, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "'So that was the job I felt I had to do when I started,' thought Sam."
  13  */
  14
  15 /* This file contains some common functions needed to carry out certain
  16  * ops. For example both pp_schomp() and pp_chomp() - scalar and array
  17  * chomp operations - call the function do_chomp() found in this file.
  18  */
  19
  20 #include "EXTERN.h"
  21 #define PERL_IN_DOOP_C
  22 #include "perl.h"
  23
  24 #ifndef PERL_MICRO
  25 #include <signal.h>
  26 #endif
  27
  28 STATIC I32
  29 S_do_trans_simple(pTHX_ SV * const sv)
  30 {
  31     dVAR;
  32     I32 matches = 0;
  33     STRLEN len;
  34     U8 *s = (U8*)SvPV(sv,len);
  35     U8 * const send = s+len;
  36     const short * const tbl = (short*)cPVOP->op_pv;
  37
  38     PERL_ARGS_ASSERT_DO_TRANS_SIMPLE;
  39
  40     if (!tbl)
  41         Perl_croak(aTHX_ "panic: do_trans_simple line %d",__LINE__);
  42
  43     /* First, take care of non-UTF-8 input strings, because they're easy */
  44     if (!SvUTF8(sv)) {
  45         while (s < send) {
  46             const I32 ch = tbl[*s];
  47             if (ch >= 0) {
  48                 matches++;
  49                 *s = (U8)ch;
  50             }
  51             s++;
  52         }
  53         SvSETMAGIC(sv);
  54     }
  55     else {
  56         const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
  57         U8 *d;
  58         U8 *dstart;
  59
  60         /* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */
  61         if (grows)
  62             Newx(d, len*2+1, U8);
  63         else
  64             d = s;
  65         dstart = d;
  66         while (s < send) {
  67             STRLEN ulen;
  68             I32 ch;
  69
  70             /* Need to check this, otherwise 128..255 won't match */
  71             const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT);
  72             if (c < 0x100 && (ch = tbl[c]) >= 0) {
  73                 matches++;
  74                 d = uvchr_to_utf8(d, ch);
  75                 s += ulen;
  76             }
  77             else { /* No match -> copy */
  78                 Move(s, d, ulen, U8);
  79                 d += ulen;
  80                 s += ulen;
  81             }
  82         }
  83         if (grows) {
  84             sv_setpvn(sv, (char*)dstart, d - dstart);
  85             Safefree(dstart);
  86         }
  87         else {
  88             *d = '\0';
  89             SvCUR_set(sv, d - dstart);
  90         }
  91         SvUTF8_on(sv);
  92         SvSETMAGIC(sv);
  93     }
  94     return matches;
  95 }
  96
  97 STATIC I32
  98 S_do_trans_count(pTHX_ SV * const sv)
  99 {
 100     dVAR;
 101     STRLEN len;
 102     const U8 *s = (const U8*)SvPV_const(sv, len);
 103     const U8 * const send = s + len;
 104     I32 matches = 0;
 105     const short * const tbl = (short*)cPVOP->op_pv;
 106
 107     PERL_ARGS_ASSERT_DO_TRANS_COUNT;
 108
 109     if (!tbl)
 110         Perl_croak(aTHX_ "panic: do_trans_count line %d",__LINE__);
 111
 112     if (!SvUTF8(sv)) {
 113         while (s < send) {
 114             if (tbl[*s++] >= 0)
 115                 matches++;
 116         }
 117     }
 118     else {
 119         const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
 120         while (s < send) {
 121             STRLEN ulen;
 122             const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT);
 123             if (c < 0x100) {
 124                 if (tbl[c] >= 0)
 125                     matches++;
 126             } else if (complement)
 127                 matches++;
 128             s += ulen;
 129         }
 130     }
 131
 132     return matches;
 133 }
 134
 135 STATIC I32
 136 S_do_trans_complex(pTHX_ SV * const sv)
 137 {
 138     dVAR;
 139     STRLEN len;
 140     U8 *s = (U8*)SvPV(sv, len);
 141     U8 * const send = s+len;
 142     I32 matches = 0;
 143     const short * const tbl = (short*)cPVOP->op_pv;
 144
 145     PERL_ARGS_ASSERT_DO_TRANS_COMPLEX;
 146
 147     if (!tbl)
 148         Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__);
 149
 150     if (!SvUTF8(sv)) {
 151         U8 *d = s;
 152         U8 * const dstart = d;
 153
 154         if (PL_op->op_private & OPpTRANS_SQUASH) {
 155             const U8* p = send;
 156             while (s < send) {
 157                 const I32 ch = tbl[*s];
 158                 if (ch >= 0) {
 159                     *d = (U8)ch;
 160                     matches++;
 161                     if (p != d - 1 || *p != *d)
 162                         p = d++;
 163                 }
 164                 else if (ch == -1)      /* -1 is unmapped character */
 165                     *d++ = *s;
 166                 else if (ch == -2)      /* -2 is delete character */
 167                     matches++;
 168                 s++;
 169             }
 170         }
 171         else {
 172             while (s < send) {
 173                 const I32 ch = tbl[*s];
 174                 if (ch >= 0) {
 175                     matches++;
 176                     *d++ = (U8)ch;
 177                 }
 178                 else if (ch == -1)      /* -1 is unmapped character */
 179                     *d++ = *s;
 180                 else if (ch == -2)      /* -2 is delete character */
 181                     matches++;
 182                 s++;
 183             }
 184         }
 185         *d = '\0';
 186         SvCUR_set(sv, d - dstart);
 187     }
 188     else { /* is utf8 */
 189         const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
 190         const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
 191         const I32 del = PL_op->op_private & OPpTRANS_DELETE;
 192         U8 *d;
 193         U8 *dstart;
 194         STRLEN rlen = 0;
 195
 196         if (grows)
 197             Newx(d, len*2+1, U8);
 198         else
 199             d = s;
 200         dstart = d;
 201         if (complement && !del)
 202             rlen = tbl[0x100];
 203
 204 #ifdef MACOS_TRADITIONAL
 205 #define comp CoMP   /* "comp" is a keyword in some compilers ... */
 206 #endif
 207
 208         if (PL_op->op_private & OPpTRANS_SQUASH) {
 209             UV pch = 0xfeedface;
 210             while (s < send) {
 211                 STRLEN len;
 212                 const UV comp = utf8n_to_uvchr(s, send - s, &len,
 213                                                UTF8_ALLOW_DEFAULT);
 214                 I32 ch;
 215
 216                 if (comp > 0xff) {
 217                     if (!complement) {
 218                         Move(s, d, len, U8);
 219                         d += len;
 220                     }
 221                     else {
 222                         matches++;
 223                         if (!del) {
 224                             ch = (rlen == 0) ? (I32)comp :
 225                                 (comp - 0x100 < rlen) ?
 226                                 tbl[comp+1] : tbl[0x100+rlen];
 227                             if ((UV)ch != pch) {
 228                                 d = uvchr_to_utf8(d, ch);
 229                                 pch = (UV)ch;
 230                             }
 231                             s += len;
 232                             continue;
 233                         }
 234                     }
 235                 }
 236                 else if ((ch = tbl[comp]) >= 0) {
 237                     matches++;
 238                     if ((UV)ch != pch) {
 239                         d = uvchr_to_utf8(d, ch);
 240                         pch = (UV)ch;
 241                     }
 242                     s += len;
 243                     continue;
 244                 }
 245                 else if (ch == -1) {    /* -1 is unmapped character */
 246                     Move(s, d, len, U8);
 247                     d += len;
 248                 }
 249                 else if (ch == -2)      /* -2 is delete character */
 250                     matches++;
 251                 s += len;
 252                 pch = 0xfeedface;
 253             }
 254         }
 255         else {
 256             while (s < send) {
 257                 STRLEN len;
 258                 const UV comp = utf8n_to_uvchr(s, send - s, &len,
 259                                                UTF8_ALLOW_DEFAULT);
 260                 I32 ch;
 261                 if (comp > 0xff) {
 262                     if (!complement) {
 263                         Move(s, d, len, U8);
 264                         d += len;
 265                     }
 266                     else {
 267                         matches++;
 268                         if (!del) {
 269                             if (comp - 0x100 < rlen)
 270                                 d = uvchr_to_utf8(d, tbl[comp+1]);
 271                             else
 272                                 d = uvchr_to_utf8(d, tbl[0x100+rlen]);
 273                         }
 274                     }
 275                 }
 276                 else if ((ch = tbl[comp]) >= 0) {
 277                     d = uvchr_to_utf8(d, ch);
 278                     matches++;
 279                 }
 280                 else if (ch == -1) {    /* -1 is unmapped character */
 281                     Move(s, d, len, U8);
 282                     d += len;
 283                 }
 284                 else if (ch == -2)      /* -2 is delete character */
 285                     matches++;
 286                 s += len;
 287             }
 288         }
 289         if (grows) {
 290             sv_setpvn(sv, (char*)dstart, d - dstart);
 291             Safefree(dstart);
 292         }
 293         else {
 294             *d = '\0';
 295             SvCUR_set(sv, d - dstart);
 296         }
 297         SvUTF8_on(sv);
 298     }
 299     SvSETMAGIC(sv);
 300     return matches;
 301 }
 302
 303 STATIC I32
 304 S_do_trans_simple_utf8(pTHX_ SV * const sv)
 305 {
 306     dVAR;
 307     U8 *s;
 308     U8 *send;
 309     U8 *d;
 310     U8 *start;
 311     U8 *dstart, *dend;
 312     I32 matches = 0;
 313     const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
 314     STRLEN len;
 315     SV* const  rv =
 316 #ifdef USE_ITHREADS
 317                     PAD_SVl(cPADOP->op_padix);
 318 #else
 319                     (SV*)cSVOP->op_sv;
 320 #endif
 321     HV* const  hv = (HV*)SvRV(rv);
 322     SV* const * svp = hv_fetchs(hv, "NONE", FALSE);
 323     const UV none = svp ? SvUV(*svp) : 0x7fffffff;
 324     const UV extra = none + 1;
 325     UV final = 0;
 326     U8 hibit = 0;
 327
 328     PERL_ARGS_ASSERT_DO_TRANS_SIMPLE_UTF8;
 329
 330     s = (U8*)SvPV(sv, len);
 331     if (!SvUTF8(sv)) {
 332         const U8 *t = s;
 333         const U8 * const e = s + len;
 334         while (t < e) {
 335             const U8 ch = *t++;
 336             hibit = !NATIVE_IS_INVARIANT(ch);
 337             if (hibit) {
 338                 s = bytes_to_utf8(s, &len);
 339                 break;
 340             }
 341         }
 342     }
 343     send = s + len;
 344     start = s;
 345
 346     svp = hv_fetchs(hv, "FINAL", FALSE);
 347     if (svp)
 348         final = SvUV(*svp);
 349
 350     if (grows) {
 351         /* d needs to be bigger than s, in case e.g. upgrading is required */
 352         Newx(d, len * 3 + UTF8_MAXBYTES, U8);
 353         dend = d + len * 3;
 354         dstart = d;
 355     }
 356     else {
 357         dstart = d = s;
 358         dend = d + len;
 359     }
 360
 361     while (s < send) {
 362         const UV uv = swash_fetch(rv, s, TRUE);
 363         if (uv < none) {
 364             s += UTF8SKIP(s);
 365             matches++;
 366             d = uvuni_to_utf8(d, uv);
 367         }
 368         else if (uv == none) {
 369             const int i = UTF8SKIP(s);
 370             Move(s, d, i, U8);
 371             d += i;
 372             s += i;
 373         }
 374         else if (uv == extra) {
 375             s += UTF8SKIP(s);
 376             matches++;
 377             d = uvuni_to_utf8(d, final);
 378         }
 379         else
 380             s += UTF8SKIP(s);
 381
 382         if (d > dend) {
 383             const STRLEN clen = d - dstart;
 384             const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES;
 385             if (!grows)
 386                 Perl_croak(aTHX_ "panic: do_trans_simple_utf8 line %d",__LINE__);
 387             Renew(dstart, nlen + UTF8_MAXBYTES, U8);
 388             d = dstart + clen;
 389             dend = dstart + nlen;
 390         }
 391     }
 392     if (grows || hibit) {
 393         sv_setpvn(sv, (char*)dstart, d - dstart);
 394         Safefree(dstart);
 395         if (grows && hibit)
 396             Safefree(start);
 397     }
 398     else {
 399         *d = '\0';
 400         SvCUR_set(sv, d - dstart);
 401     }
 402     SvSETMAGIC(sv);
 403     SvUTF8_on(sv);
 404
 405     return matches;
 406 }
 407
 408 STATIC I32
 409 S_do_trans_count_utf8(pTHX_ SV * const sv)
 410 {
 411     dVAR;
 412     const U8 *s;
 413     const U8 *start = NULL;
 414     const U8 *send;
 415     I32 matches = 0;
 416     STRLEN len;
 417     SV* const  rv =
 418 #ifdef USE_ITHREADS
 419                     PAD_SVl(cPADOP->op_padix);
 420 #else
 421                     (SV*)cSVOP->op_sv;
 422 #endif
 423     HV* const hv = (HV*)SvRV(rv);
 424     SV* const * const svp = hv_fetchs(hv, "NONE", FALSE);
 425     const UV none = svp ? SvUV(*svp) : 0x7fffffff;
 426     const UV extra = none + 1;
 427     U8 hibit = 0;
 428
 429     PERL_ARGS_ASSERT_DO_TRANS_COUNT_UTF8;
 430
 431     s = (const U8*)SvPV_const(sv, len);
 432     if (!SvUTF8(sv)) {
 433         const U8 *t = s;
 434         const U8 * const e = s + len;
 435         while (t < e) {
 436             const U8 ch = *t++;
 437             hibit = !NATIVE_IS_INVARIANT(ch);
 438             if (hibit) {
 439                 start = s = bytes_to_utf8(s, &len);
 440                 break;
 441             }
 442         }
 443     }
 444     send = s + len;
 445
 446     while (s < send) {
 447         const UV uv = swash_fetch(rv, s, TRUE);
 448         if (uv < none || uv == extra)
 449             matches++;
 450         s += UTF8SKIP(s);
 451     }
 452     if (hibit)
 453         Safefree(start);
 454
 455     return matches;
 456 }
 457
 458 STATIC I32
 459 S_do_trans_complex_utf8(pTHX_ SV * const sv)
 460 {
 461     dVAR;
 462     U8 *start, *send;
 463     U8 *d;
 464     I32 matches = 0;
 465     const I32 squash   = PL_op->op_private & OPpTRANS_SQUASH;
 466     const I32 del      = PL_op->op_private & OPpTRANS_DELETE;
 467     const I32 grows    = PL_op->op_private & OPpTRANS_GROWS;
 468     SV* const  rv =
 469 #ifdef USE_ITHREADS
 470                     PAD_SVl(cPADOP->op_padix);
 471 #else
 472                     (SV*)cSVOP->op_sv;
 473 #endif
 474     HV * const hv = (HV*)SvRV(rv);
 475     SV * const *svp = hv_fetchs(hv, "NONE", FALSE);
 476     const UV none = svp ? SvUV(*svp) : 0x7fffffff;
 477     const UV extra = none + 1;
 478     UV final = 0;
 479     bool havefinal = FALSE;
 480     STRLEN len;
 481     U8 *dstart, *dend;
 482     U8 hibit = 0;
 483     U8 *s = (U8*)SvPV(sv, len);
 484
 485     PERL_ARGS_ASSERT_DO_TRANS_COMPLEX_UTF8;
 486
 487     if (!SvUTF8(sv)) {
 488         const U8 *t = s;
 489         const U8 * const e = s + len;
 490         while (t < e) {
 491             const U8 ch = *t++;
 492             hibit = !NATIVE_IS_INVARIANT(ch);
 493             if (hibit) {
 494                 s = bytes_to_utf8(s, &len);
 495                 break;
 496             }
 497         }
 498     }
 499     send = s + len;
 500     start = s;
 501
 502     svp = hv_fetchs(hv, "FINAL", FALSE);
 503     if (svp) {
 504         final = SvUV(*svp);
 505         havefinal = TRUE;
 506     }
 507
 508     if (grows) {
 509         /* d needs to be bigger than s, in case e.g. upgrading is required */
 510         Newx(d, len * 3 + UTF8_MAXBYTES, U8);
 511         dend = d + len * 3;
 512         dstart = d;
 513     }
 514     else {
 515         dstart = d = s;
 516         dend = d + len;
 517     }
 518
 519     if (squash) {
 520         UV puv = 0xfeedface;
 521         while (s < send) {
 522             UV uv = swash_fetch(rv, s, TRUE);
 523
 524             if (d > dend) {
 525                 const STRLEN clen = d - dstart;
 526                 const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES;
 527                 if (!grows)
 528                     Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__);
 529                 Renew(dstart, nlen + UTF8_MAXBYTES, U8);
 530                 d = dstart + clen;
 531                 dend = dstart + nlen;
 532             }
 533             if (uv < none) {
 534                 matches++;
 535                 s += UTF8SKIP(s);
 536                 if (uv != puv) {
 537                     d = uvuni_to_utf8(d, uv);
 538                     puv = uv;
 539                 }
 540                 continue;
 541             }
 542             else if (uv == none) {      /* "none" is unmapped character */
 543                 const int i = UTF8SKIP(s);
 544                 Move(s, d, i, U8);
 545                 d += i;
 546                 s += i;
 547                 puv = 0xfeedface;
 548                 continue;
 549             }
 550             else if (uv == extra && !del) {
 551                 matches++;
 552                 if (havefinal) {
 553                     s += UTF8SKIP(s);
 554                     if (puv != final) {
 555                         d = uvuni_to_utf8(d, final);
 556                         puv = final;
 557                     }
 558                 }
 559                 else {
 560                     STRLEN len;
 561                     uv = utf8n_to_uvuni(s, send - s, &len, UTF8_ALLOW_DEFAULT);
 562                     if (uv != puv) {
 563                         Move(s, d, len, U8);
 564                         d += len;
 565                         puv = uv;
 566                     }
 567                     s += len;
 568                 }
 569                 continue;
 570             }
 571             matches++;                  /* "none+1" is delete character */
 572             s += UTF8SKIP(s);
 573         }
 574     }
 575     else {
 576         while (s < send) {
 577             const UV uv = swash_fetch(rv, s, TRUE);
 578             if (d > dend) {
 579                 const STRLEN clen = d - dstart;
 580                 const STRLEN nlen = dend - dstart + len + UTF8_MAXBYTES;
 581                 if (!grows)
 582                     Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__);
 583                 Renew(dstart, nlen + UTF8_MAXBYTES, U8);
 584                 d = dstart + clen;
 585                 dend = dstart + nlen;
 586             }
 587             if (uv < none) {
 588                 matches++;
 589                 s += UTF8SKIP(s);
 590                 d = uvuni_to_utf8(d, uv);
 591                 continue;
 592             }
 593             else if (uv == none) {      /* "none" is unmapped character */
 594                 const int i = UTF8SKIP(s);
 595                 Move(s, d, i, U8);
 596                 d += i;
 597                 s += i;
 598                 continue;
 599             }
 600             else if (uv == extra && !del) {
 601                 matches++;
 602                 s += UTF8SKIP(s);
 603                 d = uvuni_to_utf8(d, final);
 604                 continue;
 605             }
 606             matches++;                  /* "none+1" is delete character */
 607             s += UTF8SKIP(s);
 608         }
 609     }
 610     if (grows || hibit) {
 611         sv_setpvn(sv, (char*)dstart, d - dstart);
 612         Safefree(dstart);
 613         if (grows && hibit)
 614             Safefree(start);
 615     }
 616     else {
 617         *d = '\0';
 618         SvCUR_set(sv, d - dstart);
 619     }
 620     SvUTF8_on(sv);
 621     SvSETMAGIC(sv);
 622
 623     return matches;
 624 }
 625
 626 I32
 627 Perl_do_trans(pTHX_ SV *sv)
 628 {
 629     dVAR;
 630     STRLEN len;
 631     const I32 hasutf = (PL_op->op_private &
 632                     (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
 633
 634     PERL_ARGS_ASSERT_DO_TRANS;
 635
 636     if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL)) {
 637         if (SvIsCOW(sv))
 638             sv_force_normal_flags(sv, 0);
 639         if (SvREADONLY(sv))
 640             Perl_croak(aTHX_ PL_no_modify);
 641     }
 642     (void)SvPV_const(sv, len);
 643     if (!len)
 644         return 0;
 645     if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) {
 646         if (!SvPOKp(sv))
 647             (void)SvPV_force(sv, len);
 648         (void)SvPOK_only_UTF8(sv);
 649     }
 650
 651     DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
 652
 653     switch (PL_op->op_private & ~hasutf & (
 654                 OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|
 655                 OPpTRANS_SQUASH|OPpTRANS_DELETE|OPpTRANS_COMPLEMENT)) {
 656     case 0:
 657         if (hasutf)
 658             return do_trans_simple_utf8(sv);
 659         else
 660             return do_trans_simple(sv);
 661
 662     case OPpTRANS_IDENTICAL:
 663     case OPpTRANS_IDENTICAL|OPpTRANS_COMPLEMENT:
 664         if (hasutf)
 665             return do_trans_count_utf8(sv);
 666         else
 667             return do_trans_count(sv);
 668
 669     default:
 670         if (hasutf)
 671             return do_trans_complex_utf8(sv);
 672         else
 673             return do_trans_complex(sv);
 674     }
 675 }
 676
 677 void
 678 Perl_do_join(pTHX_ register SV *sv, SV *delim, register SV **mark, register SV **sp)
 679 {
 680     dVAR;
 681     SV ** const oldmark = mark;
 682     register I32 items = sp - mark;
 683     register STRLEN len;
 684     STRLEN delimlen;
 685
 686     PERL_ARGS_ASSERT_DO_JOIN;
 687
 688     (void) SvPV_const(delim, delimlen); /* stringify and get the delimlen */
 689     /* SvCUR assumes it's SvPOK() and woe betide you if it's not. */
 690
 691     mark++;
 692     len = (items > 0 ? (delimlen * (items - 1) ) : 0);
 693     SvUPGRADE(sv, SVt_PV);
 694     if (SvLEN(sv) < len + items) {      /* current length is way too short */
 695         while (items-- > 0) {
 696             if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) {
 697                 STRLEN tmplen;
 698                 SvPV_const(*mark, tmplen);
 699                 len += tmplen;
 700             }
 701             mark++;
 702         }
 703         SvGROW(sv, len + 1);            /* so try to pre-extend */
 704
 705         mark = oldmark;
 706         items = sp - mark;
 707         ++mark;
 708     }
 709
 710     sv_setpvn(sv, "", 0);
 711     /* sv_setpv retains old UTF8ness [perl #24846] */
 712     SvUTF8_off(sv);
 713
 714     if (PL_tainting && SvMAGICAL(sv))
 715         SvTAINTED_off(sv);
 716
 717     if (items-- > 0) {
 718         if (*mark)
 719             sv_catsv(sv, *mark);
 720         mark++;
 721     }
 722
 723     if (delimlen) {
 724         for (; items > 0; items--,mark++) {
 725             sv_catsv(sv,delim);
 726             sv_catsv(sv,*mark);
 727         }
 728     }
 729     else {
 730         for (; items > 0; items--,mark++)
 731             sv_catsv(sv,*mark);
 732     }
 733     SvSETMAGIC(sv);
 734 }
 735
 736 void
 737 Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
 738 {
 739     dVAR;
 740     STRLEN patlen;
 741     const char * const pat = SvPV_const(*sarg, patlen);
 742     bool do_taint = FALSE;
 743
 744     PERL_ARGS_ASSERT_DO_SPRINTF;
 745
 746     SvUTF8_off(sv);
 747     if (DO_UTF8(*sarg))
 748         SvUTF8_on(sv);
 749     sv_vsetpvfn(sv, pat, patlen, NULL, sarg + 1, len - 1, &do_taint);
 750     SvSETMAGIC(sv);
 751     if (do_taint)
 752         SvTAINTED_on(sv);
 753 }
 754
 755 /* currently converts input to bytes if possible, but doesn't sweat failure */
 756 UV
 757 Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
 758 {
 759     dVAR;
 760     STRLEN srclen, len, uoffset, bitoffs = 0;
 761     const unsigned char *s = (const unsigned char *) SvPV_const(sv, srclen);
 762     UV retnum = 0;
 763
 764     PERL_ARGS_ASSERT_DO_VECGET;
 765
 766     if (offset < 0)
 767         return 0;
 768     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
 769         Perl_croak(aTHX_ "Illegal number of bits in vec");
 770
 771     if (SvUTF8(sv))
 772         (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE);
 773
 774     if (size < 8) {
 775         bitoffs = ((offset%8)*size)%8;
 776         uoffset = offset/(8/size);
 777     }
 778     else if (size > 8)
 779         uoffset = offset*(size/8);
 780     else
 781         uoffset = offset;
 782
 783     len = uoffset + (bitoffs + size + 7)/8;     /* required number of bytes */
 784     if (len > srclen) {
 785         if (size <= 8)
 786             retnum = 0;
 787         else {
 788             if (size == 16) {
 789                 if (uoffset >= srclen)
 790                     retnum = 0;
 791                 else
 792                     retnum = (UV) s[uoffset] <<  8;
 793             }
 794             else if (size == 32) {
 795                 if (uoffset >= srclen)
 796                     retnum = 0;
 797                 else if (uoffset + 1 >= srclen)
 798                     retnum =
 799                         ((UV) s[uoffset    ] << 24);
 800                 else if (uoffset + 2 >= srclen)
 801                     retnum =
 802                         ((UV) s[uoffset    ] << 24) +
 803                         ((UV) s[uoffset + 1] << 16);
 804                 else
 805                     retnum =
 806                         ((UV) s[uoffset    ] << 24) +
 807                         ((UV) s[uoffset + 1] << 16) +
 808                         (     s[uoffset + 2] <<  8);
 809             }
 810 #ifdef UV_IS_QUAD
 811             else if (size == 64) {
 812                 if (ckWARN(WARN_PORTABLE))
 813                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
 814                                 "Bit vector size > 32 non-portable");
 815                 if (uoffset >= srclen)
 816                     retnum = 0;
 817                 else if (uoffset + 1 >= srclen)
 818                     retnum =
 819                         (UV) s[uoffset     ] << 56;
 820                 else if (uoffset + 2 >= srclen)
 821                     retnum =
 822                         ((UV) s[uoffset    ] << 56) +
 823                         ((UV) s[uoffset + 1] << 48);
 824                 else if (uoffset + 3 >= srclen)
 825                     retnum =
 826                         ((UV) s[uoffset    ] << 56) +
 827                         ((UV) s[uoffset + 1] << 48) +
 828                         ((UV) s[uoffset + 2] << 40);
 829                 else if (uoffset + 4 >= srclen)
 830                     retnum =
 831                         ((UV) s[uoffset    ] << 56) +
 832                         ((UV) s[uoffset + 1] << 48) +
 833                         ((UV) s[uoffset + 2] << 40) +
 834                         ((UV) s[uoffset + 3] << 32);
 835                 else if (uoffset + 5 >= srclen)
 836                     retnum =
 837                         ((UV) s[uoffset    ] << 56) +
 838                         ((UV) s[uoffset + 1] << 48) +
 839                         ((UV) s[uoffset + 2] << 40) +
 840                         ((UV) s[uoffset + 3] << 32) +
 841                         (     s[uoffset + 4] << 24);
 842                 else if (uoffset + 6 >= srclen)
 843                     retnum =
 844                         ((UV) s[uoffset    ] << 56) +
 845                         ((UV) s[uoffset + 1] << 48) +
 846                         ((UV) s[uoffset + 2] << 40) +
 847                         ((UV) s[uoffset + 3] << 32) +
 848                         ((UV) s[uoffset + 4] << 24) +
 849                         ((UV) s[uoffset + 5] << 16);
 850                 else
 851                     retnum =
 852                         ((UV) s[uoffset    ] << 56) +
 853                         ((UV) s[uoffset + 1] << 48) +
 854                         ((UV) s[uoffset + 2] << 40) +
 855                         ((UV) s[uoffset + 3] << 32) +
 856                         ((UV) s[uoffset + 4] << 24) +
 857                         ((UV) s[uoffset + 5] << 16) +
 858                         (     s[uoffset + 6] <<  8);
 859             }
 860 #endif
 861         }
 862     }
 863     else if (size < 8)
 864         retnum = (s[uoffset] >> bitoffs) & ((1 << size) - 1);
 865     else {
 866         if (size == 8)
 867             retnum = s[uoffset];
 868         else if (size == 16)
 869             retnum =
 870                 ((UV) s[uoffset] <<      8) +
 871                       s[uoffset + 1];
 872         else if (size == 32)
 873             retnum =
 874                 ((UV) s[uoffset    ] << 24) +
 875                 ((UV) s[uoffset + 1] << 16) +
 876                 (     s[uoffset + 2] <<  8) +
 877                       s[uoffset + 3];
 878 #ifdef UV_IS_QUAD
 879         else if (size == 64) {
 880             if (ckWARN(WARN_PORTABLE))
 881                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
 882                             "Bit vector size > 32 non-portable");
 883             retnum =
 884                 ((UV) s[uoffset    ] << 56) +
 885                 ((UV) s[uoffset + 1] << 48) +
 886                 ((UV) s[uoffset + 2] << 40) +
 887                 ((UV) s[uoffset + 3] << 32) +
 888                 ((UV) s[uoffset + 4] << 24) +
 889                 ((UV) s[uoffset + 5] << 16) +
 890                 (     s[uoffset + 6] <<  8) +
 891                       s[uoffset + 7];
 892         }
 893 #endif
 894     }
 895
 896     return retnum;
 897 }
 898
 899 /* currently converts input to bytes if possible but doesn't sweat failures,
 900  * although it does ensure that the string it clobbers is not marked as
 901  * utf8-valid any more
 902  */
 903 void
 904 Perl_do_vecset(pTHX_ SV *sv)
 905 {
 906     dVAR;
 907     register I32 offset, bitoffs = 0;
 908     register I32 size;
 909     register unsigned char *s;
 910     register UV lval;
 911     I32 mask;
 912     STRLEN targlen;
 913     STRLEN len;
 914     SV * const targ = LvTARG(sv);
 915
 916     PERL_ARGS_ASSERT_DO_VECSET;
 917
 918     if (!targ)
 919         return;
 920     s = (unsigned char*)SvPV_force(targ, targlen);
 921     if (SvUTF8(targ)) {
 922         /* This is handled by the SvPOK_only below...
 923         if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
 924             SvUTF8_off(targ);
 925          */
 926         (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
 927     }
 928
 929     (void)SvPOK_only(targ);
 930     lval = SvUV(sv);
 931     offset = LvTARGOFF(sv);
 932     if (offset < 0)
 933         Perl_croak(aTHX_ "Negative offset to vec in lvalue context");
 934     size = LvTARGLEN(sv);
 935     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
 936         Perl_croak(aTHX_ "Illegal number of bits in vec");
 937
 938     if (size < 8) {
 939         bitoffs = ((offset%8)*size)%8;
 940         offset /= 8/size;
 941     }
 942     else if (size > 8)
 943         offset *= size/8;
 944
 945     len = offset + (bitoffs + size + 7)/8;      /* required number of bytes */
 946     if (len > targlen) {
 947         s = (unsigned char*)SvGROW(targ, len + 1);
 948         (void)memzero((char *)(s + targlen), len - targlen + 1);
 949         SvCUR_set(targ, len);
 950     }
 951
 952     if (size < 8) {
 953         mask = (1 << size) - 1;
 954         lval &= mask;
 955         s[offset] &= ~(mask << bitoffs);
 956         s[offset] |= lval << bitoffs;
 957     }
 958     else {
 959         if (size == 8)
 960             s[offset  ] = (U8)( lval        & 0xff);
 961         else if (size == 16) {
 962             s[offset  ] = (U8)((lval >>  8) & 0xff);
 963             s[offset+1] = (U8)( lval        & 0xff);
 964         }
 965         else if (size == 32) {
 966             s[offset  ] = (U8)((lval >> 24) & 0xff);
 967             s[offset+1] = (U8)((lval >> 16) & 0xff);
 968             s[offset+2] = (U8)((lval >>  8) & 0xff);
 969             s[offset+3] = (U8)( lval        & 0xff);
 970         }
 971 #ifdef UV_IS_QUAD
 972         else if (size == 64) {
 973             if (ckWARN(WARN_PORTABLE))
 974                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
 975                             "Bit vector size > 32 non-portable");
 976             s[offset  ] = (U8)((lval >> 56) & 0xff);
 977             s[offset+1] = (U8)((lval >> 48) & 0xff);
 978             s[offset+2] = (U8)((lval >> 40) & 0xff);
 979             s[offset+3] = (U8)((lval >> 32) & 0xff);
 980             s[offset+4] = (U8)((lval >> 24) & 0xff);
 981             s[offset+5] = (U8)((lval >> 16) & 0xff);
 982             s[offset+6] = (U8)((lval >>  8) & 0xff);
 983             s[offset+7] = (U8)( lval        & 0xff);
 984         }
 985 #endif
 986     }
 987     SvSETMAGIC(targ);
 988 }
 989
 990 void
 991 Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
 992 {
 993     dVAR;
 994     STRLEN len;
 995     char *s;
 996
 997     PERL_ARGS_ASSERT_DO_CHOP;
 998
 999     if (SvTYPE(sv) == SVt_PVAV) {
1000         register I32 i;
1001         AV* const av = (AV*)sv;
1002         const I32 max = AvFILL(av);
1003
1004         for (i = 0; i <= max; i++) {
1005             sv = (SV*)av_fetch(av, i, FALSE);
1006             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
1007                 do_chop(astr, sv);
1008         }
1009         return;
1010     }
1011     else if (SvTYPE(sv) == SVt_PVHV) {
1012         HV* const hv = (HV*)sv;
1013         HE* entry;
1014         (void)hv_iterinit(hv);
1015         while ((entry = hv_iternext(hv)))
1016             do_chop(astr,hv_iterval(hv,entry));
1017         return;
1018     }
1019     else if (SvREADONLY(sv)) {
1020         if (SvFAKE(sv)) {
1021             /* SV is copy-on-write */
1022             sv_force_normal_flags(sv, 0);
1023         }
1024         if (SvREADONLY(sv))
1025             Perl_croak(aTHX_ PL_no_modify);
1026     }
1027
1028     if (PL_encoding && !SvUTF8(sv)) {
1029         /* like in do_chomp(), utf8-ize the sv as a side-effect
1030          * if we're using encoding. */
1031         sv_recode_to_utf8(sv, PL_encoding);
1032     }
1033
1034     s = SvPV(sv, len);
1035     if (len && !SvPOK(sv))
1036         s = SvPV_force_nomg(sv, len);
1037     if (DO_UTF8(sv)) {
1038         if (s && len) {
1039             char * const send = s + len;
1040             char * const start = s;
1041             s = send - 1;
1042             while (s > start && UTF8_IS_CONTINUATION(*s))
1043                 s--;
1044             if (is_utf8_string((U8*)s, send - s)) {
1045                 sv_setpvn(astr, s, send - s);
1046                 *s = '\0';
1047                 SvCUR_set(sv, s - start);
1048                 SvNIOK_off(sv);
1049                 SvUTF8_on(astr);
1050             }
1051         }
1052         else
1053             sv_setpvn(astr, "", 0);
1054     }
1055     else if (s && len) {
1056         s += --len;
1057         sv_setpvn(astr, s, 1);
1058         *s = '\0';
1059         SvCUR_set(sv, len);
1060         SvUTF8_off(sv);
1061         SvNIOK_off(sv);
1062     }
1063     else
1064         sv_setpvn(astr, "", 0);
1065     SvSETMAGIC(sv);
1066 }
1067
1068 I32
1069 Perl_do_chomp(pTHX_ register SV *sv)
1070 {
1071     dVAR;
1072     register I32 count;
1073     STRLEN len;
1074     char *s;
1075     char *temp_buffer = NULL;
1076     SV* svrecode = NULL;
1077
1078     PERL_ARGS_ASSERT_DO_CHOMP;
1079
1080     if (RsSNARF(PL_rs))
1081         return 0;
1082     if (RsRECORD(PL_rs))
1083       return 0;
1084     count = 0;
1085     if (SvTYPE(sv) == SVt_PVAV) {
1086         register I32 i;
1087         AV* const av = (AV*)sv;
1088         const I32 max = AvFILL(av);
1089
1090         for (i = 0; i <= max; i++) {
1091             sv = (SV*)av_fetch(av, i, FALSE);
1092             if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
1093                 count += do_chomp(sv);
1094         }
1095         return count;
1096     }
1097     else if (SvTYPE(sv) == SVt_PVHV) {
1098         HV* const hv = (HV*)sv;
1099         HE* entry;
1100         (void)hv_iterinit(hv);
1101         while ((entry = hv_iternext(hv)))
1102             count += do_chomp(hv_iterval(hv,entry));
1103         return count;
1104     }
1105     else if (SvREADONLY(sv)) {
1106         if (SvFAKE(sv)) {
1107             /* SV is copy-on-write */
1108             sv_force_normal_flags(sv, 0);
1109         }
1110         if (SvREADONLY(sv))
1111             Perl_croak(aTHX_ PL_no_modify);
1112     }
1113
1114     if (PL_encoding) {
1115         if (!SvUTF8(sv)) {
1116         /* XXX, here sv is utf8-ized as a side-effect!
1117            If encoding.pm is used properly, almost string-generating
1118            operations, including literal strings, chr(), input data, etc.
1119            should have been utf8-ized already, right?
1120         */
1121             sv_recode_to_utf8(sv, PL_encoding);
1122         }
1123     }
1124
1125     s = SvPV(sv, len);
1126     if (s && len) {
1127         s += --len;
1128         if (RsPARA(PL_rs)) {
1129             if (*s != '\n')
1130                 goto nope;
1131             ++count;
1132             while (len && s[-1] == '\n') {
1133                 --len;
1134                 --s;
1135                 ++count;
1136             }
1137         }
1138         else {
1139             STRLEN rslen, rs_charlen;
1140             const char *rsptr = SvPV_const(PL_rs, rslen);
1141
1142             rs_charlen = SvUTF8(PL_rs)
1143                 ? sv_len_utf8(PL_rs)
1144                 : rslen;
1145
1146             if (SvUTF8(PL_rs) != SvUTF8(sv)) {
1147                 /* Assumption is that rs is shorter than the scalar.  */
1148                 if (SvUTF8(PL_rs)) {
1149                     /* RS is utf8, scalar is 8 bit.  */
1150                     bool is_utf8 = TRUE;
1151                     temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
1152                                                          &rslen, &is_utf8);
1153                     if (is_utf8) {
1154                         /* Cannot downgrade, therefore cannot possibly match
1155                          */
1156                         assert (temp_buffer == rsptr);
1157                         temp_buffer = NULL;
1158                         goto nope;
1159                     }
1160                     rsptr = temp_buffer;
1161                 }
1162                 else if (PL_encoding) {
1163                     /* RS is 8 bit, encoding.pm is used.
1164                      * Do not recode PL_rs as a side-effect. */
1165                    svrecode = newSVpvn(rsptr, rslen);
1166                    sv_recode_to_utf8(svrecode, PL_encoding);
1167                    rsptr = SvPV_const(svrecode, rslen);
1168                    rs_charlen = sv_len_utf8(svrecode);
1169                 }
1170                 else {
1171                     /* RS is 8 bit, scalar is utf8.  */
1172                     temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
1173                     rsptr = temp_buffer;
1174                 }
1175             }
1176             if (rslen == 1) {
1177                 if (*s != *rsptr)
1178                     goto nope;
1179                 ++count;
1180             }
1181             else {
1182                 if (len < rslen - 1)
1183                     goto nope;
1184                 len -= rslen - 1;
1185                 s -= rslen - 1;
1186                 if (memNE(s, rsptr, rslen))
1187                     goto nope;
1188                 count += rs_charlen;
1189             }
1190         }
1191         s = SvPV_force_nolen(sv);
1192         SvCUR_set(sv, len);
1193         *SvEND(sv) = '\0';
1194         SvNIOK_off(sv);
1195         SvSETMAGIC(sv);
1196     }
1197   nope:
1198
1199     if (svrecode)
1200          SvREFCNT_dec(svrecode);
1201
1202     Safefree(temp_buffer);
1203     return count;
1204 }
1205
1206 void
1207 Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
1208 {
1209     dVAR;
1210 #ifdef LIBERAL
1211     register long *dl;
1212     register long *ll;
1213     register long *rl;
1214 #endif
1215     register char *dc;
1216     STRLEN leftlen;
1217     STRLEN rightlen;
1218     register const char *lc;
1219     register const char *rc;
1220     register STRLEN len;
1221     STRLEN lensave;
1222     const char *lsave;
1223     const char *rsave;
1224     bool left_utf;
1225     bool right_utf;
1226     STRLEN needlen = 0;
1227
1228     PERL_ARGS_ASSERT_DO_VOP;
1229
1230     if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
1231         sv_setpvn(sv, "", 0);   /* avoid undef warning on |= and ^= */
1232     lsave = lc = SvPV_nomg_const(left, leftlen);
1233     rsave = rc = SvPV_nomg_const(right, rightlen);
1234
1235     /* This need to come after SvPV to ensure that string overloading has
1236        fired off.  */
1237
1238     left_utf = DO_UTF8(left);
1239     right_utf = DO_UTF8(right);
1240
1241     if (left_utf && !right_utf) {
1242         /* Avoid triggering overloading again by using temporaries.
1243            Maybe there should be a variant of sv_utf8_upgrade that takes pvn
1244         */
1245         right = newSVpvn_flags(rsave, rightlen, SVs_TEMP);
1246         sv_utf8_upgrade(right);
1247         rsave = rc = SvPV_nomg_const(right, rightlen);
1248         right_utf = TRUE;
1249     }
1250     else if (!left_utf && right_utf) {
1251         left = newSVpvn_flags(lsave, leftlen, SVs_TEMP);
1252         sv_utf8_upgrade(left);
1253         lsave = lc = SvPV_nomg_const(left, leftlen);
1254         left_utf = TRUE;
1255     }
1256
1257     len = leftlen < rightlen ? leftlen : rightlen;
1258     lensave = len;
1259     SvCUR_set(sv, len);
1260     (void)SvPOK_only(sv);
1261     if ((left_utf || right_utf) && (sv == left || sv == right)) {
1262         needlen = optype == OP_BIT_AND ? len : leftlen + rightlen;
1263         Newxz(dc, needlen + 1, char);
1264     }
1265     else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
1266         dc = SvPV_force_nomg_nolen(sv);
1267         if (SvLEN(sv) < len + 1) {
1268             dc = SvGROW(sv, len + 1);
1269             (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
1270         }
1271         if (optype != OP_BIT_AND && (left_utf || right_utf))
1272             dc = SvGROW(sv, leftlen + rightlen + 1);
1273     }
1274     else {
1275         needlen = optype == OP_BIT_AND
1276                     ? len : (leftlen > rightlen ? leftlen : rightlen);
1277         Newxz(dc, needlen + 1, char);
1278         sv_usepvn_flags(sv, dc, needlen, SV_HAS_TRAILING_NUL);
1279         dc = SvPVX(sv);         /* sv_usepvn() calls Renew() */
1280     }
1281     if (left_utf || right_utf) {
1282         UV duc, luc, ruc;
1283         char *dcorig = dc;
1284         char *dcsave = NULL;
1285         STRLEN lulen = leftlen;
1286         STRLEN rulen = rightlen;
1287         STRLEN ulen;
1288
1289         switch (optype) {
1290         case OP_BIT_AND:
1291             while (lulen && rulen) {
1292                 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1293                 lc += ulen;
1294                 lulen -= ulen;
1295                 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1296                 rc += ulen;
1297                 rulen -= ulen;
1298                 duc = luc & ruc;
1299                 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
1300             }
1301             if (sv == left || sv == right)
1302                 (void)sv_usepvn(sv, dcorig, needlen);
1303             SvCUR_set(sv, dc - dcorig);
1304             break;
1305         case OP_BIT_XOR:
1306             while (lulen && rulen) {
1307                 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1308                 lc += ulen;
1309                 lulen -= ulen;
1310                 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1311                 rc += ulen;
1312                 rulen -= ulen;
1313                 duc = luc ^ ruc;
1314                 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
1315             }
1316             goto mop_up_utf;
1317         case OP_BIT_OR:
1318             while (lulen && rulen) {
1319                 luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1320                 lc += ulen;
1321                 lulen -= ulen;
1322                 ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1323                 rc += ulen;
1324                 rulen -= ulen;
1325                 duc = luc | ruc;
1326                 dc = (char*)uvchr_to_utf8((U8*)dc, duc);
1327             }
1328           mop_up_utf:
1329             if (rulen)
1330                 dcsave = savepvn(rc, rulen);
1331             else if (lulen)
1332                 dcsave = savepvn(lc, lulen);
1333             if (sv == left || sv == right)
1334                 (void)sv_usepvn(sv, dcorig, needlen); /* Uses Renew(). */
1335             SvCUR_set(sv, dc - dcorig);
1336             if (rulen)
1337                 sv_catpvn(sv, dcsave, rulen);
1338             else if (lulen)
1339                 sv_catpvn(sv, dcsave, lulen);
1340             else
1341                 *SvEND(sv) = '\0';
1342             Safefree(dcsave);
1343             break;
1344         default:
1345             if (sv == left || sv == right)
1346                 Safefree(dcorig);
1347             Perl_croak(aTHX_ "panic: do_vop called for op %u (%s)",
1348                         (unsigned)optype, PL_op_name[optype]);
1349         }
1350         SvUTF8_on(sv);
1351         goto finish;
1352     }
1353     else
1354 #ifdef LIBERAL
1355     if (len >= sizeof(long)*4 &&
1356         !((unsigned long)dc % sizeof(long)) &&
1357         !((unsigned long)lc % sizeof(long)) &&
1358         !((unsigned long)rc % sizeof(long)))    /* It's almost always aligned... */
1359     {
1360         const STRLEN remainder = len % (sizeof(long)*4);
1361         len /= (sizeof(long)*4);
1362
1363         dl = (long*)dc;
1364         ll = (long*)lc;
1365         rl = (long*)rc;
1366
1367         switch (optype) {
1368         case OP_BIT_AND:
1369             while (len--) {
1370                 *dl++ = *ll++ & *rl++;
1371                 *dl++ = *ll++ & *rl++;
1372                 *dl++ = *ll++ & *rl++;
1373                 *dl++ = *ll++ & *rl++;
1374             }
1375             break;
1376         case OP_BIT_XOR:
1377             while (len--) {
1378                 *dl++ = *ll++ ^ *rl++;
1379                 *dl++ = *ll++ ^ *rl++;
1380                 *dl++ = *ll++ ^ *rl++;
1381                 *dl++ = *ll++ ^ *rl++;
1382             }
1383             break;
1384         case OP_BIT_OR:
1385             while (len--) {
1386                 *dl++ = *ll++ | *rl++;
1387                 *dl++ = *ll++ | *rl++;
1388                 *dl++ = *ll++ | *rl++;
1389                 *dl++ = *ll++ | *rl++;
1390             }
1391         }
1392
1393         dc = (char*)dl;
1394         lc = (char*)ll;
1395         rc = (char*)rl;
1396
1397         len = remainder;
1398     }
1399 #endif
1400     {
1401         switch (optype) {
1402         case OP_BIT_AND:
1403             while (len--)
1404                 *dc++ = *lc++ & *rc++;
1405             *dc = '\0';
1406             break;
1407         case OP_BIT_XOR:
1408             while (len--)
1409                 *dc++ = *lc++ ^ *rc++;
1410             goto mop_up;
1411         case OP_BIT_OR:
1412             while (len--)
1413                 *dc++ = *lc++ | *rc++;
1414           mop_up:
1415             len = lensave;
1416             if (rightlen > len)
1417                 sv_catpvn(sv, rsave + len, rightlen - len);
1418             else if (leftlen > (STRLEN)len)
1419                 sv_catpvn(sv, lsave + len, leftlen - len);
1420             else
1421                 *SvEND(sv) = '\0';
1422             break;
1423         }
1424     }
1425 finish:
1426     SvTAINT(sv);
1427 }
1428
1429 OP *
1430 Perl_do_kv(pTHX)
1431 {
1432     dVAR;
1433     dSP;
1434     HV * const hv = (HV*)POPs;
1435     HV *keys;
1436     register HE *entry;
1437     const I32 gimme = GIMME_V;
1438     const I32 dokv =     (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV);
1439     const I32 dokeys =   dokv || (PL_op->op_type == OP_KEYS);
1440     const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES);
1441
1442     if (!hv) {
1443         if (PL_op->op_flags & OPf_MOD || LVRET) {       /* lvalue */
1444             dTARGET;            /* make sure to clear its target here */
1445             if (SvTYPE(TARG) == SVt_PVLV)
1446                 LvTARG(TARG) = NULL;
1447             PUSHs(TARG);
1448         }
1449         RETURN;
1450     }
1451
1452     keys = hv;
1453     (void)hv_iterinit(keys);    /* always reset iterator regardless */
1454
1455     if (gimme == G_VOID)
1456         RETURN;
1457
1458     if (gimme == G_SCALAR) {
1459         IV i;
1460         dTARGET;
1461
1462         if (PL_op->op_flags & OPf_MOD || LVRET) {       /* lvalue */
1463             if (SvTYPE(TARG) < SVt_PVLV) {
1464                 sv_upgrade(TARG, SVt_PVLV);
1465                 sv_magic(TARG, NULL, PERL_MAGIC_nkeys, NULL, 0);
1466             }
1467             LvTYPE(TARG) = 'k';
1468             if (LvTARG(TARG) != (SV*)keys) {
1469                 if (LvTARG(TARG))
1470                     SvREFCNT_dec(LvTARG(TARG));
1471                 LvTARG(TARG) = SvREFCNT_inc_simple(keys);
1472             }
1473             PUSHs(TARG);
1474             RETURN;
1475         }
1476
1477         if (! SvTIED_mg((SV*)keys, PERL_MAGIC_tied) )
1478         {
1479             i = HvKEYS(keys);
1480         }
1481         else {
1482             i = 0;
1483             while (hv_iternext(keys)) i++;
1484         }
1485         PUSHi( i );
1486         RETURN;
1487     }
1488
1489     EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
1490
1491     PUTBACK;    /* hv_iternext and hv_iterval might clobber stack_sp */
1492     while ((entry = hv_iternext(keys))) {
1493         SPAGAIN;
1494         if (dokeys) {
1495             SV* const sv = hv_iterkeysv(entry);
1496             XPUSHs(sv); /* won't clobber stack_sp */
1497         }
1498         if (dovalues) {
1499             SV *tmpstr;
1500             PUTBACK;
1501             tmpstr = hv_iterval(hv,entry);
1502             DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
1503                             (unsigned long)HeHASH(entry),
1504                             (int)HvMAX(keys)+1,
1505                             (unsigned long)(HeHASH(entry) & HvMAX(keys))));
1506             SPAGAIN;
1507             XPUSHs(tmpstr);
1508         }
1509         PUTBACK;
1510     }
1511     return NORMAL;
1512 }
1513
1514 /*
1515  * Local variables:
1516  * c-indentation-style: bsd
1517  * c-basic-offset: 4
1518  * indent-tabs-mode: t
1519  * End:
1520  *
1521  * ex: set ts=8 sts=4 sw=4 noet:
1522  */