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