pp_hot.c revision 1.9
1/* pp_hot.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 4 * 2000, 2001, 2002, 2003, 2004, 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 * Then he heard Merry change the note, and up went the Horn-cry of Buckland, 13 * shaking the air. 14 * 15 * Awake! Awake! Fear, Fire, Foes! Awake! 16 * Fire, Foes! Awake! 17 */ 18 19#include "EXTERN.h" 20#define PERL_IN_PP_HOT_C 21#include "perl.h" 22 23/* Hot code. */ 24 25#ifdef USE_5005THREADS 26static void unset_cvowner(pTHX_ void *cvarg); 27#endif /* USE_5005THREADS */ 28 29PP(pp_const) 30{ 31 dSP; 32 XPUSHs(cSVOP_sv); 33 RETURN; 34} 35 36PP(pp_nextstate) 37{ 38 PL_curcop = (COP*)PL_op; 39 TAINT_NOT; /* Each statement is presumed innocent */ 40 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; 41 FREETMPS; 42 return NORMAL; 43} 44 45PP(pp_gvsv) 46{ 47 dSP; 48 EXTEND(SP,1); 49 if (PL_op->op_private & OPpLVAL_INTRO) 50 PUSHs(save_scalar(cGVOP_gv)); 51 else 52 PUSHs(GvSV(cGVOP_gv)); 53 RETURN; 54} 55 56PP(pp_null) 57{ 58 return NORMAL; 59} 60 61PP(pp_setstate) 62{ 63 PL_curcop = (COP*)PL_op; 64 return NORMAL; 65} 66 67PP(pp_pushmark) 68{ 69 PUSHMARK(PL_stack_sp); 70 return NORMAL; 71} 72 73PP(pp_stringify) 74{ 75 dSP; dTARGET; 76 sv_copypv(TARG,TOPs); 77 SETTARG; 78 RETURN; 79} 80 81PP(pp_gv) 82{ 83 dSP; 84 XPUSHs((SV*)cGVOP_gv); 85 RETURN; 86} 87 88PP(pp_and) 89{ 90 dSP; 91 if (!SvTRUE(TOPs)) 92 RETURN; 93 else { 94 --SP; 95 RETURNOP(cLOGOP->op_other); 96 } 97} 98 99PP(pp_sassign) 100{ 101 dSP; dPOPTOPssrl; 102 103 if (PL_op->op_private & OPpASSIGN_BACKWARDS) { 104 SV *temp; 105 temp = left; left = right; right = temp; 106 } 107 if (PL_tainting && PL_tainted && !SvTAINTED(left)) 108 TAINT_NOT; 109 SvSetMagicSV(right, left); 110 SETs(right); 111 RETURN; 112} 113 114PP(pp_cond_expr) 115{ 116 dSP; 117 if (SvTRUEx(POPs)) 118 RETURNOP(cLOGOP->op_other); 119 else 120 RETURNOP(cLOGOP->op_next); 121} 122 123PP(pp_unstack) 124{ 125 I32 oldsave; 126 TAINT_NOT; /* Each statement is presumed innocent */ 127 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; 128 FREETMPS; 129 oldsave = PL_scopestack[PL_scopestack_ix - 1]; 130 LEAVE_SCOPE(oldsave); 131 return NORMAL; 132} 133 134PP(pp_concat) 135{ 136 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN); 137 { 138 dPOPTOPssrl; 139 STRLEN llen; 140 char* lpv; 141 bool lbyte; 142 STRLEN rlen; 143 char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */ 144 bool rbyte = !DO_UTF8(right), rcopied = FALSE; 145 146 if (TARG == right && right != left) { 147 right = sv_2mortal(newSVpvn(rpv, rlen)); 148 rpv = SvPV(right, rlen); /* no point setting UTF-8 here */ 149 rcopied = TRUE; 150 } 151 152 if (TARG != left) { 153 lpv = SvPV(left, llen); /* mg_get(left) may happen here */ 154 lbyte = !DO_UTF8(left); 155 sv_setpvn(TARG, lpv, llen); 156 if (!lbyte) 157 SvUTF8_on(TARG); 158 else 159 SvUTF8_off(TARG); 160 } 161 else { /* TARG == left */ 162 if (SvGMAGICAL(left)) 163 mg_get(left); /* or mg_get(left) may happen here */ 164 if (!SvOK(TARG)) 165 sv_setpv(left, ""); 166 lpv = SvPV_nomg(left, llen); 167 lbyte = !DO_UTF8(left); 168 if (IN_BYTES) 169 SvUTF8_off(TARG); 170 } 171 172#if defined(PERL_Y2KWARN) 173 if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) { 174 if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9' 175 && (llen == 2 || !isDIGIT(lpv[llen - 3]))) 176 { 177 Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s", 178 "about to append an integer to '19'"); 179 } 180 } 181#endif 182 183 if (lbyte != rbyte) { 184 if (lbyte) 185 sv_utf8_upgrade_nomg(TARG); 186 else { 187 if (!rcopied) 188 right = sv_2mortal(newSVpvn(rpv, rlen)); 189 sv_utf8_upgrade_nomg(right); 190 rpv = SvPV(right, rlen); 191 } 192 } 193 sv_catpvn_nomg(TARG, rpv, rlen); 194 195 SETTARG; 196 RETURN; 197 } 198} 199 200PP(pp_padsv) 201{ 202 dSP; dTARGET; 203 XPUSHs(TARG); 204 if (PL_op->op_flags & OPf_MOD) { 205 if (PL_op->op_private & OPpLVAL_INTRO) 206 SAVECLEARSV(PAD_SVl(PL_op->op_targ)); 207 else if (PL_op->op_private & OPpDEREF) { 208 PUTBACK; 209 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF); 210 SPAGAIN; 211 } 212 } 213 RETURN; 214} 215 216PP(pp_readline) 217{ 218 tryAMAGICunTARGET(iter, 0); 219 PL_last_in_gv = (GV*)(*PL_stack_sp--); 220 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) { 221 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV) 222 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv); 223 else { 224 dSP; 225 XPUSHs((SV*)PL_last_in_gv); 226 PUTBACK; 227 pp_rv2gv(); 228 PL_last_in_gv = (GV*)(*PL_stack_sp--); 229 } 230 } 231 return do_readline(); 232} 233 234PP(pp_eq) 235{ 236 dSP; tryAMAGICbinSET(eq,0); 237#ifndef NV_PRESERVES_UV 238 if (SvROK(TOPs) && SvROK(TOPm1s)) { 239 SP--; 240 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s))); 241 RETURN; 242 } 243#endif 244#ifdef PERL_PRESERVE_IVUV 245 SvIV_please(TOPs); 246 if (SvIOK(TOPs)) { 247 /* Unless the left argument is integer in range we are going 248 to have to use NV maths. Hence only attempt to coerce the 249 right argument if we know the left is integer. */ 250 SvIV_please(TOPm1s); 251 if (SvIOK(TOPm1s)) { 252 bool auvok = SvUOK(TOPm1s); 253 bool buvok = SvUOK(TOPs); 254 255 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */ 256 /* Casting IV to UV before comparison isn't going to matter 257 on 2s complement. On 1s complement or sign&magnitude 258 (if we have any of them) it could to make negative zero 259 differ from normal zero. As I understand it. (Need to 260 check - is negative zero implementation defined behaviour 261 anyway?). NWC */ 262 UV buv = SvUVX(POPs); 263 UV auv = SvUVX(TOPs); 264 265 SETs(boolSV(auv == buv)); 266 RETURN; 267 } 268 { /* ## Mixed IV,UV ## */ 269 SV *ivp, *uvp; 270 IV iv; 271 272 /* == is commutative so doesn't matter which is left or right */ 273 if (auvok) { 274 /* top of stack (b) is the iv */ 275 ivp = *SP; 276 uvp = *--SP; 277 } else { 278 uvp = *SP; 279 ivp = *--SP; 280 } 281 iv = SvIVX(ivp); 282 if (iv < 0) { 283 /* As uv is a UV, it's >0, so it cannot be == */ 284 SETs(&PL_sv_no); 285 RETURN; 286 } 287 /* we know iv is >= 0 */ 288 SETs(boolSV((UV)iv == SvUVX(uvp))); 289 RETURN; 290 } 291 } 292 } 293#endif 294 { 295 dPOPnv; 296 SETs(boolSV(TOPn == value)); 297 RETURN; 298 } 299} 300 301PP(pp_preinc) 302{ 303 dSP; 304 if (SvTYPE(TOPs) > SVt_PVLV) 305 DIE(aTHX_ PL_no_modify); 306 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) 307 && SvIVX(TOPs) != IV_MAX) 308 { 309 ++SvIVX(TOPs); 310 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); 311 } 312 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */ 313 sv_inc(TOPs); 314 SvSETMAGIC(TOPs); 315 return NORMAL; 316} 317 318PP(pp_or) 319{ 320 dSP; 321 if (SvTRUE(TOPs)) 322 RETURN; 323 else { 324 --SP; 325 RETURNOP(cLOGOP->op_other); 326 } 327} 328 329PP(pp_add) 330{ 331 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN); 332 useleft = USE_LEFT(TOPm1s); 333#ifdef PERL_PRESERVE_IVUV 334 /* We must see if we can perform the addition with integers if possible, 335 as the integer code detects overflow while the NV code doesn't. 336 If either argument hasn't had a numeric conversion yet attempt to get 337 the IV. It's important to do this now, rather than just assuming that 338 it's not IOK as a PV of "9223372036854775806" may not take well to NV 339 addition, and an SV which is NOK, NV=6.0 ought to be coerced to 340 integer in case the second argument is IV=9223372036854775806 341 We can (now) rely on sv_2iv to do the right thing, only setting the 342 public IOK flag if the value in the NV (or PV) slot is truly integer. 343 344 A side effect is that this also aggressively prefers integer maths over 345 fp maths for integer values. 346 347 How to detect overflow? 348 349 C 99 section 6.2.6.1 says 350 351 The range of nonnegative values of a signed integer type is a subrange 352 of the corresponding unsigned integer type, and the representation of 353 the same value in each type is the same. A computation involving 354 unsigned operands can never overflow, because a result that cannot be 355 represented by the resulting unsigned integer type is reduced modulo 356 the number that is one greater than the largest value that can be 357 represented by the resulting type. 358 359 (the 9th paragraph) 360 361 which I read as "unsigned ints wrap." 362 363 signed integer overflow seems to be classed as "exception condition" 364 365 If an exceptional condition occurs during the evaluation of an 366 expression (that is, if the result is not mathematically defined or not 367 in the range of representable values for its type), the behavior is 368 undefined. 369 370 (6.5, the 5th paragraph) 371 372 I had assumed that on 2s complement machines signed arithmetic would 373 wrap, hence coded pp_add and pp_subtract on the assumption that 374 everything perl builds on would be happy. After much wailing and 375 gnashing of teeth it would seem that irix64 knows its ANSI spec well, 376 knows that it doesn't need to, and doesn't. Bah. Anyway, the all- 377 unsigned code below is actually shorter than the old code. :-) 378 */ 379 380 SvIV_please(TOPs); 381 if (SvIOK(TOPs)) { 382 /* Unless the left argument is integer in range we are going to have to 383 use NV maths. Hence only attempt to coerce the right argument if 384 we know the left is integer. */ 385 register UV auv = 0; 386 bool auvok = FALSE; 387 bool a_valid = 0; 388 389 if (!useleft) { 390 auv = 0; 391 a_valid = auvok = 1; 392 /* left operand is undef, treat as zero. + 0 is identity, 393 Could SETi or SETu right now, but space optimise by not adding 394 lots of code to speed up what is probably a rarish case. */ 395 } else { 396 /* Left operand is defined, so is it IV? */ 397 SvIV_please(TOPm1s); 398 if (SvIOK(TOPm1s)) { 399 if ((auvok = SvUOK(TOPm1s))) 400 auv = SvUVX(TOPm1s); 401 else { 402 register IV aiv = SvIVX(TOPm1s); 403 if (aiv >= 0) { 404 auv = aiv; 405 auvok = 1; /* Now acting as a sign flag. */ 406 } else { /* 2s complement assumption for IV_MIN */ 407 auv = (UV)-aiv; 408 } 409 } 410 a_valid = 1; 411 } 412 } 413 if (a_valid) { 414 bool result_good = 0; 415 UV result; 416 register UV buv; 417 bool buvok = SvUOK(TOPs); 418 419 if (buvok) 420 buv = SvUVX(TOPs); 421 else { 422 register IV biv = SvIVX(TOPs); 423 if (biv >= 0) { 424 buv = biv; 425 buvok = 1; 426 } else 427 buv = (UV)-biv; 428 } 429 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, 430 else "IV" now, independent of how it came in. 431 if a, b represents positive, A, B negative, a maps to -A etc 432 a + b => (a + b) 433 A + b => -(a - b) 434 a + B => (a - b) 435 A + B => -(a + b) 436 all UV maths. negate result if A negative. 437 add if signs same, subtract if signs differ. */ 438 439 if (auvok ^ buvok) { 440 /* Signs differ. */ 441 if (auv >= buv) { 442 result = auv - buv; 443 /* Must get smaller */ 444 if (result <= auv) 445 result_good = 1; 446 } else { 447 result = buv - auv; 448 if (result <= buv) { 449 /* result really should be -(auv-buv). as its negation 450 of true value, need to swap our result flag */ 451 auvok = !auvok; 452 result_good = 1; 453 } 454 } 455 } else { 456 /* Signs same */ 457 result = auv + buv; 458 if (result >= auv) 459 result_good = 1; 460 } 461 if (result_good) { 462 SP--; 463 if (auvok) 464 SETu( result ); 465 else { 466 /* Negate result */ 467 if (result <= (UV)IV_MIN) 468 SETi( -(IV)result ); 469 else { 470 /* result valid, but out of range for IV. */ 471 SETn( -(NV)result ); 472 } 473 } 474 RETURN; 475 } /* Overflow, drop through to NVs. */ 476 } 477 } 478#endif 479 { 480 dPOPnv; 481 if (!useleft) { 482 /* left operand is undef, treat as zero. + 0.0 is identity. */ 483 SETn(value); 484 RETURN; 485 } 486 SETn( value + TOPn ); 487 RETURN; 488 } 489} 490 491PP(pp_aelemfast) 492{ 493 dSP; 494 AV *av = PL_op->op_flags & OPf_SPECIAL ? 495 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv); 496 U32 lval = PL_op->op_flags & OPf_MOD; 497 SV** svp = av_fetch(av, PL_op->op_private, lval); 498 SV *sv = (svp ? *svp : &PL_sv_undef); 499 EXTEND(SP, 1); 500 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */ 501 sv = sv_mortalcopy(sv); 502 PUSHs(sv); 503 RETURN; 504} 505 506PP(pp_join) 507{ 508 dSP; dMARK; dTARGET; 509 MARK++; 510 do_join(TARG, *MARK, MARK, SP); 511 SP = MARK; 512 SETs(TARG); 513 RETURN; 514} 515 516PP(pp_pushre) 517{ 518 dSP; 519#ifdef DEBUGGING 520 /* 521 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs 522 * will be enough to hold an OP*. 523 */ 524 SV* sv = sv_newmortal(); 525 sv_upgrade(sv, SVt_PVLV); 526 LvTYPE(sv) = '/'; 527 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*); 528 XPUSHs(sv); 529#else 530 XPUSHs((SV*)PL_op); 531#endif 532 RETURN; 533} 534 535/* Oversized hot code. */ 536 537PP(pp_print) 538{ 539 dSP; dMARK; dORIGMARK; 540 GV *gv; 541 IO *io; 542 register PerlIO *fp; 543 MAGIC *mg; 544 545 if (PL_op->op_flags & OPf_STACKED) 546 gv = (GV*)*++MARK; 547 else 548 gv = PL_defoutgv; 549 550 if (gv && (io = GvIO(gv)) 551 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 552 { 553 had_magic: 554 if (MARK == ORIGMARK) { 555 /* If using default handle then we need to make space to 556 * pass object as 1st arg, so move other args up ... 557 */ 558 MEXTEND(SP, 1); 559 ++MARK; 560 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); 561 ++SP; 562 } 563 PUSHMARK(MARK - 1); 564 *MARK = SvTIED_obj((SV*)io, mg); 565 PUTBACK; 566 ENTER; 567 call_method("PRINT", G_SCALAR); 568 LEAVE; 569 SPAGAIN; 570 MARK = ORIGMARK + 1; 571 *MARK = *SP; 572 SP = MARK; 573 RETURN; 574 } 575 if (!(io = GvIO(gv))) { 576 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv))) 577 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 578 goto had_magic; 579 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) 580 report_evil_fh(gv, io, PL_op->op_type); 581 SETERRNO(EBADF,RMS_IFI); 582 goto just_say_no; 583 } 584 else if (!(fp = IoOFP(io))) { 585 if (ckWARN2(WARN_CLOSED, WARN_IO)) { 586 if (IoIFP(io)) 587 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); 588 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) 589 report_evil_fh(gv, io, PL_op->op_type); 590 } 591 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); 592 goto just_say_no; 593 } 594 else { 595 MARK++; 596 if (PL_ofs_sv && SvOK(PL_ofs_sv)) { 597 while (MARK <= SP) { 598 if (!do_print(*MARK, fp)) 599 break; 600 MARK++; 601 if (MARK <= SP) { 602 if (!do_print(PL_ofs_sv, fp)) { /* $, */ 603 MARK--; 604 break; 605 } 606 } 607 } 608 } 609 else { 610 while (MARK <= SP) { 611 if (!do_print(*MARK, fp)) 612 break; 613 MARK++; 614 } 615 } 616 if (MARK <= SP) 617 goto just_say_no; 618 else { 619 if (PL_ors_sv && SvOK(PL_ors_sv)) 620 if (!do_print(PL_ors_sv, fp)) /* $\ */ 621 goto just_say_no; 622 623 if (IoFLAGS(io) & IOf_FLUSH) 624 if (PerlIO_flush(fp) == EOF) 625 goto just_say_no; 626 } 627 } 628 SP = ORIGMARK; 629 PUSHs(&PL_sv_yes); 630 RETURN; 631 632 just_say_no: 633 SP = ORIGMARK; 634 PUSHs(&PL_sv_undef); 635 RETURN; 636} 637 638PP(pp_rv2av) 639{ 640 dSP; dTOPss; 641 AV *av; 642 643 if (SvROK(sv)) { 644 wasref: 645 tryAMAGICunDEREF(to_av); 646 647 av = (AV*)SvRV(sv); 648 if (SvTYPE(av) != SVt_PVAV) 649 DIE(aTHX_ "Not an ARRAY reference"); 650 if (PL_op->op_flags & OPf_REF) { 651 SETs((SV*)av); 652 RETURN; 653 } 654 else if (LVRET) { 655 if (GIMME == G_SCALAR) 656 Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); 657 SETs((SV*)av); 658 RETURN; 659 } 660 else if (PL_op->op_flags & OPf_MOD 661 && PL_op->op_private & OPpLVAL_INTRO) 662 Perl_croak(aTHX_ PL_no_localize_ref); 663 } 664 else { 665 if (SvTYPE(sv) == SVt_PVAV) { 666 av = (AV*)sv; 667 if (PL_op->op_flags & OPf_REF) { 668 SETs((SV*)av); 669 RETURN; 670 } 671 else if (LVRET) { 672 if (GIMME == G_SCALAR) 673 Perl_croak(aTHX_ "Can't return array to lvalue" 674 " scalar context"); 675 SETs((SV*)av); 676 RETURN; 677 } 678 } 679 else { 680 GV *gv; 681 682 if (SvTYPE(sv) != SVt_PVGV) { 683 char *sym; 684 STRLEN len; 685 686 if (SvGMAGICAL(sv)) { 687 mg_get(sv); 688 if (SvROK(sv)) 689 goto wasref; 690 } 691 if (!SvOK(sv)) { 692 if (PL_op->op_flags & OPf_REF || 693 PL_op->op_private & HINT_STRICT_REFS) 694 DIE(aTHX_ PL_no_usym, "an ARRAY"); 695 if (ckWARN(WARN_UNINITIALIZED)) 696 report_uninit(); 697 if (GIMME == G_ARRAY) { 698 (void)POPs; 699 RETURN; 700 } 701 RETSETUNDEF; 702 } 703 sym = SvPV(sv,len); 704 if ((PL_op->op_flags & OPf_SPECIAL) && 705 !(PL_op->op_flags & OPf_MOD)) 706 { 707 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV); 708 if (!gv 709 && (!is_gv_magical(sym,len,0) 710 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV)))) 711 { 712 RETSETUNDEF; 713 } 714 } 715 else { 716 if (PL_op->op_private & HINT_STRICT_REFS) 717 DIE(aTHX_ PL_no_symref, sym, "an ARRAY"); 718 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV); 719 } 720 } 721 else { 722 gv = (GV*)sv; 723 } 724 av = GvAVn(gv); 725 if (PL_op->op_private & OPpLVAL_INTRO) 726 av = save_ary(gv); 727 if (PL_op->op_flags & OPf_REF) { 728 SETs((SV*)av); 729 RETURN; 730 } 731 else if (LVRET) { 732 if (GIMME == G_SCALAR) 733 Perl_croak(aTHX_ "Can't return array to lvalue" 734 " scalar context"); 735 SETs((SV*)av); 736 RETURN; 737 } 738 } 739 } 740 741 if (GIMME == G_ARRAY) { 742 I32 maxarg = AvFILL(av) + 1; 743 (void)POPs; /* XXXX May be optimized away? */ 744 EXTEND(SP, maxarg); 745 if (SvRMAGICAL(av)) { 746 U32 i; 747 for (i=0; i < (U32)maxarg; i++) { 748 SV **svp = av_fetch(av, i, FALSE); 749 /* See note in pp_helem, and bug id #27839 */ 750 SP[i+1] = svp 751 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp 752 : &PL_sv_undef; 753 } 754 } 755 else { 756 Copy(AvARRAY(av), SP+1, maxarg, SV*); 757 } 758 SP += maxarg; 759 } 760 else if (GIMME_V == G_SCALAR) { 761 dTARGET; 762 I32 maxarg = AvFILL(av) + 1; 763 SETi(maxarg); 764 } 765 RETURN; 766} 767 768PP(pp_rv2hv) 769{ 770 dSP; dTOPss; 771 HV *hv; 772 I32 gimme = GIMME_V; 773 774 if (SvROK(sv)) { 775 wasref: 776 tryAMAGICunDEREF(to_hv); 777 778 hv = (HV*)SvRV(sv); 779 if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV) 780 DIE(aTHX_ "Not a HASH reference"); 781 if (PL_op->op_flags & OPf_REF) { 782 SETs((SV*)hv); 783 RETURN; 784 } 785 else if (LVRET) { 786 if (gimme != G_ARRAY) 787 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); 788 SETs((SV*)hv); 789 RETURN; 790 } 791 else if (PL_op->op_flags & OPf_MOD 792 && PL_op->op_private & OPpLVAL_INTRO) 793 Perl_croak(aTHX_ PL_no_localize_ref); 794 } 795 else { 796 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) { 797 hv = (HV*)sv; 798 if (PL_op->op_flags & OPf_REF) { 799 SETs((SV*)hv); 800 RETURN; 801 } 802 else if (LVRET) { 803 if (gimme != G_ARRAY) 804 Perl_croak(aTHX_ "Can't return hash to lvalue" 805 " scalar context"); 806 SETs((SV*)hv); 807 RETURN; 808 } 809 } 810 else { 811 GV *gv; 812 813 if (SvTYPE(sv) != SVt_PVGV) { 814 char *sym; 815 STRLEN len; 816 817 if (SvGMAGICAL(sv)) { 818 mg_get(sv); 819 if (SvROK(sv)) 820 goto wasref; 821 } 822 if (!SvOK(sv)) { 823 if (PL_op->op_flags & OPf_REF || 824 PL_op->op_private & HINT_STRICT_REFS) 825 DIE(aTHX_ PL_no_usym, "a HASH"); 826 if (ckWARN(WARN_UNINITIALIZED)) 827 report_uninit(); 828 if (gimme == G_ARRAY) { 829 SP--; 830 RETURN; 831 } 832 RETSETUNDEF; 833 } 834 sym = SvPV(sv,len); 835 if ((PL_op->op_flags & OPf_SPECIAL) && 836 !(PL_op->op_flags & OPf_MOD)) 837 { 838 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV); 839 if (!gv 840 && (!is_gv_magical(sym,len,0) 841 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV)))) 842 { 843 RETSETUNDEF; 844 } 845 } 846 else { 847 if (PL_op->op_private & HINT_STRICT_REFS) 848 DIE(aTHX_ PL_no_symref, sym, "a HASH"); 849 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV); 850 } 851 } 852 else { 853 gv = (GV*)sv; 854 } 855 hv = GvHVn(gv); 856 if (PL_op->op_private & OPpLVAL_INTRO) 857 hv = save_hash(gv); 858 if (PL_op->op_flags & OPf_REF) { 859 SETs((SV*)hv); 860 RETURN; 861 } 862 else if (LVRET) { 863 if (gimme != G_ARRAY) 864 Perl_croak(aTHX_ "Can't return hash to lvalue" 865 " scalar context"); 866 SETs((SV*)hv); 867 RETURN; 868 } 869 } 870 } 871 872 if (gimme == G_ARRAY) { /* array wanted */ 873 *PL_stack_sp = (SV*)hv; 874 return do_kv(); 875 } 876 else if (gimme == G_SCALAR) { 877 dTARGET; 878 879 if (SvTYPE(hv) == SVt_PVAV) 880 hv = avhv_keys((AV*)hv); 881 882 TARG = Perl_hv_scalar(aTHX_ hv); 883 SETTARG; 884 } 885 RETURN; 886} 887 888STATIC int 889S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem, 890 SV **lastrelem) 891{ 892 OP *leftop; 893 I32 i; 894 895 leftop = ((BINOP*)PL_op)->op_last; 896 assert(leftop); 897 assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST); 898 leftop = ((LISTOP*)leftop)->op_first; 899 assert(leftop); 900 /* Skip PUSHMARK and each element already assigned to. */ 901 for (i = lelem - firstlelem; i > 0; i--) { 902 leftop = leftop->op_sibling; 903 assert(leftop); 904 } 905 if (leftop->op_type != OP_RV2HV) 906 return 0; 907 908 /* pseudohash */ 909 if (av_len(ary) > 0) 910 av_fill(ary, 0); /* clear all but the fields hash */ 911 if (lastrelem >= relem) { 912 while (relem < lastrelem) { /* gobble up all the rest */ 913 SV *tmpstr; 914 assert(relem[0]); 915 assert(relem[1]); 916 /* Avoid a memory leak when avhv_store_ent dies. */ 917 tmpstr = sv_newmortal(); 918 sv_setsv(tmpstr,relem[1]); /* value */ 919 relem[1] = tmpstr; 920 if (avhv_store_ent(ary,relem[0],tmpstr,0)) 921 (void)SvREFCNT_inc(tmpstr); 922 if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr)) 923 mg_set(tmpstr); 924 relem += 2; 925 TAINT_NOT; 926 } 927 } 928 if (relem == lastrelem) 929 return 1; 930 return 2; 931} 932 933STATIC void 934S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) 935{ 936 if (*relem) { 937 SV *tmpstr; 938 if (ckWARN(WARN_MISC)) { 939 if (relem == firstrelem && 940 SvROK(*relem) && 941 (SvTYPE(SvRV(*relem)) == SVt_PVAV || 942 SvTYPE(SvRV(*relem)) == SVt_PVHV)) 943 { 944 Perl_warner(aTHX_ packWARN(WARN_MISC), 945 "Reference found where even-sized list expected"); 946 } 947 else 948 Perl_warner(aTHX_ packWARN(WARN_MISC), 949 "Odd number of elements in hash assignment"); 950 } 951 if (SvTYPE(hash) == SVt_PVAV) { 952 /* pseudohash */ 953 tmpstr = sv_newmortal(); 954 if (avhv_store_ent((AV*)hash,*relem,tmpstr,0)) 955 (void)SvREFCNT_inc(tmpstr); 956 if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr)) 957 mg_set(tmpstr); 958 } 959 else { 960 HE *didstore; 961 tmpstr = NEWSV(29,0); 962 didstore = hv_store_ent(hash,*relem,tmpstr,0); 963 if (SvMAGICAL(hash)) { 964 if (SvSMAGICAL(tmpstr)) 965 mg_set(tmpstr); 966 if (!didstore) 967 sv_2mortal(tmpstr); 968 } 969 } 970 TAINT_NOT; 971 } 972} 973 974PP(pp_aassign) 975{ 976 dSP; 977 SV **lastlelem = PL_stack_sp; 978 SV **lastrelem = PL_stack_base + POPMARK; 979 SV **firstrelem = PL_stack_base + POPMARK + 1; 980 SV **firstlelem = lastrelem + 1; 981 982 register SV **relem; 983 register SV **lelem; 984 985 register SV *sv; 986 register AV *ary; 987 988 I32 gimme; 989 HV *hash; 990 I32 i; 991 int magic; 992 int duplicates = 0; 993 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */ 994 995 996 PL_delaymagic = DM_DELAY; /* catch simultaneous items */ 997 gimme = GIMME_V; 998 999 /* If there's a common identifier on both sides we have to take 1000 * special care that assigning the identifier on the left doesn't 1001 * clobber a value on the right that's used later in the list. 1002 */ 1003 if (PL_op->op_private & (OPpASSIGN_COMMON)) { 1004 EXTEND_MORTAL(lastrelem - firstrelem + 1); 1005 for (relem = firstrelem; relem <= lastrelem; relem++) { 1006 /*SUPPRESS 560*/ 1007 if ((sv = *relem)) { 1008 TAINT_NOT; /* Each item is independent */ 1009 *relem = sv_mortalcopy(sv); 1010 } 1011 } 1012 } 1013 1014 relem = firstrelem; 1015 lelem = firstlelem; 1016 ary = Null(AV*); 1017 hash = Null(HV*); 1018 1019 while (lelem <= lastlelem) { 1020 TAINT_NOT; /* Each item stands on its own, taintwise. */ 1021 sv = *lelem++; 1022 switch (SvTYPE(sv)) { 1023 case SVt_PVAV: 1024 ary = (AV*)sv; 1025 magic = SvMAGICAL(ary) != 0; 1026 if (PL_op->op_private & OPpASSIGN_HASH) { 1027 switch (do_maybe_phash(ary, lelem, firstlelem, relem, 1028 lastrelem)) 1029 { 1030 case 0: 1031 goto normal_array; 1032 case 1: 1033 do_oddball((HV*)ary, relem, firstrelem); 1034 } 1035 relem = lastrelem + 1; 1036 break; 1037 } 1038 normal_array: 1039 av_clear(ary); 1040 av_extend(ary, lastrelem - relem); 1041 i = 0; 1042 while (relem <= lastrelem) { /* gobble up all the rest */ 1043 SV **didstore; 1044 sv = NEWSV(28,0); 1045 assert(*relem); 1046 sv_setsv(sv,*relem); 1047 *(relem++) = sv; 1048 didstore = av_store(ary,i++,sv); 1049 if (magic) { 1050 if (SvSMAGICAL(sv)) 1051 mg_set(sv); 1052 if (!didstore) 1053 sv_2mortal(sv); 1054 } 1055 TAINT_NOT; 1056 } 1057 break; 1058 case SVt_PVHV: { /* normal hash */ 1059 SV *tmpstr; 1060 1061 hash = (HV*)sv; 1062 magic = SvMAGICAL(hash) != 0; 1063 hv_clear(hash); 1064 firsthashrelem = relem; 1065 1066 while (relem < lastrelem) { /* gobble up all the rest */ 1067 HE *didstore; 1068 if (*relem) 1069 sv = *(relem++); 1070 else 1071 sv = &PL_sv_no, relem++; 1072 tmpstr = NEWSV(29,0); 1073 if (*relem) 1074 sv_setsv(tmpstr,*relem); /* value */ 1075 *(relem++) = tmpstr; 1076 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0)) 1077 /* key overwrites an existing entry */ 1078 duplicates += 2; 1079 didstore = hv_store_ent(hash,sv,tmpstr,0); 1080 if (magic) { 1081 if (SvSMAGICAL(tmpstr)) 1082 mg_set(tmpstr); 1083 if (!didstore) 1084 sv_2mortal(tmpstr); 1085 } 1086 TAINT_NOT; 1087 } 1088 if (relem == lastrelem) { 1089 do_oddball(hash, relem, firstrelem); 1090 relem++; 1091 } 1092 } 1093 break; 1094 default: 1095 if (SvIMMORTAL(sv)) { 1096 if (relem <= lastrelem) 1097 relem++; 1098 break; 1099 } 1100 if (relem <= lastrelem) { 1101 sv_setsv(sv, *relem); 1102 *(relem++) = sv; 1103 } 1104 else 1105 sv_setsv(sv, &PL_sv_undef); 1106 SvSETMAGIC(sv); 1107 break; 1108 } 1109 } 1110 if (PL_delaymagic & ~DM_DELAY) { 1111 if (PL_delaymagic & DM_UID) { 1112#ifdef HAS_SETRESUID 1113 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1, 1114 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1, 1115 (Uid_t)-1); 1116#else 1117# ifdef HAS_SETREUID 1118 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1, 1119 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1); 1120# else 1121# ifdef HAS_SETRUID 1122 if ((PL_delaymagic & DM_UID) == DM_RUID) { 1123 (void)setruid(PL_uid); 1124 PL_delaymagic &= ~DM_RUID; 1125 } 1126# endif /* HAS_SETRUID */ 1127# ifdef HAS_SETEUID 1128 if ((PL_delaymagic & DM_UID) == DM_EUID) { 1129 (void)seteuid(PL_euid); 1130 PL_delaymagic &= ~DM_EUID; 1131 } 1132# endif /* HAS_SETEUID */ 1133 if (PL_delaymagic & DM_UID) { 1134 if (PL_uid != PL_euid) 1135 DIE(aTHX_ "No setreuid available"); 1136 (void)PerlProc_setuid(PL_uid); 1137 } 1138# endif /* HAS_SETREUID */ 1139#endif /* HAS_SETRESUID */ 1140 PL_uid = PerlProc_getuid(); 1141 PL_euid = PerlProc_geteuid(); 1142 } 1143 if (PL_delaymagic & DM_GID) { 1144#ifdef HAS_SETRESGID 1145 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1, 1146 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1, 1147 (Gid_t)-1); 1148#else 1149# ifdef HAS_SETREGID 1150 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1, 1151 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1); 1152# else 1153# ifdef HAS_SETRGID 1154 if ((PL_delaymagic & DM_GID) == DM_RGID) { 1155 (void)setrgid(PL_gid); 1156 PL_delaymagic &= ~DM_RGID; 1157 } 1158# endif /* HAS_SETRGID */ 1159# ifdef HAS_SETEGID 1160 if ((PL_delaymagic & DM_GID) == DM_EGID) { 1161 (void)setegid(PL_egid); 1162 PL_delaymagic &= ~DM_EGID; 1163 } 1164# endif /* HAS_SETEGID */ 1165 if (PL_delaymagic & DM_GID) { 1166 if (PL_gid != PL_egid) 1167 DIE(aTHX_ "No setregid available"); 1168 (void)PerlProc_setgid(PL_gid); 1169 } 1170# endif /* HAS_SETREGID */ 1171#endif /* HAS_SETRESGID */ 1172 PL_gid = PerlProc_getgid(); 1173 PL_egid = PerlProc_getegid(); 1174 } 1175 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); 1176 } 1177 PL_delaymagic = 0; 1178 1179 if (gimme == G_VOID) 1180 SP = firstrelem - 1; 1181 else if (gimme == G_SCALAR) { 1182 dTARGET; 1183 SP = firstrelem; 1184 SETi(lastrelem - firstrelem + 1 - duplicates); 1185 } 1186 else { 1187 if (ary) 1188 SP = lastrelem; 1189 else if (hash) { 1190 if (duplicates) { 1191 /* Removes from the stack the entries which ended up as 1192 * duplicated keys in the hash (fix for [perl #24380]) */ 1193 Move(firsthashrelem + duplicates, 1194 firsthashrelem, duplicates, SV**); 1195 lastrelem -= duplicates; 1196 } 1197 SP = lastrelem; 1198 } 1199 else 1200 SP = firstrelem + (lastlelem - firstlelem); 1201 lelem = firstlelem + (relem - firstrelem); 1202 while (relem <= SP) 1203 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef; 1204 } 1205 RETURN; 1206} 1207 1208PP(pp_qr) 1209{ 1210 dSP; 1211 register PMOP *pm = cPMOP; 1212 SV *rv = sv_newmortal(); 1213 SV *sv = newSVrv(rv, "Regexp"); 1214 if (pm->op_pmdynflags & PMdf_TAINTED) 1215 SvTAINTED_on(rv); 1216 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0); 1217 RETURNX(PUSHs(rv)); 1218} 1219 1220PP(pp_match) 1221{ 1222 dSP; dTARG; 1223 register PMOP *pm = cPMOP; 1224 PMOP *dynpm = pm; 1225 register char *t; 1226 register char *s; 1227 char *strend; 1228 I32 global; 1229 I32 r_flags = REXEC_CHECKED; 1230 char *truebase; /* Start of string */ 1231 register REGEXP *rx = PM_GETRE(pm); 1232 bool rxtainted; 1233 I32 gimme = GIMME; 1234 STRLEN len; 1235 I32 minmatch = 0; 1236 I32 oldsave = PL_savestack_ix; 1237 I32 update_minmatch = 1; 1238 I32 had_zerolen = 0; 1239 1240 if (PL_op->op_flags & OPf_STACKED) 1241 TARG = POPs; 1242 else { 1243 TARG = DEFSV; 1244 EXTEND(SP,1); 1245 } 1246 1247 PUTBACK; /* EVAL blocks need stack_sp. */ 1248 s = SvPV(TARG, len); 1249 strend = s + len; 1250 if (!s) 1251 DIE(aTHX_ "panic: pp_match"); 1252 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || 1253 (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); 1254 TAINT_NOT; 1255 1256 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG)); 1257 1258 /* PMdf_USED is set after a ?? matches once */ 1259 if (pm->op_pmdynflags & PMdf_USED) { 1260 failure: 1261 if (gimme == G_ARRAY) 1262 RETURN; 1263 RETPUSHNO; 1264 } 1265 1266 /* empty pattern special-cased to use last successful pattern if possible */ 1267 if (!rx->prelen && PL_curpm) { 1268 pm = PL_curpm; 1269 rx = PM_GETRE(pm); 1270 } 1271 1272 if (rx->minlen > (I32)len) 1273 goto failure; 1274 1275 truebase = t = s; 1276 1277 /* XXXX What part of this is needed with true \G-support? */ 1278 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) { 1279 rx->startp[0] = -1; 1280 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { 1281 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global); 1282 if (mg && mg->mg_len >= 0) { 1283 if (!(rx->reganch & ROPT_GPOS_SEEN)) 1284 rx->endp[0] = rx->startp[0] = mg->mg_len; 1285 else if (rx->reganch & ROPT_ANCH_GPOS) { 1286 r_flags |= REXEC_IGNOREPOS; 1287 rx->endp[0] = rx->startp[0] = mg->mg_len; 1288 } 1289 minmatch = (mg->mg_flags & MGf_MINMATCH); 1290 update_minmatch = 0; 1291 } 1292 } 1293 } 1294 if ((!global && rx->nparens) 1295 || SvTEMP(TARG) || PL_sawampersand) 1296 r_flags |= REXEC_COPY_STR; 1297 if (SvSCREAM(TARG)) 1298 r_flags |= REXEC_SCREAM; 1299 1300 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { 1301 SAVEINT(PL_multiline); 1302 PL_multiline = pm->op_pmflags & PMf_MULTILINE; 1303 } 1304 1305play_it_again: 1306 if (global && rx->startp[0] != -1) { 1307 t = s = rx->endp[0] + truebase; 1308 if ((s + rx->minlen) > strend) 1309 goto nope; 1310 if (update_minmatch++) 1311 minmatch = had_zerolen; 1312 } 1313 if (rx->reganch & RE_USE_INTUIT && 1314 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) { 1315 PL_bostr = truebase; 1316 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); 1317 1318 if (!s) 1319 goto nope; 1320 if ( (rx->reganch & ROPT_CHECK_ALL) 1321 && !PL_sawampersand 1322 && ((rx->reganch & ROPT_NOSCAN) 1323 || !((rx->reganch & RE_INTUIT_TAIL) 1324 && (r_flags & REXEC_SCREAM))) 1325 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */ 1326 goto yup; 1327 } 1328 if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags)) 1329 { 1330 PL_curpm = pm; 1331 if (dynpm->op_pmflags & PMf_ONCE) 1332 dynpm->op_pmdynflags |= PMdf_USED; 1333 goto gotcha; 1334 } 1335 else 1336 goto ret_no; 1337 /*NOTREACHED*/ 1338 1339 gotcha: 1340 if (rxtainted) 1341 RX_MATCH_TAINTED_on(rx); 1342 TAINT_IF(RX_MATCH_TAINTED(rx)); 1343 if (gimme == G_ARRAY) { 1344 I32 nparens, i, len; 1345 1346 nparens = rx->nparens; 1347 if (global && !nparens) 1348 i = 1; 1349 else 1350 i = 0; 1351 SPAGAIN; /* EVAL blocks could move the stack. */ 1352 EXTEND(SP, nparens + i); 1353 EXTEND_MORTAL(nparens + i); 1354 for (i = !i; i <= nparens; i++) { 1355 PUSHs(sv_newmortal()); 1356 /*SUPPRESS 560*/ 1357 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) { 1358 len = rx->endp[i] - rx->startp[i]; 1359 s = rx->startp[i] + truebase; 1360 if (rx->endp[i] < 0 || rx->startp[i] < 0 || 1361 len < 0 || len > strend - s) 1362 DIE(aTHX_ "panic: pp_match start/end pointers"); 1363 sv_setpvn(*SP, s, len); 1364 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len)) 1365 SvUTF8_on(*SP); 1366 } 1367 } 1368 if (global) { 1369 if (dynpm->op_pmflags & PMf_CONTINUE) { 1370 MAGIC* mg = 0; 1371 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) 1372 mg = mg_find(TARG, PERL_MAGIC_regex_global); 1373 if (!mg) { 1374 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0); 1375 mg = mg_find(TARG, PERL_MAGIC_regex_global); 1376 } 1377 if (rx->startp[0] != -1) { 1378 mg->mg_len = rx->endp[0]; 1379 if (rx->startp[0] == rx->endp[0]) 1380 mg->mg_flags |= MGf_MINMATCH; 1381 else 1382 mg->mg_flags &= ~MGf_MINMATCH; 1383 } 1384 } 1385 had_zerolen = (rx->startp[0] != -1 1386 && rx->startp[0] == rx->endp[0]); 1387 PUTBACK; /* EVAL blocks may use stack */ 1388 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; 1389 goto play_it_again; 1390 } 1391 else if (!nparens) 1392 XPUSHs(&PL_sv_yes); 1393 LEAVE_SCOPE(oldsave); 1394 RETURN; 1395 } 1396 else { 1397 if (global) { 1398 MAGIC* mg = 0; 1399 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) 1400 mg = mg_find(TARG, PERL_MAGIC_regex_global); 1401 if (!mg) { 1402 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0); 1403 mg = mg_find(TARG, PERL_MAGIC_regex_global); 1404 } 1405 if (rx->startp[0] != -1) { 1406 mg->mg_len = rx->endp[0]; 1407 if (rx->startp[0] == rx->endp[0]) 1408 mg->mg_flags |= MGf_MINMATCH; 1409 else 1410 mg->mg_flags &= ~MGf_MINMATCH; 1411 } 1412 } 1413 LEAVE_SCOPE(oldsave); 1414 RETPUSHYES; 1415 } 1416 1417yup: /* Confirmed by INTUIT */ 1418 if (rxtainted) 1419 RX_MATCH_TAINTED_on(rx); 1420 TAINT_IF(RX_MATCH_TAINTED(rx)); 1421 PL_curpm = pm; 1422 if (dynpm->op_pmflags & PMf_ONCE) 1423 dynpm->op_pmdynflags |= PMdf_USED; 1424 if (RX_MATCH_COPIED(rx)) 1425 Safefree(rx->subbeg); 1426 RX_MATCH_COPIED_off(rx); 1427 rx->subbeg = Nullch; 1428 if (global) { 1429 rx->subbeg = truebase; 1430 rx->startp[0] = s - truebase; 1431 if (RX_MATCH_UTF8(rx)) { 1432 char *t = (char*)utf8_hop((U8*)s, rx->minlen); 1433 rx->endp[0] = t - truebase; 1434 } 1435 else { 1436 rx->endp[0] = s - truebase + rx->minlen; 1437 } 1438 rx->sublen = strend - truebase; 1439 goto gotcha; 1440 } 1441 if (PL_sawampersand) { 1442 I32 off; 1443 1444 rx->subbeg = savepvn(t, strend - t); 1445 rx->sublen = strend - t; 1446 RX_MATCH_COPIED_on(rx); 1447 off = rx->startp[0] = s - t; 1448 rx->endp[0] = off + rx->minlen; 1449 } 1450 else { /* startp/endp are used by @- @+. */ 1451 rx->startp[0] = s - truebase; 1452 rx->endp[0] = s - truebase + rx->minlen; 1453 } 1454 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */ 1455 LEAVE_SCOPE(oldsave); 1456 RETPUSHYES; 1457 1458nope: 1459ret_no: 1460 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) { 1461 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { 1462 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global); 1463 if (mg) 1464 mg->mg_len = -1; 1465 } 1466 } 1467 LEAVE_SCOPE(oldsave); 1468 if (gimme == G_ARRAY) 1469 RETURN; 1470 RETPUSHNO; 1471} 1472 1473OP * 1474Perl_do_readline(pTHX) 1475{ 1476 dSP; dTARGETSTACKED; 1477 register SV *sv; 1478 STRLEN tmplen = 0; 1479 STRLEN offset; 1480 PerlIO *fp; 1481 register IO *io = GvIO(PL_last_in_gv); 1482 register I32 type = PL_op->op_type; 1483 I32 gimme = GIMME_V; 1484 MAGIC *mg; 1485 1486 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { 1487 PUSHMARK(SP); 1488 XPUSHs(SvTIED_obj((SV*)io, mg)); 1489 PUTBACK; 1490 ENTER; 1491 call_method("READLINE", gimme); 1492 LEAVE; 1493 SPAGAIN; 1494 if (gimme == G_SCALAR) { 1495 SV* result = POPs; 1496 SvSetSV_nosteal(TARG, result); 1497 PUSHTARG; 1498 } 1499 RETURN; 1500 } 1501 fp = Nullfp; 1502 if (io) { 1503 fp = IoIFP(io); 1504 if (!fp) { 1505 if (IoFLAGS(io) & IOf_ARGV) { 1506 if (IoFLAGS(io) & IOf_START) { 1507 IoLINES(io) = 0; 1508 if (av_len(GvAVn(PL_last_in_gv)) < 0) { 1509 IoFLAGS(io) &= ~IOf_START; 1510 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp); 1511 sv_setpvn(GvSV(PL_last_in_gv), "-", 1); 1512 SvSETMAGIC(GvSV(PL_last_in_gv)); 1513 fp = IoIFP(io); 1514 goto have_fp; 1515 } 1516 } 1517 fp = nextargv(PL_last_in_gv); 1518 if (!fp) { /* Note: fp != IoIFP(io) */ 1519 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ 1520 } 1521 } 1522 else if (type == OP_GLOB) 1523 fp = Perl_start_glob(aTHX_ POPs, io); 1524 } 1525 else if (type == OP_GLOB) 1526 SP--; 1527 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) { 1528 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY); 1529 } 1530 } 1531 if (!fp) { 1532 if (ckWARN2(WARN_GLOB, WARN_CLOSED) 1533 && (!io || !(IoFLAGS(io) & IOf_START))) { 1534 if (type == OP_GLOB) 1535 Perl_warner(aTHX_ packWARN(WARN_GLOB), 1536 "glob failed (can't start child: %s)", 1537 Strerror(errno)); 1538 else 1539 report_evil_fh(PL_last_in_gv, io, PL_op->op_type); 1540 } 1541 if (gimme == G_SCALAR) { 1542 /* undef TARG, and push that undefined value */ 1543 if (type != OP_RCATLINE) { 1544 SV_CHECK_THINKFIRST(TARG); 1545 (void)SvOK_off(TARG); 1546 } 1547 PUSHTARG; 1548 } 1549 RETURN; 1550 } 1551 have_fp: 1552 if (gimme == G_SCALAR) { 1553 sv = TARG; 1554 if (SvROK(sv)) 1555 sv_unref(sv); 1556 (void)SvUPGRADE(sv, SVt_PV); 1557 tmplen = SvLEN(sv); /* remember if already alloced */ 1558 if (!tmplen && !SvREADONLY(sv)) 1559 Sv_Grow(sv, 80); /* try short-buffering it */ 1560 offset = 0; 1561 if (type == OP_RCATLINE && SvOK(sv)) { 1562 if (!SvPOK(sv)) { 1563 STRLEN n_a; 1564 (void)SvPV_force(sv, n_a); 1565 } 1566 offset = SvCUR(sv); 1567 } 1568 } 1569 else { 1570 sv = sv_2mortal(NEWSV(57, 80)); 1571 offset = 0; 1572 } 1573 1574 /* This should not be marked tainted if the fp is marked clean */ 1575#define MAYBE_TAINT_LINE(io, sv) \ 1576 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \ 1577 TAINT; \ 1578 SvTAINTED_on(sv); \ 1579 } 1580 1581/* delay EOF state for a snarfed empty file */ 1582#define SNARF_EOF(gimme,rs,io,sv) \ 1583 (gimme != G_SCALAR || SvCUR(sv) \ 1584 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs)) 1585 1586 for (;;) { 1587 PUTBACK; 1588 if (!sv_gets(sv, fp, offset) 1589 && (type == OP_GLOB 1590 || SNARF_EOF(gimme, PL_rs, io, sv) 1591 || PerlIO_error(fp))) 1592 { 1593 PerlIO_clearerr(fp); 1594 if (IoFLAGS(io) & IOf_ARGV) { 1595 fp = nextargv(PL_last_in_gv); 1596 if (fp) 1597 continue; 1598 (void)do_close(PL_last_in_gv, FALSE); 1599 } 1600 else if (type == OP_GLOB) { 1601 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) { 1602 Perl_warner(aTHX_ packWARN(WARN_GLOB), 1603 "glob failed (child exited with status %d%s)", 1604 (int)(STATUS_CURRENT >> 8), 1605 (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); 1606 } 1607 } 1608 if (gimme == G_SCALAR) { 1609 if (type != OP_RCATLINE) { 1610 SV_CHECK_THINKFIRST(TARG); 1611 (void)SvOK_off(TARG); 1612 } 1613 SPAGAIN; 1614 PUSHTARG; 1615 } 1616 MAYBE_TAINT_LINE(io, sv); 1617 RETURN; 1618 } 1619 MAYBE_TAINT_LINE(io, sv); 1620 IoLINES(io)++; 1621 IoFLAGS(io) |= IOf_NOLINE; 1622 SvSETMAGIC(sv); 1623 SPAGAIN; 1624 XPUSHs(sv); 1625 if (type == OP_GLOB) { 1626 char *tmps; 1627 1628 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) { 1629 tmps = SvEND(sv) - 1; 1630 if (*tmps == *SvPVX(PL_rs)) { 1631 *tmps = '\0'; 1632 SvCUR(sv)--; 1633 } 1634 } 1635 for (tmps = SvPVX(sv); *tmps; tmps++) 1636 if (!isALPHA(*tmps) && !isDIGIT(*tmps) && 1637 strchr("$&*(){}[]'\";\\|?<>~`", *tmps)) 1638 break; 1639 if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) { 1640 (void)POPs; /* Unmatched wildcard? Chuck it... */ 1641 continue; 1642 } 1643 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */ 1644 U8 *s = (U8*)SvPVX(sv) + offset; 1645 STRLEN len = SvCUR(sv) - offset; 1646 U8 *f; 1647 1648 if (ckWARN(WARN_UTF8) && 1649 !Perl_is_utf8_string_loc(aTHX_ s, len, &f)) 1650 /* Emulate :encoding(utf8) warning in the same case. */ 1651 Perl_warner(aTHX_ packWARN(WARN_UTF8), 1652 "utf8 \"\\x%02X\" does not map to Unicode", 1653 f < (U8*)SvEND(sv) ? *f : 0); 1654 } 1655 if (gimme == G_ARRAY) { 1656 if (SvLEN(sv) - SvCUR(sv) > 20) { 1657 SvLEN_set(sv, SvCUR(sv)+1); 1658 Renew(SvPVX(sv), SvLEN(sv), char); 1659 } 1660 sv = sv_2mortal(NEWSV(58, 80)); 1661 continue; 1662 } 1663 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) { 1664 /* try to reclaim a bit of scalar space (only on 1st alloc) */ 1665 if (SvCUR(sv) < 60) 1666 SvLEN_set(sv, 80); 1667 else 1668 SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */ 1669 Renew(SvPVX(sv), SvLEN(sv), char); 1670 } 1671 RETURN; 1672 } 1673} 1674 1675PP(pp_enter) 1676{ 1677 dSP; 1678 register PERL_CONTEXT *cx; 1679 I32 gimme = OP_GIMME(PL_op, -1); 1680 1681 if (gimme == -1) { 1682 if (cxstack_ix >= 0) 1683 gimme = cxstack[cxstack_ix].blk_gimme; 1684 else 1685 gimme = G_SCALAR; 1686 } 1687 1688 ENTER; 1689 1690 SAVETMPS; 1691 PUSHBLOCK(cx, CXt_BLOCK, SP); 1692 1693 RETURN; 1694} 1695 1696PP(pp_helem) 1697{ 1698 dSP; 1699 HE* he; 1700 SV **svp; 1701 SV *keysv = POPs; 1702 HV *hv = (HV*)POPs; 1703 U32 lval = PL_op->op_flags & OPf_MOD || LVRET; 1704 U32 defer = PL_op->op_private & OPpLVAL_DEFER; 1705 SV *sv; 1706 U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0; 1707 I32 preeminent = 0; 1708 1709 if (SvTYPE(hv) == SVt_PVHV) { 1710 if (PL_op->op_private & OPpLVAL_INTRO) { 1711 MAGIC *mg; 1712 HV *stash; 1713 /* does the element we're localizing already exist? */ 1714 preeminent = 1715 /* can we determine whether it exists? */ 1716 ( !SvRMAGICAL(hv) 1717 || mg_find((SV*)hv, PERL_MAGIC_env) 1718 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied)) 1719 /* Try to preserve the existenceness of a tied hash 1720 * element by using EXISTS and DELETE if possible. 1721 * Fallback to FETCH and STORE otherwise */ 1722 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg)))) 1723 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE) 1724 && gv_fetchmethod_autoload(stash, "DELETE", TRUE) 1725 ) 1726 ) ? hv_exists_ent(hv, keysv, 0) : 1; 1727 1728 } 1729 he = hv_fetch_ent(hv, keysv, lval && !defer, hash); 1730 svp = he ? &HeVAL(he) : 0; 1731 } 1732 else if (SvTYPE(hv) == SVt_PVAV) { 1733 if (PL_op->op_private & OPpLVAL_INTRO) 1734 DIE(aTHX_ "Can't localize pseudo-hash element"); 1735 svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash); 1736 } 1737 else { 1738 RETPUSHUNDEF; 1739 } 1740 if (lval) { 1741 if (!svp || *svp == &PL_sv_undef) { 1742 SV* lv; 1743 SV* key2; 1744 if (!defer) { 1745 STRLEN n_a; 1746 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); 1747 } 1748 lv = sv_newmortal(); 1749 sv_upgrade(lv, SVt_PVLV); 1750 LvTYPE(lv) = 'y'; 1751 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0); 1752 SvREFCNT_dec(key2); /* sv_magic() increments refcount */ 1753 LvTARG(lv) = SvREFCNT_inc(hv); 1754 LvTARGLEN(lv) = 1; 1755 PUSHs(lv); 1756 RETURN; 1757 } 1758 if (PL_op->op_private & OPpLVAL_INTRO) { 1759 if (HvNAME(hv) && isGV(*svp)) 1760 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL)); 1761 else { 1762 if (!preeminent) { 1763 STRLEN keylen; 1764 char *key = SvPV(keysv, keylen); 1765 SAVEDELETE(hv, savepvn(key,keylen), keylen); 1766 } else 1767 save_helem(hv, keysv, svp); 1768 } 1769 } 1770 else if (PL_op->op_private & OPpDEREF) 1771 vivify_ref(*svp, PL_op->op_private & OPpDEREF); 1772 } 1773 sv = (svp ? *svp : &PL_sv_undef); 1774 /* This makes C<local $tied{foo} = $tied{foo}> possible. 1775 * Pushing the magical RHS on to the stack is useless, since 1776 * that magic is soon destined to be misled by the local(), 1777 * and thus the later pp_sassign() will fail to mg_get() the 1778 * old value. This should also cure problems with delayed 1779 * mg_get()s. GSAR 98-07-03 */ 1780 if (!lval && SvGMAGICAL(sv)) 1781 sv = sv_mortalcopy(sv); 1782 PUSHs(sv); 1783 RETURN; 1784} 1785 1786PP(pp_leave) 1787{ 1788 dSP; 1789 register PERL_CONTEXT *cx; 1790 register SV **mark; 1791 SV **newsp; 1792 PMOP *newpm; 1793 I32 gimme; 1794 1795 if (PL_op->op_flags & OPf_SPECIAL) { 1796 cx = &cxstack[cxstack_ix]; 1797 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ 1798 } 1799 1800 POPBLOCK(cx,newpm); 1801 1802 gimme = OP_GIMME(PL_op, -1); 1803 if (gimme == -1) { 1804 if (cxstack_ix >= 0) 1805 gimme = cxstack[cxstack_ix].blk_gimme; 1806 else 1807 gimme = G_SCALAR; 1808 } 1809 1810 TAINT_NOT; 1811 if (gimme == G_VOID) 1812 SP = newsp; 1813 else if (gimme == G_SCALAR) { 1814 MARK = newsp + 1; 1815 if (MARK <= SP) { 1816 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) 1817 *MARK = TOPs; 1818 else 1819 *MARK = sv_mortalcopy(TOPs); 1820 } else { 1821 MEXTEND(mark,0); 1822 *MARK = &PL_sv_undef; 1823 } 1824 SP = MARK; 1825 } 1826 else if (gimme == G_ARRAY) { 1827 /* in case LEAVE wipes old return values */ 1828 for (mark = newsp + 1; mark <= SP; mark++) { 1829 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { 1830 *mark = sv_mortalcopy(*mark); 1831 TAINT_NOT; /* Each item is independent */ 1832 } 1833 } 1834 } 1835 PL_curpm = newpm; /* Don't pop $1 et al till now */ 1836 1837 LEAVE; 1838 1839 RETURN; 1840} 1841 1842PP(pp_iter) 1843{ 1844 dSP; 1845 register PERL_CONTEXT *cx; 1846 SV *sv, *oldsv; 1847 AV* av; 1848 SV **itersvp; 1849 1850 EXTEND(SP, 1); 1851 cx = &cxstack[cxstack_ix]; 1852 if (CxTYPE(cx) != CXt_LOOP) 1853 DIE(aTHX_ "panic: pp_iter"); 1854 1855 itersvp = CxITERVAR(cx); 1856 av = cx->blk_loop.iterary; 1857 if (SvTYPE(av) != SVt_PVAV) { 1858 /* iterate ($min .. $max) */ 1859 if (cx->blk_loop.iterlval) { 1860 /* string increment */ 1861 register SV* cur = cx->blk_loop.iterlval; 1862 STRLEN maxlen = 0; 1863 char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : ""; 1864 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { 1865#ifndef USE_5005THREADS /* don't risk potential race */ 1866 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { 1867 /* safe to reuse old SV */ 1868 sv_setsv(*itersvp, cur); 1869 } 1870 else 1871#endif 1872 { 1873 /* we need a fresh SV every time so that loop body sees a 1874 * completely new SV for closures/references to work as 1875 * they used to */ 1876 oldsv = *itersvp; 1877 *itersvp = newSVsv(cur); 1878 SvREFCNT_dec(oldsv); 1879 } 1880 if (strEQ(SvPVX(cur), max)) 1881 sv_setiv(cur, 0); /* terminate next time */ 1882 else 1883 sv_inc(cur); 1884 RETPUSHYES; 1885 } 1886 RETPUSHNO; 1887 } 1888 /* integer increment */ 1889 if (cx->blk_loop.iterix > cx->blk_loop.itermax) 1890 RETPUSHNO; 1891 1892#ifndef USE_5005THREADS /* don't risk potential race */ 1893 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { 1894 /* safe to reuse old SV */ 1895 sv_setiv(*itersvp, cx->blk_loop.iterix++); 1896 } 1897 else 1898#endif 1899 { 1900 /* we need a fresh SV every time so that loop body sees a 1901 * completely new SV for closures/references to work as they 1902 * used to */ 1903 oldsv = *itersvp; 1904 *itersvp = newSViv(cx->blk_loop.iterix++); 1905 SvREFCNT_dec(oldsv); 1906 } 1907 RETPUSHYES; 1908 } 1909 1910 /* iterate array */ 1911 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av))) 1912 RETPUSHNO; 1913 1914 if (SvMAGICAL(av) || AvREIFY(av)) { 1915 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE); 1916 if (svp) 1917 sv = *svp; 1918 else 1919 sv = Nullsv; 1920 } 1921 else { 1922 sv = AvARRAY(av)[++cx->blk_loop.iterix]; 1923 } 1924 if (sv && SvREFCNT(sv) == 0) { 1925 *itersvp = Nullsv; 1926 Perl_croak(aTHX_ "Use of freed value in iteration"); 1927 } 1928 1929 if (sv) 1930 SvTEMP_off(sv); 1931 else 1932 sv = &PL_sv_undef; 1933 if (av != PL_curstack && sv == &PL_sv_undef) { 1934 SV *lv = cx->blk_loop.iterlval; 1935 if (lv && SvREFCNT(lv) > 1) { 1936 SvREFCNT_dec(lv); 1937 lv = Nullsv; 1938 } 1939 if (lv) 1940 SvREFCNT_dec(LvTARG(lv)); 1941 else { 1942 lv = cx->blk_loop.iterlval = NEWSV(26, 0); 1943 sv_upgrade(lv, SVt_PVLV); 1944 LvTYPE(lv) = 'y'; 1945 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0); 1946 } 1947 LvTARG(lv) = SvREFCNT_inc(av); 1948 LvTARGOFF(lv) = cx->blk_loop.iterix; 1949 LvTARGLEN(lv) = (STRLEN)UV_MAX; 1950 sv = (SV*)lv; 1951 } 1952 1953 oldsv = *itersvp; 1954 *itersvp = SvREFCNT_inc(sv); 1955 SvREFCNT_dec(oldsv); 1956 1957 RETPUSHYES; 1958} 1959 1960PP(pp_subst) 1961{ 1962 dSP; dTARG; 1963 register PMOP *pm = cPMOP; 1964 PMOP *rpm = pm; 1965 register SV *dstr; 1966 register char *s; 1967 char *strend; 1968 register char *m; 1969 char *c; 1970 register char *d; 1971 STRLEN clen; 1972 I32 iters = 0; 1973 I32 maxiters; 1974 register I32 i; 1975 bool once; 1976 bool rxtainted; 1977 char *orig; 1978 I32 r_flags; 1979 register REGEXP *rx = PM_GETRE(pm); 1980 STRLEN len; 1981 int force_on_match = 0; 1982 I32 oldsave = PL_savestack_ix; 1983 STRLEN slen; 1984 bool doutf8 = FALSE; 1985 SV *nsv = Nullsv; 1986 1987 /* known replacement string? */ 1988 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv; 1989 if (PL_op->op_flags & OPf_STACKED) 1990 TARG = POPs; 1991 else { 1992 TARG = DEFSV; 1993 EXTEND(SP,1); 1994 } 1995 1996 if (SvFAKE(TARG) && SvREADONLY(TARG)) 1997 sv_force_normal(TARG); 1998 if (SvREADONLY(TARG) 1999 || (SvTYPE(TARG) > SVt_PVLV 2000 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))) 2001 DIE(aTHX_ PL_no_modify); 2002 PUTBACK; 2003 2004 s = SvPV(TARG, len); 2005 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV) 2006 force_on_match = 1; 2007 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || 2008 (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); 2009 if (PL_tainted) 2010 rxtainted |= 2; 2011 TAINT_NOT; 2012 2013 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG)); 2014 2015 force_it: 2016 if (!pm || !s) 2017 DIE(aTHX_ "panic: pp_subst"); 2018 2019 strend = s + len; 2020 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len; 2021 maxiters = 2 * slen + 10; /* We can match twice at each 2022 position, once with zero-length, 2023 second time with non-zero. */ 2024 2025 if (!rx->prelen && PL_curpm) { 2026 pm = PL_curpm; 2027 rx = PM_GETRE(pm); 2028 } 2029 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand) 2030 ? REXEC_COPY_STR : 0; 2031 if (SvSCREAM(TARG)) 2032 r_flags |= REXEC_SCREAM; 2033 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { 2034 SAVEINT(PL_multiline); 2035 PL_multiline = pm->op_pmflags & PMf_MULTILINE; 2036 } 2037 orig = m = s; 2038 if (rx->reganch & RE_USE_INTUIT) { 2039 PL_bostr = orig; 2040 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); 2041 2042 if (!s) 2043 goto nope; 2044 /* How to do it in subst? */ 2045/* if ( (rx->reganch & ROPT_CHECK_ALL) 2046 && !PL_sawampersand 2047 && ((rx->reganch & ROPT_NOSCAN) 2048 || !((rx->reganch & RE_INTUIT_TAIL) 2049 && (r_flags & REXEC_SCREAM)))) 2050 goto yup; 2051*/ 2052 } 2053 2054 /* only replace once? */ 2055 once = !(rpm->op_pmflags & PMf_GLOBAL); 2056 2057 /* known replacement string? */ 2058 if (dstr) { 2059 /* replacement needing upgrading? */ 2060 if (DO_UTF8(TARG) && !doutf8) { 2061 nsv = sv_newmortal(); 2062 SvSetSV(nsv, dstr); 2063 if (PL_encoding) 2064 sv_recode_to_utf8(nsv, PL_encoding); 2065 else 2066 sv_utf8_upgrade(nsv); 2067 c = SvPV(nsv, clen); 2068 doutf8 = TRUE; 2069 } 2070 else { 2071 c = SvPV(dstr, clen); 2072 doutf8 = DO_UTF8(dstr); 2073 } 2074 } 2075 else { 2076 c = Nullch; 2077 doutf8 = FALSE; 2078 } 2079 2080 /* can do inplace substitution? */ 2081 if (c && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR)) 2082 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN) 2083 && (!doutf8 || SvUTF8(TARG))) { 2084 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, 2085 r_flags | REXEC_CHECKED)) 2086 { 2087 SPAGAIN; 2088 PUSHs(&PL_sv_no); 2089 LEAVE_SCOPE(oldsave); 2090 RETURN; 2091 } 2092 if (force_on_match) { 2093 force_on_match = 0; 2094 s = SvPV_force(TARG, len); 2095 goto force_it; 2096 } 2097 d = s; 2098 PL_curpm = pm; 2099 SvSCREAM_off(TARG); /* disable possible screamer */ 2100 if (once) { 2101 rxtainted |= RX_MATCH_TAINTED(rx); 2102 m = orig + rx->startp[0]; 2103 d = orig + rx->endp[0]; 2104 s = orig; 2105 if (m - s > strend - d) { /* faster to shorten from end */ 2106 if (clen) { 2107 Copy(c, m, clen, char); 2108 m += clen; 2109 } 2110 i = strend - d; 2111 if (i > 0) { 2112 Move(d, m, i, char); 2113 m += i; 2114 } 2115 *m = '\0'; 2116 SvCUR_set(TARG, m - s); 2117 } 2118 /*SUPPRESS 560*/ 2119 else if ((i = m - s)) { /* faster from front */ 2120 d -= clen; 2121 m = d; 2122 sv_chop(TARG, d-i); 2123 s += i; 2124 while (i--) 2125 *--d = *--s; 2126 if (clen) 2127 Copy(c, m, clen, char); 2128 } 2129 else if (clen) { 2130 d -= clen; 2131 sv_chop(TARG, d); 2132 Copy(c, d, clen, char); 2133 } 2134 else { 2135 sv_chop(TARG, d); 2136 } 2137 TAINT_IF(rxtainted & 1); 2138 SPAGAIN; 2139 PUSHs(&PL_sv_yes); 2140 } 2141 else { 2142 do { 2143 if (iters++ > maxiters) 2144 DIE(aTHX_ "Substitution loop"); 2145 rxtainted |= RX_MATCH_TAINTED(rx); 2146 m = rx->startp[0] + orig; 2147 /*SUPPRESS 560*/ 2148 if ((i = m - s)) { 2149 if (s != d) 2150 Move(s, d, i, char); 2151 d += i; 2152 } 2153 if (clen) { 2154 Copy(c, d, clen, char); 2155 d += clen; 2156 } 2157 s = rx->endp[0] + orig; 2158 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, 2159 TARG, NULL, 2160 /* don't match same null twice */ 2161 REXEC_NOT_FIRST|REXEC_IGNOREPOS)); 2162 if (s != d) { 2163 i = strend - s; 2164 SvCUR_set(TARG, d - SvPVX(TARG) + i); 2165 Move(s, d, i+1, char); /* include the NUL */ 2166 } 2167 TAINT_IF(rxtainted & 1); 2168 SPAGAIN; 2169 PUSHs(sv_2mortal(newSViv((I32)iters))); 2170 } 2171 (void)SvPOK_only_UTF8(TARG); 2172 TAINT_IF(rxtainted); 2173 if (SvSMAGICAL(TARG)) { 2174 PUTBACK; 2175 mg_set(TARG); 2176 SPAGAIN; 2177 } 2178 SvTAINT(TARG); 2179 if (doutf8) 2180 SvUTF8_on(TARG); 2181 LEAVE_SCOPE(oldsave); 2182 RETURN; 2183 } 2184 2185 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, 2186 r_flags | REXEC_CHECKED)) 2187 { 2188 if (force_on_match) { 2189 force_on_match = 0; 2190 s = SvPV_force(TARG, len); 2191 goto force_it; 2192 } 2193 rxtainted |= RX_MATCH_TAINTED(rx); 2194 dstr = NEWSV(25, len); 2195 sv_setpvn(dstr, m, s-m); 2196 if (DO_UTF8(TARG)) 2197 SvUTF8_on(dstr); 2198 PL_curpm = pm; 2199 if (!c) { 2200 register PERL_CONTEXT *cx; 2201 SPAGAIN; 2202 ReREFCNT_inc(rx); 2203 PUSHSUBST(cx); 2204 RETURNOP(cPMOP->op_pmreplroot); 2205 } 2206 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; 2207 do { 2208 if (iters++ > maxiters) 2209 DIE(aTHX_ "Substitution loop"); 2210 rxtainted |= RX_MATCH_TAINTED(rx); 2211 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { 2212 m = s; 2213 s = orig; 2214 orig = rx->subbeg; 2215 s = orig + (m - s); 2216 strend = s + (strend - m); 2217 } 2218 m = rx->startp[0] + orig; 2219 if (doutf8 && !SvUTF8(dstr)) 2220 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv); 2221 else 2222 sv_catpvn(dstr, s, m-s); 2223 s = rx->endp[0] + orig; 2224 if (clen) 2225 sv_catpvn(dstr, c, clen); 2226 if (once) 2227 break; 2228 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, 2229 TARG, NULL, r_flags)); 2230 if (doutf8 && !DO_UTF8(TARG)) 2231 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv); 2232 else 2233 sv_catpvn(dstr, s, strend - s); 2234 2235 (void)SvOOK_off(TARG); 2236 if (SvLEN(TARG)) 2237 Safefree(SvPVX(TARG)); 2238 SvPVX(TARG) = SvPVX(dstr); 2239 SvCUR_set(TARG, SvCUR(dstr)); 2240 SvLEN_set(TARG, SvLEN(dstr)); 2241 doutf8 |= DO_UTF8(dstr); 2242 SvPVX(dstr) = 0; 2243 sv_free(dstr); 2244 2245 TAINT_IF(rxtainted & 1); 2246 SPAGAIN; 2247 PUSHs(sv_2mortal(newSViv((I32)iters))); 2248 2249 (void)SvPOK_only(TARG); 2250 if (doutf8) 2251 SvUTF8_on(TARG); 2252 TAINT_IF(rxtainted); 2253 SvSETMAGIC(TARG); 2254 SvTAINT(TARG); 2255 LEAVE_SCOPE(oldsave); 2256 RETURN; 2257 } 2258 goto ret_no; 2259 2260nope: 2261ret_no: 2262 SPAGAIN; 2263 PUSHs(&PL_sv_no); 2264 LEAVE_SCOPE(oldsave); 2265 RETURN; 2266} 2267 2268PP(pp_grepwhile) 2269{ 2270 dSP; 2271 2272 if (SvTRUEx(POPs)) 2273 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; 2274 ++*PL_markstack_ptr; 2275 LEAVE; /* exit inner scope */ 2276 2277 /* All done yet? */ 2278 if (PL_stack_base + *PL_markstack_ptr > SP) { 2279 I32 items; 2280 I32 gimme = GIMME_V; 2281 2282 LEAVE; /* exit outer scope */ 2283 (void)POPMARK; /* pop src */ 2284 items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; 2285 (void)POPMARK; /* pop dst */ 2286 SP = PL_stack_base + POPMARK; /* pop original mark */ 2287 if (gimme == G_SCALAR) { 2288 dTARGET; 2289 XPUSHi(items); 2290 } 2291 else if (gimme == G_ARRAY) 2292 SP += items; 2293 RETURN; 2294 } 2295 else { 2296 SV *src; 2297 2298 ENTER; /* enter inner scope */ 2299 SAVEVPTR(PL_curpm); 2300 2301 src = PL_stack_base[*PL_markstack_ptr]; 2302 SvTEMP_off(src); 2303 DEFSV = src; 2304 2305 RETURNOP(cLOGOP->op_other); 2306 } 2307} 2308 2309PP(pp_leavesub) 2310{ 2311 dSP; 2312 SV **mark; 2313 SV **newsp; 2314 PMOP *newpm; 2315 I32 gimme; 2316 register PERL_CONTEXT *cx; 2317 SV *sv; 2318 2319 POPBLOCK(cx,newpm); 2320 cxstack_ix++; /* temporarily protect top context */ 2321 2322 TAINT_NOT; 2323 if (gimme == G_SCALAR) { 2324 MARK = newsp + 1; 2325 if (MARK <= SP) { 2326 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { 2327 if (SvTEMP(TOPs)) { 2328 *MARK = SvREFCNT_inc(TOPs); 2329 FREETMPS; 2330 sv_2mortal(*MARK); 2331 } 2332 else { 2333 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */ 2334 FREETMPS; 2335 *MARK = sv_mortalcopy(sv); 2336 SvREFCNT_dec(sv); 2337 } 2338 } 2339 else 2340 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs); 2341 } 2342 else { 2343 MEXTEND(MARK, 0); 2344 *MARK = &PL_sv_undef; 2345 } 2346 SP = MARK; 2347 } 2348 else if (gimme == G_ARRAY) { 2349 for (MARK = newsp + 1; MARK <= SP; MARK++) { 2350 if (!SvTEMP(*MARK)) { 2351 *MARK = sv_mortalcopy(*MARK); 2352 TAINT_NOT; /* Each item is independent */ 2353 } 2354 } 2355 } 2356 PUTBACK; 2357 2358 LEAVE; 2359 cxstack_ix--; 2360 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ 2361 PL_curpm = newpm; /* ... and pop $1 et al */ 2362 2363 LEAVESUB(sv); 2364 return pop_return(); 2365} 2366 2367/* This duplicates the above code because the above code must not 2368 * get any slower by more conditions */ 2369PP(pp_leavesublv) 2370{ 2371 dSP; 2372 SV **mark; 2373 SV **newsp; 2374 PMOP *newpm; 2375 I32 gimme; 2376 register PERL_CONTEXT *cx; 2377 SV *sv; 2378 2379 POPBLOCK(cx,newpm); 2380 cxstack_ix++; /* temporarily protect top context */ 2381 2382 TAINT_NOT; 2383 2384 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) { 2385 /* We are an argument to a function or grep(). 2386 * This kind of lvalueness was legal before lvalue 2387 * subroutines too, so be backward compatible: 2388 * cannot report errors. */ 2389 2390 /* Scalar context *is* possible, on the LHS of -> only, 2391 * as in f()->meth(). But this is not an lvalue. */ 2392 if (gimme == G_SCALAR) 2393 goto temporise; 2394 if (gimme == G_ARRAY) { 2395 if (!CvLVALUE(cx->blk_sub.cv)) 2396 goto temporise_array; 2397 EXTEND_MORTAL(SP - newsp); 2398 for (mark = newsp + 1; mark <= SP; mark++) { 2399 if (SvTEMP(*mark)) 2400 /* empty */ ; 2401 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY)) 2402 *mark = sv_mortalcopy(*mark); 2403 else { 2404 /* Can be a localized value subject to deletion. */ 2405 PL_tmps_stack[++PL_tmps_ix] = *mark; 2406 (void)SvREFCNT_inc(*mark); 2407 } 2408 } 2409 } 2410 } 2411 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */ 2412 /* Here we go for robustness, not for speed, so we change all 2413 * the refcounts so the caller gets a live guy. Cannot set 2414 * TEMP, so sv_2mortal is out of question. */ 2415 if (!CvLVALUE(cx->blk_sub.cv)) { 2416 LEAVE; 2417 cxstack_ix--; 2418 POPSUB(cx,sv); 2419 PL_curpm = newpm; 2420 LEAVESUB(sv); 2421 DIE(aTHX_ "Can't modify non-lvalue subroutine call"); 2422 } 2423 if (gimme == G_SCALAR) { 2424 MARK = newsp + 1; 2425 EXTEND_MORTAL(1); 2426 if (MARK == SP) { 2427 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { 2428 LEAVE; 2429 cxstack_ix--; 2430 POPSUB(cx,sv); 2431 PL_curpm = newpm; 2432 LEAVESUB(sv); 2433 DIE(aTHX_ "Can't return %s from lvalue subroutine", 2434 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef" 2435 : "a readonly value" : "a temporary"); 2436 } 2437 else { /* Can be a localized value 2438 * subject to deletion. */ 2439 PL_tmps_stack[++PL_tmps_ix] = *mark; 2440 (void)SvREFCNT_inc(*mark); 2441 } 2442 } 2443 else { /* Should not happen? */ 2444 LEAVE; 2445 cxstack_ix--; 2446 POPSUB(cx,sv); 2447 PL_curpm = newpm; 2448 LEAVESUB(sv); 2449 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context", 2450 (MARK > SP ? "Empty array" : "Array")); 2451 } 2452 SP = MARK; 2453 } 2454 else if (gimme == G_ARRAY) { 2455 EXTEND_MORTAL(SP - newsp); 2456 for (mark = newsp + 1; mark <= SP; mark++) { 2457 if (*mark != &PL_sv_undef 2458 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { 2459 /* Might be flattened array after $#array = */ 2460 PUTBACK; 2461 LEAVE; 2462 cxstack_ix--; 2463 POPSUB(cx,sv); 2464 PL_curpm = newpm; 2465 LEAVESUB(sv); 2466 DIE(aTHX_ "Can't return a %s from lvalue subroutine", 2467 SvREADONLY(TOPs) ? "readonly value" : "temporary"); 2468 } 2469 else { 2470 /* Can be a localized value subject to deletion. */ 2471 PL_tmps_stack[++PL_tmps_ix] = *mark; 2472 (void)SvREFCNT_inc(*mark); 2473 } 2474 } 2475 } 2476 } 2477 else { 2478 if (gimme == G_SCALAR) { 2479 temporise: 2480 MARK = newsp + 1; 2481 if (MARK <= SP) { 2482 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { 2483 if (SvTEMP(TOPs)) { 2484 *MARK = SvREFCNT_inc(TOPs); 2485 FREETMPS; 2486 sv_2mortal(*MARK); 2487 } 2488 else { 2489 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */ 2490 FREETMPS; 2491 *MARK = sv_mortalcopy(sv); 2492 SvREFCNT_dec(sv); 2493 } 2494 } 2495 else 2496 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs); 2497 } 2498 else { 2499 MEXTEND(MARK, 0); 2500 *MARK = &PL_sv_undef; 2501 } 2502 SP = MARK; 2503 } 2504 else if (gimme == G_ARRAY) { 2505 temporise_array: 2506 for (MARK = newsp + 1; MARK <= SP; MARK++) { 2507 if (!SvTEMP(*MARK)) { 2508 *MARK = sv_mortalcopy(*MARK); 2509 TAINT_NOT; /* Each item is independent */ 2510 } 2511 } 2512 } 2513 } 2514 PUTBACK; 2515 2516 LEAVE; 2517 cxstack_ix--; 2518 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ 2519 PL_curpm = newpm; /* ... and pop $1 et al */ 2520 2521 LEAVESUB(sv); 2522 return pop_return(); 2523} 2524 2525 2526STATIC CV * 2527S_get_db_sub(pTHX_ SV **svp, CV *cv) 2528{ 2529 SV *dbsv = GvSV(PL_DBsub); 2530 2531 if (!PERLDB_SUB_NN) { 2532 GV *gv = CvGV(cv); 2533 2534 save_item(dbsv); 2535 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) 2536 || strEQ(GvNAME(gv), "END") 2537 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ 2538 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) 2539 && (gv = (GV*)*svp) ))) { 2540 /* Use GV from the stack as a fallback. */ 2541 /* GV is potentially non-unique, or contain different CV. */ 2542 SV *tmp = newRV((SV*)cv); 2543 sv_setsv(dbsv, tmp); 2544 SvREFCNT_dec(tmp); 2545 } 2546 else { 2547 gv_efullname3(dbsv, gv, Nullch); 2548 } 2549 } 2550 else { 2551 (void)SvUPGRADE(dbsv, SVt_PVIV); 2552 (void)SvIOK_on(dbsv); 2553 SAVEIV(SvIVX(dbsv)); 2554 SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */ 2555 } 2556 2557 if (CvXSUB(cv)) 2558 PL_curcopdb = PL_curcop; 2559 cv = GvCV(PL_DBsub); 2560 return cv; 2561} 2562 2563PP(pp_entersub) 2564{ 2565 dSP; dPOPss; 2566 GV *gv; 2567 HV *stash; 2568 register CV *cv; 2569 register PERL_CONTEXT *cx; 2570 I32 gimme; 2571 bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0; 2572 2573 if (!sv) 2574 DIE(aTHX_ "Not a CODE reference"); 2575 switch (SvTYPE(sv)) { 2576 default: 2577 if (!SvROK(sv)) { 2578 char *sym; 2579 STRLEN n_a; 2580 2581 if (sv == &PL_sv_yes) { /* unfound import, ignore */ 2582 if (hasargs) 2583 SP = PL_stack_base + POPMARK; 2584 RETURN; 2585 } 2586 if (SvGMAGICAL(sv)) { 2587 mg_get(sv); 2588 if (SvROK(sv)) 2589 goto got_rv; 2590 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch; 2591 } 2592 else 2593 sym = SvPV(sv, n_a); 2594 if (!sym) 2595 DIE(aTHX_ PL_no_usym, "a subroutine"); 2596 if (PL_op->op_private & HINT_STRICT_REFS) 2597 DIE(aTHX_ PL_no_symref, sym, "a subroutine"); 2598 cv = get_cv(sym, TRUE); 2599 break; 2600 } 2601 got_rv: 2602 { 2603 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ 2604 tryAMAGICunDEREF(to_cv); 2605 } 2606 cv = (CV*)SvRV(sv); 2607 if (SvTYPE(cv) == SVt_PVCV) 2608 break; 2609 /* FALL THROUGH */ 2610 case SVt_PVHV: 2611 case SVt_PVAV: 2612 DIE(aTHX_ "Not a CODE reference"); 2613 case SVt_PVCV: 2614 cv = (CV*)sv; 2615 break; 2616 case SVt_PVGV: 2617 if (!(cv = GvCVu((GV*)sv))) 2618 cv = sv_2cv(sv, &stash, &gv, FALSE); 2619 if (!cv) { 2620 ENTER; 2621 SAVETMPS; 2622 goto try_autoload; 2623 } 2624 break; 2625 } 2626 2627 ENTER; 2628 SAVETMPS; 2629 2630 retry: 2631 if (!CvROOT(cv) && !CvXSUB(cv)) { 2632 GV* autogv; 2633 SV* sub_name; 2634 2635 /* anonymous or undef'd function leaves us no recourse */ 2636 if (CvANON(cv) || !(gv = CvGV(cv))) 2637 DIE(aTHX_ "Undefined subroutine called"); 2638 2639 /* autoloaded stub? */ 2640 if (cv != GvCV(gv)) { 2641 cv = GvCV(gv); 2642 } 2643 /* should call AUTOLOAD now? */ 2644 else { 2645try_autoload: 2646 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), 2647 FALSE))) 2648 { 2649 cv = GvCV(autogv); 2650 } 2651 /* sorry */ 2652 else { 2653 sub_name = sv_newmortal(); 2654 gv_efullname3(sub_name, gv, Nullch); 2655 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name); 2656 } 2657 } 2658 if (!cv) 2659 DIE(aTHX_ "Not a CODE reference"); 2660 goto retry; 2661 } 2662 2663 gimme = GIMME_V; 2664 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) { 2665 cv = get_db_sub(&sv, cv); 2666 if (!cv) 2667 DIE(aTHX_ "No DBsub routine"); 2668 } 2669 2670#ifdef USE_5005THREADS 2671 /* 2672 * First we need to check if the sub or method requires locking. 2673 * If so, we gain a lock on the CV, the first argument or the 2674 * stash (for static methods), as appropriate. This has to be 2675 * inline because for FAKE_THREADS, COND_WAIT inlines code to 2676 * reschedule by returning a new op. 2677 */ 2678 MUTEX_LOCK(CvMUTEXP(cv)); 2679 if (CvFLAGS(cv) & CVf_LOCKED) { 2680 MAGIC *mg; 2681 if (CvFLAGS(cv) & CVf_METHOD) { 2682 if (SP > PL_stack_base + TOPMARK) 2683 sv = *(PL_stack_base + TOPMARK + 1); 2684 else { 2685 AV *av = (AV*)PAD_SVl(0); 2686 if (hasargs || !av || AvFILLp(av) < 0 2687 || !(sv = AvARRAY(av)[0])) 2688 { 2689 MUTEX_UNLOCK(CvMUTEXP(cv)); 2690 DIE(aTHX_ "no argument for locked method call"); 2691 } 2692 } 2693 if (SvROK(sv)) 2694 sv = SvRV(sv); 2695 else { 2696 STRLEN len; 2697 char *stashname = SvPV(sv, len); 2698 sv = (SV*)gv_stashpvn(stashname, len, TRUE); 2699 } 2700 } 2701 else { 2702 sv = (SV*)cv; 2703 } 2704 MUTEX_UNLOCK(CvMUTEXP(cv)); 2705 mg = condpair_magic(sv); 2706 MUTEX_LOCK(MgMUTEXP(mg)); 2707 if (MgOWNER(mg) == thr) 2708 MUTEX_UNLOCK(MgMUTEXP(mg)); 2709 else { 2710 while (MgOWNER(mg)) 2711 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); 2712 MgOWNER(mg) = thr; 2713 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n", 2714 thr, sv)); 2715 MUTEX_UNLOCK(MgMUTEXP(mg)); 2716 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); 2717 } 2718 MUTEX_LOCK(CvMUTEXP(cv)); 2719 } 2720 /* 2721 * Now we have permission to enter the sub, we must distinguish 2722 * four cases. (0) It's an XSUB (in which case we don't care 2723 * about ownership); (1) it's ours already (and we're recursing); 2724 * (2) it's free (but we may already be using a cached clone); 2725 * (3) another thread owns it. Case (1) is easy: we just use it. 2726 * Case (2) means we look for a clone--if we have one, use it 2727 * otherwise grab ownership of cv. Case (3) means we look for a 2728 * clone (for non-XSUBs) and have to create one if we don't 2729 * already have one. 2730 * Why look for a clone in case (2) when we could just grab 2731 * ownership of cv straight away? Well, we could be recursing, 2732 * i.e. we originally tried to enter cv while another thread 2733 * owned it (hence we used a clone) but it has been freed up 2734 * and we're now recursing into it. It may or may not be "better" 2735 * to use the clone but at least CvDEPTH can be trusted. 2736 */ 2737 if (CvOWNER(cv) == thr || CvXSUB(cv)) 2738 MUTEX_UNLOCK(CvMUTEXP(cv)); 2739 else { 2740 /* Case (2) or (3) */ 2741 SV **svp; 2742 2743 /* 2744 * XXX Might it be better to release CvMUTEXP(cv) while we 2745 * do the hv_fetch? We might find someone has pinched it 2746 * when we look again, in which case we would be in case 2747 * (3) instead of (2) so we'd have to clone. Would the fact 2748 * that we released the mutex more quickly make up for this? 2749 */ 2750 if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE))) 2751 { 2752 /* We already have a clone to use */ 2753 MUTEX_UNLOCK(CvMUTEXP(cv)); 2754 cv = *(CV**)svp; 2755 DEBUG_S(PerlIO_printf(Perl_debug_log, 2756 "entersub: %p already has clone %p:%s\n", 2757 thr, cv, SvPEEK((SV*)cv))); 2758 CvOWNER(cv) = thr; 2759 SvREFCNT_inc(cv); 2760 if (CvDEPTH(cv) == 0) 2761 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv); 2762 } 2763 else { 2764 /* (2) => grab ownership of cv. (3) => make clone */ 2765 if (!CvOWNER(cv)) { 2766 CvOWNER(cv) = thr; 2767 SvREFCNT_inc(cv); 2768 MUTEX_UNLOCK(CvMUTEXP(cv)); 2769 DEBUG_S(PerlIO_printf(Perl_debug_log, 2770 "entersub: %p grabbing %p:%s in stash %s\n", 2771 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ? 2772 HvNAME(CvSTASH(cv)) : "(none)")); 2773 } 2774 else { 2775 /* Make a new clone. */ 2776 CV *clonecv; 2777 SvREFCNT_inc(cv); /* don't let it vanish from under us */ 2778 MUTEX_UNLOCK(CvMUTEXP(cv)); 2779 DEBUG_S((PerlIO_printf(Perl_debug_log, 2780 "entersub: %p cloning %p:%s\n", 2781 thr, cv, SvPEEK((SV*)cv)))); 2782 /* 2783 * We're creating a new clone so there's no race 2784 * between the original MUTEX_UNLOCK and the 2785 * SvREFCNT_inc since no one will be trying to undef 2786 * it out from underneath us. At least, I don't think 2787 * there's a race... 2788 */ 2789 clonecv = cv_clone(cv); 2790 SvREFCNT_dec(cv); /* finished with this */ 2791 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0); 2792 CvOWNER(clonecv) = thr; 2793 cv = clonecv; 2794 SvREFCNT_inc(cv); 2795 } 2796 DEBUG_S(if (CvDEPTH(cv) != 0) 2797 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n", 2798 CvDEPTH(cv))); 2799 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv); 2800 } 2801 } 2802#endif /* USE_5005THREADS */ 2803 2804 if (CvXSUB(cv)) { 2805#ifdef PERL_XSUB_OLDSTYLE 2806 if (CvOLDSTYLE(cv)) { 2807 I32 (*fp3)(int,int,int); 2808 dMARK; 2809 register I32 items = SP - MARK; 2810 /* We dont worry to copy from @_. */ 2811 while (SP > mark) { 2812 SP[1] = SP[0]; 2813 SP--; 2814 } 2815 PL_stack_sp = mark + 1; 2816 fp3 = (I32(*)(int,int,int))CvXSUB(cv); 2817 items = (*fp3)(CvXSUBANY(cv).any_i32, 2818 MARK - PL_stack_base + 1, 2819 items); 2820 PL_stack_sp = PL_stack_base + items; 2821 } 2822 else 2823#endif /* PERL_XSUB_OLDSTYLE */ 2824 { 2825 I32 markix = TOPMARK; 2826 2827 PUTBACK; 2828 2829 if (!hasargs) { 2830 /* Need to copy @_ to stack. Alternative may be to 2831 * switch stack to @_, and copy return values 2832 * back. This would allow popping @_ in XSUB, e.g.. XXXX */ 2833 AV* av; 2834 I32 items; 2835#ifdef USE_5005THREADS 2836 av = (AV*)PAD_SVl(0); 2837#else 2838 av = GvAV(PL_defgv); 2839#endif /* USE_5005THREADS */ 2840 items = AvFILLp(av) + 1; /* @_ is not tieable */ 2841 2842 if (items) { 2843 /* Mark is at the end of the stack. */ 2844 EXTEND(SP, items); 2845 Copy(AvARRAY(av), SP + 1, items, SV*); 2846 SP += items; 2847 PUTBACK ; 2848 } 2849 } 2850 /* We assume first XSUB in &DB::sub is the called one. */ 2851 if (PL_curcopdb) { 2852 SAVEVPTR(PL_curcop); 2853 PL_curcop = PL_curcopdb; 2854 PL_curcopdb = NULL; 2855 } 2856 /* Do we need to open block here? XXXX */ 2857 (void)(*CvXSUB(cv))(aTHX_ cv); 2858 2859 /* Enforce some sanity in scalar context. */ 2860 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) { 2861 if (markix > PL_stack_sp - PL_stack_base) 2862 *(PL_stack_base + markix) = &PL_sv_undef; 2863 else 2864 *(PL_stack_base + markix) = *PL_stack_sp; 2865 PL_stack_sp = PL_stack_base + markix; 2866 } 2867 } 2868 LEAVE; 2869 return NORMAL; 2870 } 2871 else { 2872 dMARK; 2873 register I32 items = SP - MARK; 2874 AV* padlist = CvPADLIST(cv); 2875 push_return(PL_op->op_next); 2876 PUSHBLOCK(cx, CXt_SUB, MARK); 2877 PUSHSUB(cx); 2878 CvDEPTH(cv)++; 2879 /* XXX This would be a natural place to set C<PL_compcv = cv> so 2880 * that eval'' ops within this sub know the correct lexical space. 2881 * Owing the speed considerations, we choose instead to search for 2882 * the cv using find_runcv() when calling doeval(). 2883 */ 2884 if (CvDEPTH(cv) >= 2) { 2885 PERL_STACK_OVERFLOW_CHECK(); 2886 pad_push(padlist, CvDEPTH(cv), 1); 2887 } 2888#ifdef USE_5005THREADS 2889 if (!hasargs) { 2890 AV* av = (AV*)PAD_SVl(0); 2891 2892 items = AvFILLp(av) + 1; 2893 if (items) { 2894 /* Mark is at the end of the stack. */ 2895 EXTEND(SP, items); 2896 Copy(AvARRAY(av), SP + 1, items, SV*); 2897 SP += items; 2898 PUTBACK ; 2899 } 2900 } 2901#endif /* USE_5005THREADS */ 2902 PAD_SET_CUR(padlist, CvDEPTH(cv)); 2903#ifndef USE_5005THREADS 2904 if (hasargs) 2905#endif /* USE_5005THREADS */ 2906 { 2907 AV* av; 2908 SV** ary; 2909 2910#if 0 2911 DEBUG_S(PerlIO_printf(Perl_debug_log, 2912 "%p entersub preparing @_\n", thr)); 2913#endif 2914 av = (AV*)PAD_SVl(0); 2915 if (AvREAL(av)) { 2916 /* @_ is normally not REAL--this should only ever 2917 * happen when DB::sub() calls things that modify @_ */ 2918 av_clear(av); 2919 AvREAL_off(av); 2920 AvREIFY_on(av); 2921 } 2922#ifndef USE_5005THREADS 2923 cx->blk_sub.savearray = GvAV(PL_defgv); 2924 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); 2925#endif /* USE_5005THREADS */ 2926 CX_CURPAD_SAVE(cx->blk_sub); 2927 cx->blk_sub.argarray = av; 2928 ++MARK; 2929 2930 if (items > AvMAX(av) + 1) { 2931 ary = AvALLOC(av); 2932 if (AvARRAY(av) != ary) { 2933 AvMAX(av) += AvARRAY(av) - AvALLOC(av); 2934 SvPVX(av) = (char*)ary; 2935 } 2936 if (items > AvMAX(av) + 1) { 2937 AvMAX(av) = items - 1; 2938 Renew(ary,items,SV*); 2939 AvALLOC(av) = ary; 2940 SvPVX(av) = (char*)ary; 2941 } 2942 } 2943 Copy(MARK,AvARRAY(av),items,SV*); 2944 AvFILLp(av) = items - 1; 2945 2946 while (items--) { 2947 if (*MARK) 2948 SvTEMP_off(*MARK); 2949 MARK++; 2950 } 2951 } 2952 /* warning must come *after* we fully set up the context 2953 * stuff so that __WARN__ handlers can safely dounwind() 2954 * if they want to 2955 */ 2956 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION) 2957 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))) 2958 sub_crush_depth(cv); 2959#if 0 2960 DEBUG_S(PerlIO_printf(Perl_debug_log, 2961 "%p entersub returning %p\n", thr, CvSTART(cv))); 2962#endif 2963 RETURNOP(CvSTART(cv)); 2964 } 2965} 2966 2967void 2968Perl_sub_crush_depth(pTHX_ CV *cv) 2969{ 2970 if (CvANON(cv)) 2971 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); 2972 else { 2973 SV* tmpstr = sv_newmortal(); 2974 gv_efullname3(tmpstr, CvGV(cv), Nullch); 2975 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"", 2976 tmpstr); 2977 } 2978} 2979 2980PP(pp_aelem) 2981{ 2982 dSP; 2983 SV** svp; 2984 SV* elemsv = POPs; 2985 IV elem = SvIV(elemsv); 2986 AV* av = (AV*)POPs; 2987 U32 lval = PL_op->op_flags & OPf_MOD || LVRET; 2988 U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); 2989 SV *sv; 2990 2991 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)) 2992 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv); 2993 if (elem > 0) 2994 elem -= PL_curcop->cop_arybase; 2995 if (SvTYPE(av) != SVt_PVAV) 2996 RETPUSHUNDEF; 2997 svp = av_fetch(av, elem, lval && !defer); 2998 if (lval) { 2999#ifdef PERL_MALLOC_WRAP 3000 static const char oom_array_extend[] = 3001 "Out of memory during array extend"; /* Duplicated in av.c */ 3002 if (SvUOK(elemsv)) { 3003 UV uv = SvUV(elemsv); 3004 elem = uv > IV_MAX ? IV_MAX : uv; 3005 } 3006 else if (SvNOK(elemsv)) 3007 elem = (IV)SvNV(elemsv); 3008 if (elem > 0) 3009 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend); 3010#endif 3011 if (!svp || *svp == &PL_sv_undef) { 3012 SV* lv; 3013 if (!defer) 3014 DIE(aTHX_ PL_no_aelem, elem); 3015 lv = sv_newmortal(); 3016 sv_upgrade(lv, SVt_PVLV); 3017 LvTYPE(lv) = 'y'; 3018 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0); 3019 LvTARG(lv) = SvREFCNT_inc(av); 3020 LvTARGOFF(lv) = elem; 3021 LvTARGLEN(lv) = 1; 3022 PUSHs(lv); 3023 RETURN; 3024 } 3025 if (PL_op->op_private & OPpLVAL_INTRO) 3026 save_aelem(av, elem, svp); 3027 else if (PL_op->op_private & OPpDEREF) 3028 vivify_ref(*svp, PL_op->op_private & OPpDEREF); 3029 } 3030 sv = (svp ? *svp : &PL_sv_undef); 3031 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */ 3032 sv = sv_mortalcopy(sv); 3033 PUSHs(sv); 3034 RETURN; 3035} 3036 3037void 3038Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) 3039{ 3040 if (SvGMAGICAL(sv)) 3041 mg_get(sv); 3042 if (!SvOK(sv)) { 3043 if (SvREADONLY(sv)) 3044 Perl_croak(aTHX_ PL_no_modify); 3045 if (SvTYPE(sv) < SVt_RV) 3046 sv_upgrade(sv, SVt_RV); 3047 else if (SvTYPE(sv) >= SVt_PV) { 3048 (void)SvOOK_off(sv); 3049 Safefree(SvPVX(sv)); 3050 SvLEN(sv) = SvCUR(sv) = 0; 3051 } 3052 switch (to_what) { 3053 case OPpDEREF_SV: 3054 SvRV(sv) = NEWSV(355,0); 3055 break; 3056 case OPpDEREF_AV: 3057 SvRV(sv) = (SV*)newAV(); 3058 break; 3059 case OPpDEREF_HV: 3060 SvRV(sv) = (SV*)newHV(); 3061 break; 3062 } 3063 SvROK_on(sv); 3064 SvSETMAGIC(sv); 3065 } 3066} 3067 3068PP(pp_method) 3069{ 3070 dSP; 3071 SV* sv = TOPs; 3072 3073 if (SvROK(sv)) { 3074 SV* rsv = SvRV(sv); 3075 if (SvTYPE(rsv) == SVt_PVCV) { 3076 SETs(rsv); 3077 RETURN; 3078 } 3079 } 3080 3081 SETs(method_common(sv, Null(U32*))); 3082 RETURN; 3083} 3084 3085PP(pp_method_named) 3086{ 3087 dSP; 3088 SV* sv = cSVOP_sv; 3089 U32 hash = SvUVX(sv); 3090 3091 XPUSHs(method_common(sv, &hash)); 3092 RETURN; 3093} 3094 3095STATIC SV * 3096S_method_common(pTHX_ SV* meth, U32* hashp) 3097{ 3098 SV* sv; 3099 SV* ob; 3100 GV* gv; 3101 HV* stash; 3102 char* name; 3103 STRLEN namelen; 3104 char* packname = 0; 3105 SV *packsv = Nullsv; 3106 STRLEN packlen; 3107 3108 name = SvPV(meth, namelen); 3109 sv = *(PL_stack_base + TOPMARK + 1); 3110 3111 if (!sv) 3112 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name); 3113 3114 if (SvGMAGICAL(sv)) 3115 mg_get(sv); 3116 if (SvROK(sv)) 3117 ob = (SV*)SvRV(sv); 3118 else { 3119 GV* iogv; 3120 3121 /* this isn't a reference */ 3122 packname = Nullch; 3123 3124 if(SvOK(sv) && (packname = SvPV(sv, packlen))) { 3125 HE* he; 3126 he = hv_fetch_ent(PL_stashcache, sv, 0, 0); 3127 if (he) { 3128 stash = INT2PTR(HV*,SvIV(HeVAL(he))); 3129 goto fetch; 3130 } 3131 } 3132 3133 if (!SvOK(sv) || 3134 !(packname) || 3135 !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) || 3136 !(ob=(SV*)GvIO(iogv))) 3137 { 3138 /* this isn't the name of a filehandle either */ 3139 if (!packname || 3140 ((UTF8_IS_START(*packname) && DO_UTF8(sv)) 3141 ? !isIDFIRST_utf8((U8*)packname) 3142 : !isIDFIRST(*packname) 3143 )) 3144 { 3145 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name, 3146 SvOK(sv) ? "without a package or object reference" 3147 : "on an undefined value"); 3148 } 3149 /* assume it's a package name */ 3150 stash = gv_stashpvn(packname, packlen, FALSE); 3151 if (!stash) 3152 packsv = sv; 3153 else { 3154 SV* ref = newSViv(PTR2IV(stash)); 3155 hv_store(PL_stashcache, packname, packlen, ref, 0); 3156 } 3157 goto fetch; 3158 } 3159 /* it _is_ a filehandle name -- replace with a reference */ 3160 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv)); 3161 } 3162 3163 /* if we got here, ob should be a reference or a glob */ 3164 if (!ob || !(SvOBJECT(ob) 3165 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob)) 3166 && SvOBJECT(ob)))) 3167 { 3168 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference", 3169 name); 3170 } 3171 3172 stash = SvSTASH(ob); 3173 3174 fetch: 3175 /* NOTE: stash may be null, hope hv_fetch_ent and 3176 gv_fetchmethod can cope (it seems they can) */ 3177 3178 /* shortcut for simple names */ 3179 if (hashp) { 3180 HE* he = hv_fetch_ent(stash, meth, 0, *hashp); 3181 if (he) { 3182 gv = (GV*)HeVAL(he); 3183 if (isGV(gv) && GvCV(gv) && 3184 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation)) 3185 return (SV*)GvCV(gv); 3186 } 3187 } 3188 3189 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name); 3190 3191 if (!gv) { 3192 /* This code tries to figure out just what went wrong with 3193 gv_fetchmethod. It therefore needs to duplicate a lot of 3194 the internals of that function. We can't move it inside 3195 Perl_gv_fetchmethod_autoload(), however, since that would 3196 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we 3197 don't want that. 3198 */ 3199 char* leaf = name; 3200 char* sep = Nullch; 3201 char* p; 3202 3203 for (p = name; *p; p++) { 3204 if (*p == '\'') 3205 sep = p, leaf = p + 1; 3206 else if (*p == ':' && *(p + 1) == ':') 3207 sep = p, leaf = p + 2; 3208 } 3209 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) { 3210 /* the method name is unqualified or starts with SUPER:: */ 3211 packname = sep ? CopSTASHPV(PL_curcop) : 3212 stash ? HvNAME(stash) : packname; 3213 packlen = strlen(packname); 3214 } 3215 else { 3216 /* the method name is qualified */ 3217 packname = name; 3218 packlen = sep - name; 3219 } 3220 3221 /* we're relying on gv_fetchmethod not autovivifying the stash */ 3222 if (gv_stashpvn(packname, packlen, FALSE)) { 3223 Perl_croak(aTHX_ 3224 "Can't locate object method \"%s\" via package \"%.*s\"", 3225 leaf, (int)packlen, packname); 3226 } 3227 else { 3228 Perl_croak(aTHX_ 3229 "Can't locate object method \"%s\" via package \"%.*s\"" 3230 " (perhaps you forgot to load \"%.*s\"?)", 3231 leaf, (int)packlen, packname, (int)packlen, packname); 3232 } 3233 } 3234 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv; 3235} 3236 3237#ifdef USE_5005THREADS 3238static void 3239unset_cvowner(pTHX_ void *cvarg) 3240{ 3241 register CV* cv = (CV *) cvarg; 3242 3243 DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n", 3244 thr, cv, SvPEEK((SV*)cv)))); 3245 MUTEX_LOCK(CvMUTEXP(cv)); 3246 DEBUG_S(if (CvDEPTH(cv) != 0) 3247 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n", 3248 CvDEPTH(cv))); 3249 assert(thr == CvOWNER(cv)); 3250 CvOWNER(cv) = 0; 3251 MUTEX_UNLOCK(CvMUTEXP(cv)); 3252 SvREFCNT_dec(cv); 3253} 3254#endif /* USE_5005THREADS */ 3255