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