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