doop.c

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