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