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 #include "regcomp.h" 38 #include "feature.h" 39 40 /* Hot code. */ 41 42 43 #ifdef PERL_RC_STACK 44 45 /* common code for pp_wrap() and xs_wrap(): 46 * free any original arguments, and bump and shift down any return 47 * args 48 */ 49 50 STATIC void 51 S_pp_xs_wrap_return(pTHX_ I32 nargs, I32 old_sp) 52 { 53 I32 nret = (I32)(PL_stack_sp - PL_stack_base) - old_sp; 54 assert(nret >= 0); 55 56 /* bump any returned values */ 57 if (nret) { 58 SV **svp = PL_stack_sp - nret + 1; 59 while (svp <= PL_stack_sp) { 60 SvREFCNT_inc(*svp); 61 svp++; 62 } 63 } 64 65 PL_curstackinfo->si_stack_nonrc_base = 0; 66 67 /* free the original args and shift the returned valued down */ 68 if (nargs) { 69 SV **svp = PL_stack_sp - nret; 70 I32 i = nargs; 71 while (i--) { 72 SvREFCNT_dec(*svp); 73 *svp = NULL; 74 svp--; 75 } 76 77 if (nret) { 78 Move(PL_stack_sp - nret + 1, 79 PL_stack_sp - nret - nargs + 1, 80 nret, SV*); 81 } 82 PL_stack_sp -= nargs; 83 } 84 } 85 86 /* pp_wrap(): 87 * wrapper function for pp() functions to turn them into functions 88 * that can operate on a reference-counted stack, by taking a non- 89 * reference-counted copy of the current stack frame, calling the real 90 * pp() function, then incrementing the reference count of any returned 91 * args. 92 * 93 * nargs or nlists indicate the number of stack arguments or the 94 * number of stack lists (delimited by MARKs) which the function expects. 95 */ 96 OP* 97 Perl_pp_wrap(pTHX_ Perl_ppaddr_t real_pp_fn, I32 nargs, int nlists) 98 { 99 PERL_ARGS_ASSERT_PP_WRAP; 100 101 if (!rpp_stack_is_rc()) 102 /* stack-already non-RC; nothing needing wrapping */ 103 return real_pp_fn(aTHX); 104 105 OP *next_op; 106 I32 old_sp = (I32)(PL_stack_sp - PL_stack_base); 107 108 assert(nargs >= 0); 109 assert(nlists >= 0); 110 assert(AvREAL(PL_curstack)); 111 112 PL_curstackinfo->si_stack_nonrc_base = PL_stack_sp - PL_stack_base + 1; 113 114 if (nlists) { 115 assert(nargs == 0); 116 I32 mark = PL_markstack_ptr[-nlists+1]; 117 nargs = (PL_stack_sp - PL_stack_base) - mark; 118 assert(nlists <= 2); /* if ever more, make below a loop */ 119 PL_markstack_ptr[0] += nargs; 120 if (nlists == 2) 121 PL_markstack_ptr[-1] += nargs; 122 } 123 124 if (nargs) { 125 /* duplicate all the arg pointers further up the stack */ 126 rpp_extend(nargs); 127 Copy(PL_stack_sp - nargs + 1, PL_stack_sp + 1, nargs, SV*); 128 PL_stack_sp += nargs; 129 } 130 131 next_op = real_pp_fn(aTHX); 132 133 /* we should still be a split stack */ 134 assert(AvREAL(PL_curstack)); 135 assert(PL_curstackinfo->si_stack_nonrc_base); 136 137 S_pp_xs_wrap_return(aTHX_ nargs, old_sp); 138 139 return next_op; 140 } 141 142 143 /* xs_wrap(): 144 * similar in concept to pp_wrap: make a non-referenced-counted copy of 145 * a (not refcount aware) XS sub's args, call the XS subs, then bump any 146 * return values and free the original args */ 147 148 void 149 Perl_xs_wrap(pTHX_ XSUBADDR_t xsub, CV *cv) 150 { 151 PERL_ARGS_ASSERT_XS_WRAP; 152 153 I32 old_sp = (I32)(PL_stack_sp - PL_stack_base); 154 I32 mark = PL_markstack_ptr[0]; 155 I32 nargs = (PL_stack_sp - PL_stack_base) - mark; 156 157 /* we should be a fully refcounted stack */ 158 assert(AvREAL(PL_curstack)); 159 assert(!PL_curstackinfo->si_stack_nonrc_base); 160 161 PL_curstackinfo->si_stack_nonrc_base = PL_stack_sp - PL_stack_base + 1; 162 163 164 if (nargs) { 165 /* duplicate all the arg pointers further up the stack */ 166 rpp_extend(nargs); 167 Copy(PL_stack_sp - nargs + 1, PL_stack_sp + 1, nargs, SV*); 168 PL_stack_sp += nargs; 169 PL_markstack_ptr[0] += nargs; 170 } 171 172 xsub(aTHX_ cv); 173 174 S_pp_xs_wrap_return(aTHX_ nargs, old_sp); 175 } 176 177 #endif 178 179 180 181 /* Private helper function for Perl_rpp_replace_2_1_COMMON() 182 * and rpp_popfree_2_NN(). 183 * Free the two passed SVs, whose original ref counts are rc1 and rc2. 184 * Assumes the stack initially looked like 185 * .... sv1 sv2 186 * and is now: 187 * .... X 188 * but where sv2 is still on the slot above the current PL_stack_sp. 189 */ 190 191 void 192 Perl_rpp_free_2_(pTHX_ SV *const sv1, SV *const sv2, 193 const U32 rc1, const U32 rc2) 194 { 195 196 PERL_ARGS_ASSERT_RPP_FREE_2_; 197 198 #ifdef PERL_RC_STACK 199 if (rc1 > 1) 200 SvREFCNT(sv1) = rc1 - 1; 201 else { 202 /* temporarily reclaim sv2 on stack in case we die while freeing sv1 */ 203 assert(PL_stack_sp[1] == sv2); 204 PL_stack_sp++; 205 Perl_sv_free2(aTHX_ sv1, rc1); 206 PL_stack_sp--; 207 } 208 if (rc2 > 1) 209 SvREFCNT(sv2) = rc2 - 1; 210 else 211 Perl_sv_free2(aTHX_ sv2, rc2); 212 #else 213 PERL_UNUSED_VAR(sv1); 214 PERL_UNUSED_VAR(sv2); 215 PERL_UNUSED_VAR(rc1); 216 PERL_UNUSED_VAR(rc2); 217 #endif 218 } 219 220 221 222 /* ----------------------------------------------------------- */ 223 224 225 PP(pp_const) 226 { 227 rpp_xpush_1(cSVOP_sv); 228 return NORMAL; 229 } 230 231 PP(pp_nextstate) 232 { 233 PL_curcop = (COP*)PL_op; 234 TAINT_NOT; /* Each statement is presumed innocent */ 235 rpp_popfree_to_NN(PL_stack_base + CX_CUR()->blk_oldsp); 236 FREETMPS; 237 PERL_ASYNC_CHECK(); 238 return NORMAL; 239 } 240 241 PP(pp_gvsv) 242 { 243 assert(SvTYPE(cGVOP_gv) == SVt_PVGV); 244 rpp_xpush_1( 245 UNLIKELY(PL_op->op_private & OPpLVAL_INTRO) 246 ? save_scalar(cGVOP_gv) 247 : GvSVn(cGVOP_gv)); 248 return NORMAL; 249 } 250 251 252 /* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */ 253 254 PP(pp_null) 255 { 256 return NORMAL; 257 } 258 259 /* This is sometimes called directly by pp_coreargs, pp_grepstart and 260 amagic_call. */ 261 PP(pp_pushmark) 262 { 263 PUSHMARK(PL_stack_sp); 264 return NORMAL; 265 } 266 267 PP(pp_stringify) 268 { 269 dTARGET; 270 sv_copypv(TARG, *PL_stack_sp); 271 SvSETMAGIC(TARG); 272 rpp_replace_1_1_NN(TARG); 273 return NORMAL; 274 } 275 276 PP(pp_gv) 277 { 278 /* cGVOP_gv might be a real GV or might be an RV to a CV */ 279 assert(SvTYPE(cGVOP_gv) == SVt_PVGV || 280 (SvTYPE(cGVOP_gv) <= SVt_PVMG && SvROK(cGVOP_gv) && SvTYPE(SvRV(cGVOP_gv)) == SVt_PVCV)); 281 rpp_xpush_1(MUTABLE_SV(cGVOP_gv)); 282 return NORMAL; 283 } 284 285 286 /* also used for: pp_andassign() */ 287 288 PP(pp_and) 289 { 290 PERL_ASYNC_CHECK(); 291 { 292 SV * const sv = *PL_stack_sp; 293 if (!SvTRUE_NN(sv)) 294 return NORMAL; 295 else { 296 if (PL_op->op_type == OP_AND) 297 rpp_popfree_1_NN(); 298 return cLOGOP->op_other; 299 } 300 } 301 } 302 303 /* 304 * Mashup of simple padsv + sassign OPs 305 * Doesn't support the following lengthy and unlikely sassign case: 306 * (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) 307 * These cases have a separate optimization, so are not handled here: 308 * (PL_op->op_private & OPpASSIGN_BACKWARDS) {or,and,dor}assign 309 */ 310 311 PP(pp_padsv_store) 312 { 313 OP * const op = PL_op; 314 SV** const padentry = &PAD_SVl(op->op_targ); 315 SV* targ = *padentry; /* lvalue to assign into */ 316 SV* const val = *PL_stack_sp; /* RHS value to assign */ 317 318 /* !OPf_STACKED is not handled by this OP */ 319 assert(op->op_flags & OPf_STACKED); 320 321 /* Inlined, simplified pp_padsv here */ 322 if ((op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == OPpLVAL_INTRO) { 323 save_clearsv(padentry); 324 } 325 326 /* Inlined, simplified pp_sassign from here */ 327 assert(TAINTING_get || !TAINT_get); 328 if (UNLIKELY(TAINT_get) && !SvTAINTED(val)) 329 TAINT_NOT; 330 331 if ( 332 UNLIKELY(SvTEMP(targ)) && !SvSMAGICAL(targ) && SvREFCNT(targ) == 1 && 333 (!isGV_with_GP(targ) || SvFAKE(targ)) && ckWARN(WARN_MISC) 334 ) 335 Perl_warner(aTHX_ 336 packWARN(WARN_MISC), "Useless assignment to a temporary" 337 ); 338 SvSetMagicSV(targ, val); 339 340 rpp_replace_1_1_NN(targ); 341 return NORMAL; 342 } 343 344 345 /* A mashup of simplified AELEMFAST_LEX + SASSIGN OPs */ 346 347 PP(pp_aelemfastlex_store) 348 { 349 OP * const op = PL_op; 350 SV* const val = *PL_stack_sp; /* RHS value to assign */ 351 AV * const av = MUTABLE_AV(PAD_SV(op->op_targ)); 352 const I8 key = (I8)PL_op->op_private; 353 SV * targ = NULL; 354 355 /* !OPf_STACKED is not handled by this OP */ 356 assert(op->op_flags & OPf_STACKED); 357 358 /* Inlined, simplified pp_aelemfast here */ 359 assert(SvTYPE(av) == SVt_PVAV); 360 361 /* inlined av_fetch() for simple cases ... */ 362 if (!SvRMAGICAL(av) && key >=0 && key <= AvFILLp(av)) { 363 targ = AvARRAY(av)[key]; 364 } 365 /* ... else do it the hard way */ 366 if (!targ) { 367 SV **svp = av_fetch(av, key, 1); 368 369 if (svp) 370 targ = *svp; 371 else 372 DIE(aTHX_ PL_no_aelem, (int)key); 373 } 374 375 /* Inlined, simplified pp_sassign from here */ 376 assert(TAINTING_get || !TAINT_get); 377 if (UNLIKELY(TAINT_get) && !SvTAINTED(val)) 378 TAINT_NOT; 379 380 /* This assertion is a deviation from pp_sassign, which uses an if() 381 * condition to check for "Useless assignment to a temporary" and 382 * warns if the condition is true. Here, the condition should NEVER 383 * be true when the LHS is the result of an array fetch. The 384 * assertion is here as a final check that this remains the case. 385 */ 386 assert(!(SvTEMP(targ) && SvREFCNT(targ) == 1 && !SvSMAGICAL(targ))); 387 388 SvSetMagicSV(targ, val); 389 390 assert(GIMME_V == G_VOID); 391 rpp_popfree_1_NN(); 392 return NORMAL; 393 } 394 395 PP(pp_sassign) 396 { 397 /* sassign keeps its args in the optree traditionally backwards. 398 So we pop them differently. 399 */ 400 SV *left = PL_stack_sp[0]; 401 SV *right = PL_stack_sp[-1]; 402 403 if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */ 404 SV * const temp = left; 405 left = right; right = temp; 406 PL_stack_sp[0] = left; 407 PL_stack_sp[-1] = right; 408 } 409 assert(TAINTING_get || !TAINT_get); 410 if (UNLIKELY(TAINT_get) && !SvTAINTED(right)) 411 TAINT_NOT; 412 413 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) { 414 /* *foo =\&bar */ 415 SV * const cv = SvRV(right); 416 const U32 cv_type = SvTYPE(cv); 417 const bool is_gv = isGV_with_GP(left); 418 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM; 419 420 if (!got_coderef) { 421 assert(SvROK(cv)); 422 } 423 424 /* Can do the optimisation if left (LVALUE) is not a typeglob, 425 right (RVALUE) is a reference to something, and we're in void 426 context. */ 427 if (!got_coderef && !is_gv && GIMME_V == G_VOID) { 428 /* Is the target symbol table currently empty? */ 429 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV); 430 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) { 431 /* Good. Create a new proxy constant subroutine in the target. 432 The gv becomes a(nother) reference to the constant. */ 433 SV *const value = SvRV(cv); 434 435 SvUPGRADE(MUTABLE_SV(gv), SVt_IV); 436 SvPCS_IMPORTED_on(gv); 437 SvRV_set(gv, value); 438 SvREFCNT_inc_simple_void(value); 439 rpp_replace_2_1_NN(left); 440 return NORMAL; 441 } 442 } 443 444 /* Need to fix things up. */ 445 if (!is_gv) { 446 /* Need to fix GV. */ 447 SV *sv = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV)); 448 rpp_replace_1_1_NN(sv); 449 left = sv; 450 } 451 452 if (!got_coderef) { 453 /* We've been returned a constant rather than a full subroutine, 454 but they expect a subroutine reference to apply. */ 455 if (SvROK(cv)) { 456 ENTER_with_name("sassign_coderef"); 457 SvREFCNT_inc_void(SvRV(cv)); 458 /* newCONSTSUB takes a reference count on the passed in SV 459 from us. We set the name to NULL, otherwise we get into 460 all sorts of fun as the reference to our new sub is 461 donated to the GV that we're about to assign to. 462 */ 463 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL, 464 SvRV(cv)))); 465 SvREFCNT_dec_NN(cv); 466 LEAVE_with_name("sassign_coderef"); 467 } else { 468 /* What can happen for the corner case *{"BONK"} = \&{"BONK"}; 469 is that 470 First: ops for \&{"BONK"}; return us the constant in the 471 symbol table 472 Second: ops for *{"BONK"} cause that symbol table entry 473 (and our reference to it) to be upgraded from RV 474 to typeblob) 475 Thirdly: We get here. cv is actually PVGV now, and its 476 GvCV() is actually the subroutine we're looking for 477 478 So change the reference so that it points to the subroutine 479 of that typeglob, as that's what they were after all along. 480 */ 481 GV *const upgraded = MUTABLE_GV(cv); 482 CV *const source = GvCV(upgraded); 483 484 assert(source); 485 assert(CvFLAGS(source) & CVf_CONST); 486 487 SvREFCNT_inc_simple_void_NN(source); 488 SvREFCNT_dec_NN(upgraded); 489 SvRV_set(right, MUTABLE_SV(source)); 490 } 491 } 492 493 } 494 if ( 495 rpp_is_lone(left) && !SvSMAGICAL(left) && 496 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC) 497 ) 498 Perl_warner(aTHX_ 499 packWARN(WARN_MISC), "Useless assignment to a temporary" 500 ); 501 SvSetMagicSV(left, right); 502 if (LIKELY(GIMME_V == G_VOID)) 503 rpp_popfree_2_NN(); /* pop left and right */ 504 else { 505 /* pop right, leave left on the stack */ 506 assert(PL_stack_sp[-1] == right); 507 assert(PL_stack_sp[0] == left); 508 *--PL_stack_sp = left; 509 #ifdef PERL_RC_STACK 510 SvREFCNT_dec_NN(right); 511 #endif 512 } 513 514 return NORMAL; 515 } 516 517 PP(pp_cond_expr) 518 { 519 PERL_ASYNC_CHECK(); 520 bool ok = SvTRUE_NN(*PL_stack_sp); 521 rpp_popfree_1_NN(); 522 return (ok ? cLOGOP->op_other : cLOGOP->op_next); 523 } 524 525 PP(pp_unstack) 526 { 527 PERL_CONTEXT *cx; 528 PERL_ASYNC_CHECK(); 529 TAINT_NOT; /* Each statement is presumed innocent */ 530 cx = CX_CUR(); 531 rpp_popfree_to_NN(PL_stack_base + CX_CUR()->blk_oldsp); 532 FREETMPS; 533 if (!(PL_op->op_flags & OPf_SPECIAL)) { 534 assert(CxTYPE(cx) == CXt_BLOCK || CxTYPE_is_LOOP(cx)); 535 CX_LEAVE_SCOPE(cx); 536 } 537 return NORMAL; 538 } 539 540 541 /* The main body of pp_concat, not including the magic/overload and 542 * stack handling. 543 * It does targ = left . right. 544 * Moved into a separate function so that pp_multiconcat() can use it 545 * too. 546 */ 547 548 PERL_STATIC_INLINE void 549 S_do_concat(pTHX_ SV *left, SV *right, SV *targ, U8 targmy) 550 { 551 bool lbyte; 552 STRLEN rlen; 553 const char *rpv = NULL; 554 bool rbyte = FALSE; 555 bool rcopied = FALSE; 556 557 if (TARG == right && right != left) { /* $r = $l.$r */ 558 rpv = SvPV_nomg_const(right, rlen); 559 rbyte = !DO_UTF8(right); 560 right = newSVpvn_flags(rpv, rlen, SVs_TEMP); 561 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */ 562 rcopied = TRUE; 563 } 564 565 if (TARG != left) { /* not $l .= $r */ 566 STRLEN llen; 567 const char* const lpv = SvPV_nomg_const(left, llen); 568 lbyte = !DO_UTF8(left); 569 sv_setpvn(TARG, lpv, llen); 570 if (!lbyte) 571 SvUTF8_on(TARG); 572 else 573 SvUTF8_off(TARG); 574 } 575 else { /* $l .= $r and left == TARG */ 576 if (!SvOK(left)) { 577 if ((left == right /* $l .= $l */ 578 || targmy) /* $l = $l . $r */ 579 && ckWARN(WARN_UNINITIALIZED) 580 ) 581 report_uninit(left); 582 SvPVCLEAR(left); 583 } 584 else { 585 SvPV_force_nomg_nolen(left); 586 } 587 lbyte = !DO_UTF8(left); 588 if (IN_BYTES) 589 SvUTF8_off(left); 590 } 591 592 if (!rcopied) { 593 rpv = SvPV_nomg_const(right, rlen); 594 rbyte = !DO_UTF8(right); 595 } 596 if (lbyte != rbyte) { 597 if (lbyte) 598 sv_utf8_upgrade_nomg(TARG); 599 else { 600 if (!rcopied) 601 right = newSVpvn_flags(rpv, rlen, SVs_TEMP); 602 sv_utf8_upgrade_nomg(right); 603 rpv = SvPV_nomg_const(right, rlen); 604 } 605 } 606 sv_catpvn_nomg(TARG, rpv, rlen); 607 SvSETMAGIC(TARG); 608 } 609 610 611 PP(pp_concat) 612 { 613 SV *targ = (PL_op->op_flags & OPf_STACKED) 614 ? PL_stack_sp[-1] 615 : PAD_SV(PL_op->op_targ); 616 617 if (rpp_try_AMAGIC_2(concat_amg, AMGf_assign)) 618 return NORMAL; 619 620 SV *right = PL_stack_sp[0]; 621 SV *left = PL_stack_sp[-1]; 622 S_do_concat(aTHX_ left, right, targ, PL_op->op_private & OPpTARGET_MY); 623 rpp_replace_2_1_NN(targ); 624 return NORMAL; 625 } 626 627 628 /* pp_multiconcat() 629 630 Concatenate one or more args, possibly interleaved with constant string 631 segments. The result may be assigned to, or appended to, a variable or 632 expression. 633 634 Several op_flags and/or op_private bits indicate what the target is, and 635 whether it's appended to. Valid permutations are: 636 637 - (PADTMP) = (A.B.C....) 638 OPpTARGET_MY $lex = (A.B.C....) 639 OPpTARGET_MY,OPpLVAL_INTRO my $lex = (A.B.C....) 640 OPpTARGET_MY,OPpMULTICONCAT_APPEND $lex .= (A.B.C....) 641 OPf_STACKED expr = (A.B.C....) 642 OPf_STACKED,OPpMULTICONCAT_APPEND expr .= (A.B.C....) 643 644 Other combinations like (A.B).(C.D) are not optimised into a multiconcat 645 op, as it's too hard to get the correct ordering of ties, overload etc. 646 647 In addition: 648 649 OPpMULTICONCAT_FAKE: not a real concat, instead an optimised 650 sprintf "...%s...". Don't call '.' 651 overloading: only use '""' overloading. 652 653 OPpMULTICONCAT_STRINGIFY: the RHS was of the form 654 "...$a...$b..." rather than 655 "..." . $a . "..." . $b . "..." 656 657 An OP_MULTICONCAT is of type UNOP_AUX. The fixed slots of the aux array are 658 defined with PERL_MULTICONCAT_IX_FOO constants, where: 659 660 661 FOO index description 662 -------- ----- ---------------------------------- 663 NARGS 0 number of arguments 664 PLAIN_PV 1 non-utf8 constant string 665 PLAIN_LEN 2 non-utf8 constant string length 666 UTF8_PV 3 utf8 constant string 667 UTF8_LEN 4 utf8 constant string length 668 LENGTHS 5 first of nargs+1 const segment lengths 669 670 The idea is that a general string concatenation will have a fixed (known 671 at compile time) number of variable args, interspersed with constant 672 strings, e.g. "a=$a b=$b\n" 673 674 All the constant string segments "a=", " b=" and "\n" are stored as a 675 single string "a= b=\n", pointed to from the PLAIN_PV/UTF8_PV slot, along 676 with a series of segment lengths: e.g. 2,3,1. In the case where the 677 constant string is plain but has a different utf8 representation, both 678 variants are stored, and two sets of (nargs+1) segments lengths are stored 679 in the slots beginning at PERL_MULTICONCAT_IX_LENGTHS. 680 681 A segment length of -1 indicates that there is no constant string at that 682 point; this distinguishes between e.g. ($a . $b) and ($a . "" . $b), which 683 have differing overloading behaviour. 684 685 */ 686 687 PP(pp_multiconcat) 688 { 689 SV *targ; /* The SV to be assigned or appended to */ 690 char *targ_pv; /* where within SvPVX(targ) we're writing to */ 691 STRLEN targ_len; /* SvCUR(targ) */ 692 SV **toparg; /* the highest arg position on the stack */ 693 UNOP_AUX_item *aux; /* PL_op->op_aux buffer */ 694 UNOP_AUX_item *const_lens; /* the segment length array part of aux */ 695 const char *const_pv; /* the current segment of the const string buf */ 696 SSize_t nargs; /* how many args were expected */ 697 SSize_t stack_adj; /* how much to adjust PL_stack_sp on return */ 698 STRLEN grow; /* final size of destination string (targ) */ 699 UV targ_count; /* how many times targ has appeared on the RHS */ 700 bool is_append; /* OPpMULTICONCAT_APPEND flag is set */ 701 bool slow_concat; /* args too complex for quick concat */ 702 U32 dst_utf8; /* the result will be utf8 (indicate this with 703 SVf_UTF8 in a U32, rather than using bool, 704 for ease of testing and setting) */ 705 /* for each arg, holds the result of an SvPV() call */ 706 struct multiconcat_svpv { 707 const char *pv; 708 SSize_t len; 709 } 710 *targ_chain, /* chain of slots where targ has appeared on RHS */ 711 *svpv_p, /* ptr for looping through svpv_buf */ 712 *svpv_base, /* first slot (may be greater than svpv_buf), */ 713 *svpv_end, /* and slot after highest result so far, of: */ 714 svpv_buf[PERL_MULTICONCAT_MAXARG]; /* buf for storing SvPV() results */ 715 716 aux = cUNOP_AUXx(PL_op)->op_aux; 717 stack_adj = nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize; 718 is_append = cBOOL(PL_op->op_private & OPpMULTICONCAT_APPEND); 719 720 /* get targ from the stack or pad */ 721 722 toparg = PL_stack_sp; 723 if (PL_op->op_flags & OPf_STACKED) { 724 stack_adj++; 725 if (is_append) { 726 /* for 'expr .= ...', expr is the bottom item on the stack */ 727 targ = PL_stack_sp[-nargs]; 728 } 729 else { 730 /* for 'expr = ...', expr is the top item on the stack */ 731 targ = *PL_stack_sp; 732 toparg--; 733 } 734 } 735 else { 736 SV **svp = &(PAD_SVl(PL_op->op_targ)); 737 targ = *svp; 738 if (PL_op->op_private & OPpLVAL_INTRO) { 739 assert(PL_op->op_private & OPpTARGET_MY); 740 save_clearsv(svp); 741 } 742 if (!nargs) 743 /* $lex .= "const" doesn't cause anything to be pushed */ 744 rpp_extend(1); 745 } 746 747 grow = 1; /* allow for '\0' at minimum */ 748 targ_count = 0; 749 targ_chain = NULL; 750 targ_len = 0; 751 svpv_end = svpv_buf; 752 /* only utf8 variants of the const strings? */ 753 dst_utf8 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv ? 0 : SVf_UTF8; 754 755 756 /* -------------------------------------------------------------- 757 * Phase 1: 758 * 759 * stringify (i.e. SvPV()) every arg and store the resultant pv/len/utf8 760 * triplets in svpv_buf[]. Also increment 'grow' by the args' lengths. 761 * 762 * utf8 is indicated by storing a negative length. 763 * 764 * Where an arg is actually targ, the stringification is deferred: 765 * the length is set to 0, and the slot is added to targ_chain. 766 * 767 * If a magic, overloaded, or otherwise weird arg is found, which 768 * might have side effects when stringified, the loop is abandoned and 769 * we goto a code block where a more basic 'emulate calling 770 * pp_cpncat() on each arg in turn' is done. 771 */ 772 773 for (SV **svp = toparg - (nargs - 1); svp <= toparg; svp++, svpv_end++) { 774 U32 utf8; 775 STRLEN len; 776 SV *sv; 777 778 assert(svpv_end - svpv_buf < PERL_MULTICONCAT_MAXARG); 779 780 sv = *svp; 781 782 /* this if/else chain is arranged so that common/simple cases 783 * take few conditionals */ 784 785 if (LIKELY((SvFLAGS(sv) & (SVs_GMG|SVf_ROK|SVf_POK)) == SVf_POK)) { 786 /* common case: sv is a simple non-magical PV */ 787 if (targ == sv) { 788 /* targ appears on RHS. 789 * Delay storing PV pointer; instead, add slot to targ_chain 790 * so it can be populated later, after targ has been grown and 791 * we know its final SvPVX() address. 792 */ 793 targ_on_rhs: 794 svpv_end->len = 0; /* zerojng here means we can skip 795 updating later if targ_len == 0 */ 796 svpv_end->pv = (char*)targ_chain; 797 targ_chain = svpv_end; 798 targ_count++; 799 continue; 800 } 801 802 len = SvCUR(sv); 803 svpv_end->pv = SvPVX(sv); 804 } 805 else if (UNLIKELY(SvFLAGS(sv) & (SVs_GMG|SVf_ROK))) 806 /* may have side effects: tie, overload etc. 807 * Abandon 'stringify everything first' and handle 808 * args in strict order. Note that already-stringified args 809 * will be reprocessed, which is safe because the each first 810 * stringification would have been idempotent. 811 */ 812 goto do_magical; 813 else if (SvNIOK(sv)) { 814 if (targ == sv) 815 goto targ_on_rhs; 816 /* stringify general valid scalar */ 817 svpv_end->pv = sv_2pv_flags(sv, &len, 0); 818 } 819 else if (!SvOK(sv)) { 820 if (ckWARN(WARN_UNINITIALIZED)) 821 /* an undef value in the presence of warnings may trigger 822 * side affects */ 823 goto do_magical; 824 svpv_end->pv = ""; 825 len = 0; 826 } 827 else 828 goto do_magical; /* something weird */ 829 830 utf8 = (SvFLAGS(sv) & SVf_UTF8); 831 dst_utf8 |= utf8; 832 ASSUME(len < SSize_t_MAX); 833 svpv_end->len = utf8 ? -(SSize_t)len : (SSize_t)len; 834 grow += len; 835 } 836 837 /* -------------------------------------------------------------- 838 * Phase 2: 839 * 840 * Stringify targ: 841 * 842 * if targ appears on the RHS or is appended to, force stringify it; 843 * otherwise set it to "". Then set targ_len. 844 */ 845 846 if (is_append) { 847 /* abandon quick route if using targ might have side effects */ 848 if (UNLIKELY(SvFLAGS(targ) & (SVs_GMG|SVf_ROK))) 849 goto do_magical; 850 851 if (SvOK(targ)) { 852 U32 targ_utf8; 853 stringify_targ: 854 SvPV_force_nomg_nolen(targ); 855 targ_utf8 = SvFLAGS(targ) & SVf_UTF8; 856 if (UNLIKELY(dst_utf8 & ~targ_utf8)) { 857 if (LIKELY(!IN_BYTES)) 858 sv_utf8_upgrade_nomg(targ); 859 } 860 else 861 dst_utf8 |= targ_utf8; 862 863 targ_len = SvCUR(targ); 864 grow += targ_len * (targ_count + is_append); 865 goto phase3; 866 } 867 else if (ckWARN(WARN_UNINITIALIZED)) 868 /* warning might have side effects */ 869 goto do_magical; 870 /* the undef targ will be silently SvPVCLEAR()ed below */ 871 } 872 else if (UNLIKELY(SvTYPE(targ) >= SVt_REGEXP)) { 873 /* Assigning to some weird LHS type. Don't force the LHS to be an 874 * empty string; instead, do things 'long hand' by using the 875 * overload code path, which concats to a TEMP sv and does 876 * sv_catsv() calls rather than COPY()s. This ensures that even 877 * bizarre code like this doesn't break or crash: 878 * *F = *F . *F. 879 * (which makes the 'F' typeglob an alias to the 880 * '*main::F*main::F' typeglob). 881 */ 882 goto do_magical; 883 } 884 else if (targ_chain) 885 /* targ was found on RHS. 886 * Force stringify it, using the same code as the append branch 887 * above, except that we don't need the magic/overload/undef 888 * checks as these will already have been done in the phase 1 889 * loop. 890 */ 891 goto stringify_targ; 892 893 /* unrolled SvPVCLEAR() - mostly: no need to grow or set SvCUR() to 0; 894 * those will be done later. */ 895 SV_CHECK_THINKFIRST_COW_DROP(targ); 896 SvUPGRADE(targ, SVt_PV); 897 SvFLAGS(targ) &= ~(SVf_OK|SVf_IVisUV|SVf_UTF8); 898 SvFLAGS(targ) |= (SVf_POK|SVp_POK|dst_utf8); 899 900 phase3: 901 902 /* -------------------------------------------------------------- 903 * Phase 3: 904 * 905 * UTF-8 tweaks and grow targ: 906 * 907 * Now that we know the length and utf8-ness of both the targ and 908 * args, grow targ to the size needed to accumulate all the args, based 909 * on whether targ appears on the RHS, whether we're appending, and 910 * whether any non-utf8 args expand in size if converted to utf8. 911 * 912 * For the latter, if dst_utf8 we scan non-utf8 args looking for 913 * variant chars, and adjust the svpv->len value of those args to the 914 * utf8 size and negate it to flag them. At the same time we un-negate 915 * the lens of any utf8 args since after this phase we no longer care 916 * whether an arg is utf8 or not. 917 * 918 * Finally, initialise const_lens and const_pv based on utf8ness. 919 * Note that there are 3 permutations: 920 * 921 * * If the constant string is invariant whether utf8 or not (e.g. "abc"), 922 * then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] are the same as 923 * aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN] and there is one set of 924 * segment lengths. 925 * 926 * * If the string is fully utf8, e.g. "\x{100}", then 927 * aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN] == (NULL,0) and there is 928 * one set of segment lengths. 929 * 930 * * If the string has different plain and utf8 representations 931 * (e.g. "\x80"), then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]] 932 * holds the plain rep, while aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN] 933 * holds the utf8 rep, and there are 2 sets of segment lengths, 934 * with the utf8 set following after the plain set. 935 * 936 * On entry to this section the (pv,len) pairs in svpv_buf have the 937 * following meanings: 938 * (pv, len) a plain string 939 * (pv, -len) a utf8 string 940 * (NULL, 0) left-most targ \ linked together R-to-L 941 * (next, 0) other targ / in targ_chain 942 */ 943 944 /* turn off utf8 handling if 'use bytes' is in scope */ 945 if (UNLIKELY(dst_utf8 && IN_BYTES)) { 946 dst_utf8 = 0; 947 SvUTF8_off(targ); 948 /* undo all the negative lengths which flag utf8-ness */ 949 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) { 950 SSize_t len = svpv_p->len; 951 if (len < 0) 952 svpv_p->len = -len; 953 } 954 } 955 956 /* grow += total of lengths of constant string segments */ 957 { 958 SSize_t len; 959 len = aux[dst_utf8 ? PERL_MULTICONCAT_IX_UTF8_LEN 960 : PERL_MULTICONCAT_IX_PLAIN_LEN].ssize; 961 slow_concat = cBOOL(len); 962 grow += len; 963 } 964 965 const_lens = aux + PERL_MULTICONCAT_IX_LENGTHS; 966 967 if (dst_utf8) { 968 const_pv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv; 969 if ( aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv 970 && const_pv != aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv) 971 /* separate sets of lengths for plain and utf8 */ 972 const_lens += nargs + 1; 973 974 /* If the result is utf8 but some of the args aren't, 975 * calculate how much extra growth is needed for all the chars 976 * which will expand to two utf8 bytes. 977 * Also, if the growth is non-zero, negate the length to indicate 978 * that this is a variant string. Conversely, un-negate the 979 * length on utf8 args (which was only needed to flag non-utf8 980 * args in this loop */ 981 for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) { 982 SSize_t len, extra; 983 984 len = svpv_p->len; 985 if (len <= 0) { 986 svpv_p->len = -len; 987 continue; 988 } 989 990 extra = variant_under_utf8_count((U8 *) svpv_p->pv, 991 (U8 *) svpv_p->pv + len); 992 if (UNLIKELY(extra)) { 993 grow += extra; 994 /* -ve len indicates special handling */ 995 svpv_p->len = -(len + extra); 996 slow_concat = TRUE; 997 } 998 } 999 } 1000 else 1001 const_pv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv; 1002 1003 /* unrolled SvGROW(), except don't check for SVf_IsCOW, which should 1004 * already have been dropped */ 1005 assert(!SvIsCOW(targ)); 1006 targ_pv = (SvLEN(targ) < (grow) ? sv_grow(targ,grow) : SvPVX(targ)); 1007 1008 1009 /* -------------------------------------------------------------- 1010 * Phase 4: 1011 * 1012 * Now that targ has been grown, we know the final address of the targ 1013 * PVX, if needed. Preserve / move targ contents if appending or if 1014 * targ appears on RHS. 1015 * 1016 * Also update svpv_buf slots in targ_chain. 1017 * 1018 * Don't bother with any of this if the target length is zero: 1019 * targ_len is set to zero unless we're appending or targ appears on 1020 * RHS. And even if it is, we can optimise by skipping this chunk of 1021 * code for zero targ_len. In the latter case, we don't need to update 1022 * the slots in targ_chain with the (zero length) target string, since 1023 * we set the len in such slots to 0 earlier, and since the Copy() is 1024 * skipped on zero length, it doesn't matter what svpv_p->pv contains. 1025 * 1026 * On entry to this section the (pv,len) pairs in svpv_buf have the 1027 * following meanings: 1028 * (pv, len) a pure-plain or utf8 string 1029 * (pv, -(len+extra)) a plain string which will expand by 'extra' 1030 * bytes when converted to utf8 1031 * (NULL, 0) left-most targ \ linked together R-to-L 1032 * (next, 0) other targ / in targ_chain 1033 * 1034 * On exit, the targ contents will have been moved to the 1035 * earliest place they are needed (e.g. $x = "abc$x" will shift them 1036 * 3 bytes, while $x .= ... will leave them at the beginning); 1037 * and dst_pv will point to the location within SvPVX(targ) where the 1038 * next arg should be copied. 1039 */ 1040 1041 svpv_base = svpv_buf; 1042 1043 if (targ_len) { 1044 struct multiconcat_svpv *tc_stop; 1045 char *targ_buf = targ_pv; /* ptr to original targ string */ 1046 1047 assert(is_append || targ_count); 1048 1049 if (is_append) { 1050 targ_pv += targ_len; 1051 tc_stop = NULL; 1052 } 1053 else { 1054 /* The targ appears on RHS, e.g. '$t = $a . $t . $t'. 1055 * Move the current contents of targ to the first 1056 * position where it's needed, and use that as the src buffer 1057 * for any further uses (such as the second RHS $t above). 1058 * In calculating the first position, we need to sum the 1059 * lengths of all consts and args before that. 1060 */ 1061 1062 UNOP_AUX_item *lens = const_lens; 1063 /* length of first const string segment */ 1064 STRLEN offset = lens->ssize > 0 ? lens->ssize : 0; 1065 1066 assert(targ_chain); 1067 svpv_p = svpv_base; 1068 1069 for (;;) { 1070 SSize_t len; 1071 if (!svpv_p->pv) 1072 break; /* the first targ argument */ 1073 /* add lengths of the next arg and const string segment */ 1074 len = svpv_p->len; 1075 if (len < 0) /* variant args have this */ 1076 len = -len; 1077 offset += (STRLEN)len; 1078 len = (++lens)->ssize; 1079 offset += (len >= 0) ? (STRLEN)len : 0; 1080 if (!offset) { 1081 /* all args and consts so far are empty; update 1082 * the start position for the concat later */ 1083 svpv_base++; 1084 const_lens++; 1085 } 1086 svpv_p++; 1087 assert(svpv_p < svpv_end); 1088 } 1089 1090 if (offset) { 1091 targ_buf += offset; 1092 Move(targ_pv, targ_buf, targ_len, char); 1093 /* a negative length implies don't Copy(), but do increment */ 1094 svpv_p->len = -((SSize_t)targ_len); 1095 slow_concat = TRUE; 1096 } 1097 else { 1098 /* skip the first targ copy */ 1099 svpv_base++; 1100 const_lens++; 1101 targ_pv += targ_len; 1102 } 1103 1104 /* Don't populate the first targ slot in the loop below; it's 1105 * either not used because we advanced svpv_base beyond it, or 1106 * we already stored the special -targ_len value in it 1107 */ 1108 tc_stop = svpv_p; 1109 } 1110 1111 /* populate slots in svpv_buf representing targ on RHS */ 1112 while (targ_chain != tc_stop) { 1113 struct multiconcat_svpv *p = targ_chain; 1114 targ_chain = (struct multiconcat_svpv *)(p->pv); 1115 p->pv = targ_buf; 1116 p->len = (SSize_t)targ_len; 1117 } 1118 } 1119 1120 1121 /* -------------------------------------------------------------- 1122 * Phase 5: 1123 * 1124 * Append all the args in svpv_buf, plus the const strings, to targ. 1125 * 1126 * On entry to this section the (pv,len) pairs in svpv_buf have the 1127 * following meanings: 1128 * (pv, len) a pure-plain or utf8 string (which may be targ) 1129 * (pv, -(len+extra)) a plain string which will expand by 'extra' 1130 * bytes when converted to utf8 1131 * (0, -len) left-most targ, whose content has already 1132 * been copied. Just advance targ_pv by len. 1133 */ 1134 1135 /* If there are no constant strings and no special case args 1136 * (svpv_p->len < 0), use a simpler, more efficient concat loop 1137 */ 1138 if (!slow_concat) { 1139 for (svpv_p = svpv_base; svpv_p < svpv_end; svpv_p++) { 1140 SSize_t len = svpv_p->len; 1141 if (!len) 1142 continue; 1143 Copy(svpv_p->pv, targ_pv, len, char); 1144 targ_pv += len; 1145 } 1146 const_lens += (svpv_end - svpv_base + 1); 1147 } 1148 else { 1149 /* Note that we iterate the loop nargs+1 times: to append nargs 1150 * arguments and nargs+1 constant strings. For example, "-$a-$b-" 1151 */ 1152 svpv_p = svpv_base; 1153 1154 for (;;) { 1155 SSize_t len = (const_lens++)->ssize; 1156 1157 /* append next const string segment */ 1158 if (len > 0) { 1159 Copy(const_pv, targ_pv, len, char); 1160 targ_pv += len; 1161 const_pv += len; 1162 } 1163 1164 if (svpv_p == svpv_end) 1165 break; 1166 1167 /* append next arg */ 1168 len = svpv_p->len; 1169 1170 if (LIKELY(len > 0)) { 1171 Copy(svpv_p->pv, targ_pv, len, char); 1172 targ_pv += len; 1173 } 1174 else if (UNLIKELY(len < 0)) { 1175 /* negative length indicates two special cases */ 1176 const char *p = svpv_p->pv; 1177 len = -len; 1178 if (UNLIKELY(p)) { 1179 /* copy plain-but-variant pv to a utf8 targ */ 1180 char * end_pv = targ_pv + len; 1181 assert(dst_utf8); 1182 while (targ_pv < end_pv) { 1183 U8 c = (U8) *p++; 1184 append_utf8_from_native_byte(c, (U8**)&targ_pv); 1185 } 1186 } 1187 else 1188 /* arg is already-copied targ */ 1189 targ_pv += len; 1190 } 1191 1192 ++svpv_p; 1193 } 1194 } 1195 1196 *targ_pv = '\0'; 1197 SvCUR_set(targ, targ_pv - SvPVX(targ)); 1198 assert(grow >= SvCUR(targ) + 1); 1199 assert(SvLEN(targ) >= SvCUR(targ) + 1); 1200 1201 /* -------------------------------------------------------------- 1202 * Phase 6: 1203 * 1204 * return result 1205 */ 1206 1207 rpp_popfree_to_NN(PL_stack_sp - stack_adj); 1208 SvTAINT(targ); 1209 SvSETMAGIC(targ); 1210 rpp_push_1(targ); 1211 return NORMAL; 1212 1213 /* -------------------------------------------------------------- 1214 * Phase 7: 1215 * 1216 * We only get here if any of the args (or targ too in the case of 1217 * append) have something which might cause side effects, such 1218 * as magic, overload, or an undef value in the presence of warnings. 1219 * In that case, any earlier attempt to stringify the args will have 1220 * been abandoned, and we come here instead. 1221 * 1222 * Here, we concat each arg in turn the old-fashioned way: essentially 1223 * emulating pp_concat() in a loop. This means that all the weird edge 1224 * cases will be handled correctly, if not necessarily speedily. 1225 * 1226 * Note that some args may already have been stringified - those are 1227 * processed again, which is safe, since only args without side-effects 1228 * were stringified earlier. 1229 */ 1230 1231 do_magical: 1232 { 1233 SSize_t i, n; 1234 SV *left = NULL; 1235 SV *right; 1236 SV* nexttarg; 1237 bool nextappend; 1238 U32 utf8 = 0; 1239 SV **svp; 1240 const char *cpv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv; 1241 SV *csv = NULL; /* SV which will hold cpv */ 1242 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS; 1243 Size_t arg_count = 0; /* how many args have been processed */ 1244 1245 if (!cpv) { 1246 cpv = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv; 1247 utf8 = SVf_UTF8; 1248 } 1249 1250 svp = toparg - nargs + 1; 1251 1252 /* iterate for: 1253 * nargs arguments, 1254 * plus possible nargs+1 consts, 1255 * plus, if appending, a final targ in an extra last iteration 1256 */ 1257 1258 n = nargs *2 + 1; 1259 for (i = 0; i <= n; i++) { 1260 SSize_t len; 1261 1262 /* if necessary, stringify the final RHS result in 1263 * something like $targ .= "$a$b$c" - simulating 1264 * pp_stringify 1265 */ 1266 if ( i == n 1267 && (PL_op->op_private &OPpMULTICONCAT_STRINGIFY) 1268 && !(SvPOK(left)) 1269 /* extra conditions for backwards compatibility: 1270 * probably incorrect, but keep the existing behaviour 1271 * for now. The rules are: 1272 * $x = "$ov" single arg: stringify; 1273 * $x = "$ov$y" multiple args: don't stringify, 1274 * $lex = "$ov$y$z" except TARGMY with at least 2 concats 1275 */ 1276 && ( arg_count == 1 1277 || ( arg_count >= 3 1278 && !is_append 1279 && (PL_op->op_private & OPpTARGET_MY) 1280 && !(PL_op->op_private & OPpLVAL_INTRO) 1281 ) 1282 ) 1283 ) 1284 { 1285 assert(aux[PERL_MULTICONCAT_IX_PADTMP2].pad_offset); 1286 SV *tmp = PAD_SV(aux[PERL_MULTICONCAT_IX_PADTMP2].pad_offset); 1287 sv_copypv(tmp, left); 1288 SvSETMAGIC(tmp); 1289 left = tmp; 1290 } 1291 1292 /* do one extra iteration to handle $targ in $targ .= ... */ 1293 if (i == n && !is_append) 1294 break; 1295 1296 /* get the next arg SV or regen the next const SV */ 1297 len = lens[i >> 1].ssize; 1298 if (i == n) { 1299 /* handle the final targ .= (....) */ 1300 right = left; 1301 left = targ; 1302 } 1303 else if (i & 1) 1304 right = svp[(i >> 1)]; 1305 else if (len < 0) 1306 continue; /* no const in this position */ 1307 else { 1308 /* Use one of our PADTMPs to fake up the SV which would 1309 * have been returned by an OP_CONST. Try to reuse it if 1310 * possible. If the refcount has gone up, something like 1311 * overload code has taken a reference to it, so abandon 1312 * it */ 1313 if (!csv || SvREFCNT(csv) > 1 || SvLEN(csv) != 0) { 1314 if (csv) 1315 csv = newSV_type_mortal(SVt_PV); 1316 else { 1317 assert(aux[PERL_MULTICONCAT_IX_PADTMP1].pad_offset); 1318 csv = PAD_SV( 1319 aux[PERL_MULTICONCAT_IX_PADTMP1].pad_offset); 1320 SvUPGRADE(csv, SVt_PV); 1321 } 1322 1323 if (utf8) 1324 SvUTF8_on(csv); 1325 SvREADONLY_on(csv); 1326 SvPOK_on(csv); 1327 } 1328 /* use the const string buffer directly with the 1329 * SvLEN==0 trick */ 1330 1331 /* cast away constness because we think we know it's safe 1332 * (SvREADONLY) */ 1333 SvPV_set(csv, (char *)cpv); 1334 SvLEN_set(csv, 0); 1335 SvCUR_set(csv, len); 1336 1337 right = csv; 1338 cpv += len; 1339 } 1340 1341 arg_count++; 1342 1343 if (arg_count <= 1) { 1344 left = right; 1345 continue; /* need at least two SVs to concat together */ 1346 } 1347 1348 if (arg_count == 2 && i < n) { 1349 /* for the first concat, use one of the PADTMPs to emulate 1350 * the PADTMP from OP_CONST. In later iterations this will 1351 * be appended to */ 1352 nexttarg = PAD_SV(aux[PERL_MULTICONCAT_IX_PADTMP0].pad_offset); 1353 nextappend = FALSE; 1354 } 1355 else { 1356 nexttarg = left; 1357 nextappend = TRUE; 1358 } 1359 1360 /* Handle possible overloading. 1361 * This is basically an unrolled 1362 * tryAMAGICbin_MG(concat_amg, AMGf_assign); 1363 * and 1364 * Perl_try_amagic_bin() 1365 * call, but using left and right rather than 1366 * PL_stack_sp[-1], PL_stack_sp[0], 1367 * and not relying on OPf_STACKED implying .= 1368 */ 1369 1370 if ((SvFLAGS(left)|SvFLAGS(right)) & (SVf_ROK|SVs_GMG)) { 1371 SvGETMAGIC(left); 1372 if (left != right) 1373 SvGETMAGIC(right); 1374 1375 if ((SvAMAGIC(left) || SvAMAGIC(right)) 1376 /* sprintf doesn't do concat overloading, 1377 * but allow for $x .= sprintf(...) 1378 */ 1379 && ( !(PL_op->op_private & OPpMULTICONCAT_FAKE) 1380 || i == n) 1381 ) 1382 { 1383 SV * const tmpsv = amagic_call(left, right, concat_amg, 1384 (nextappend ? AMGf_assign: 0)); 1385 if (tmpsv) { 1386 /* NB: tryAMAGICbin_MG() includes an OPpTARGET_MY test 1387 * here, which isn't needed as any implicit 1388 * assign done under OPpTARGET_MY is done after 1389 * this loop */ 1390 if (nextappend) { 1391 sv_setsv(left, tmpsv); 1392 SvSETMAGIC(left); 1393 } 1394 else 1395 left = tmpsv; 1396 continue; 1397 } 1398 } 1399 1400 /* if both args are the same magical value, make one a copy */ 1401 if (left == right && SvGMAGICAL(left)) { 1402 SV * targetsv = right; 1403 /* Print the uninitialized warning now, so it includes the 1404 * variable name. */ 1405 if (!SvOK(right)) { 1406 if (ckWARN(WARN_UNINITIALIZED)) 1407 report_uninit(right); 1408 targetsv = &PL_sv_no; 1409 } 1410 left = sv_mortalcopy_flags(targetsv, 0); 1411 SvGETMAGIC(right); 1412 } 1413 } 1414 1415 /* nexttarg = left . right */ 1416 S_do_concat(aTHX_ left, right, nexttarg, 0); 1417 left = nexttarg; 1418 } 1419 1420 /* Return the result of all RHS concats, unless this op includes 1421 * an assign ($lex = x.y.z or expr = x.y.z), in which case copy 1422 * to target (which will be $lex or expr). 1423 * If we are appending, targ will already have been appended to in 1424 * the loop */ 1425 if ( !is_append 1426 && ( (PL_op->op_flags & OPf_STACKED) 1427 || (PL_op->op_private & OPpTARGET_MY)) 1428 ) { 1429 sv_setsv(targ, left); 1430 SvSETMAGIC(targ); 1431 } 1432 else 1433 targ = left; 1434 1435 rpp_popfree_to_NN(PL_stack_sp - stack_adj); 1436 rpp_push_1(targ); 1437 return NORMAL; 1438 } 1439 } 1440 1441 1442 /* push the elements of av onto the stack. 1443 * Returns PL_op->op_next to allow tail-call optimisation of its callers */ 1444 1445 STATIC OP* 1446 S_pushav(pTHX_ AV* const av) 1447 { 1448 const SSize_t maxarg = AvFILL(av) + 1; 1449 rpp_extend(maxarg); 1450 if (UNLIKELY(SvRMAGICAL(av))) { 1451 PADOFFSET i; 1452 for (i=0; i < (PADOFFSET)maxarg; i++) { 1453 SV ** const svp = av_fetch(av, i, FALSE); 1454 rpp_push_1(LIKELY(svp) 1455 ? *svp 1456 : UNLIKELY(PL_op->op_flags & OPf_MOD) 1457 ? av_nonelem(av,i) 1458 : &PL_sv_undef 1459 ); 1460 } 1461 } 1462 else { 1463 PADOFFSET i; 1464 for (i=0; i < (PADOFFSET)maxarg; i++) { 1465 SV *sv = AvARRAY(av)[i]; 1466 rpp_push_1(LIKELY(sv) 1467 ? sv 1468 : UNLIKELY(PL_op->op_flags & OPf_MOD) 1469 ? av_nonelem(av,i) 1470 : &PL_sv_undef 1471 ); 1472 } 1473 } 1474 return NORMAL; 1475 } 1476 1477 1478 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */ 1479 1480 PP(pp_padrange) 1481 { 1482 PADOFFSET base = PL_op->op_targ; 1483 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK; 1484 if (PL_op->op_flags & OPf_SPECIAL) { 1485 /* fake the RHS of my ($x,$y,..) = @_ */ 1486 PUSHMARK(PL_stack_sp); 1487 (void)S_pushav(aTHX_ GvAVn(PL_defgv)); 1488 } 1489 1490 /* note, this is only skipped for compile-time-known void cxt */ 1491 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) { 1492 int i; 1493 1494 rpp_extend(count); 1495 PUSHMARK(PL_stack_sp); 1496 for (i = 0; i <count; i++) 1497 rpp_push_1(PAD_SV(base+i)); 1498 } 1499 1500 if (PL_op->op_private & OPpLVAL_INTRO) { 1501 SV **svp = &(PAD_SVl(base)); 1502 const UV payload = (UV)( 1503 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)) 1504 | (count << SAVE_TIGHT_SHIFT) 1505 | SAVEt_CLEARPADRANGE); 1506 int i; 1507 1508 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT)); 1509 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) 1510 == (Size_t)base); 1511 { 1512 dSS_ADD; 1513 SS_ADD_UV(payload); 1514 SS_ADD_END(1); 1515 } 1516 1517 for (i = 0; i <count; i++) 1518 SvPADSTALE_off(*svp++); /* mark lexical as active */ 1519 } 1520 return NORMAL; 1521 } 1522 1523 1524 PP(pp_padsv) 1525 { 1526 { 1527 OP * const op = PL_op; 1528 /* access PL_curpad once */ 1529 SV ** const padentry = &(PAD_SVl(op->op_targ)); 1530 { 1531 dTARG; 1532 TARG = *padentry; 1533 rpp_xpush_1(TARG); 1534 } 1535 if (op->op_flags & OPf_MOD) { 1536 if (op->op_private & OPpLVAL_INTRO) 1537 if (!(op->op_private & OPpPAD_STATE)) 1538 save_clearsv(padentry); 1539 if (op->op_private & OPpDEREF) { 1540 /* *sp is equivalent to TARG here. Using *sp rather 1541 than TARG reduces the scope of TARG, so it does not 1542 span the call to save_clearsv, resulting in smaller 1543 machine code. */ 1544 rpp_replace_1_1_NN( 1545 vivify_ref(*PL_stack_sp, op->op_private & OPpDEREF)); 1546 } 1547 } 1548 return op->op_next; 1549 } 1550 } 1551 1552 1553 /* Implement readline(), and also <X> and <<X>> in the cases where X is 1554 * seen by the parser as file-handle-ish rather than glob-ish. 1555 * 1556 * It expects at least one arg: the typeglob or scalar filehandle to read 1557 * from. An empty <> isn't handled specially by this op; instead the parser 1558 * will have planted a preceding gv(*ARGV) op. 1559 * 1560 * Scalar assignment is optimised away by making the assignment target be 1561 * passed as a second argument, with OPf_STACKED set. For example, 1562 * 1563 * $x[$i] = readline($fh); 1564 * 1565 * is implemented as if written as 1566 * 1567 * readline($x[$i], $fh); 1568 * 1569 * (that is, if the perl-level readline function took two args, which it 1570 * doesn't). The 'while (<>) {...}' construct is handled specially by the 1571 * parser, but not specially by this op. The parser treats the condition 1572 * as 1573 * 1574 * defined($_ = <>) 1575 * 1576 * which is then optimised into the equivalent of 1577 * 1578 * defined(readline($_, *ARGV)) 1579 * 1580 * When called as a real function, e.g. (\&CORE::readline)->(*STDIN), 1581 * pp_coreargs() will have pushed a NULL if no argument was supplied. 1582 * 1583 * The parser decides whether '<something>' in the perl src code causes an 1584 * OP_GLOB or an OP_READLINE op to be planted. 1585 */ 1586 1587 PP(pp_readline) 1588 { 1589 SV *arg = *PL_stack_sp; 1590 1591 /* pp_coreargs pushes a NULL to indicate no args passed to 1592 * CORE::readline() */ 1593 if (arg) { 1594 SvGETMAGIC(arg); 1595 1596 /* unrolled tryAMAGICunTARGETlist(iter_amg, 0) */ 1597 SV *tmpsv; 1598 U8 gimme = GIMME_V; 1599 if (UNLIKELY(SvAMAGIC(arg) && 1600 (tmpsv = amagic_call(arg, &PL_sv_undef, iter_amg, 1601 AMGf_want_list | AMGf_noright 1602 |AMGf_unary)))) 1603 { 1604 if (gimme == G_VOID) { 1605 NOOP; 1606 } 1607 else if (gimme == G_LIST) { 1608 SSize_t i; 1609 SSize_t len; 1610 assert(SvTYPE(tmpsv) == SVt_PVAV); 1611 len = av_count((AV *)tmpsv); 1612 assert(*PL_stack_sp == arg); 1613 rpp_popfree_1_NN(); /* pop the original filehhandle arg */ 1614 /* no assignment target to pop */ 1615 assert(!(PL_op->op_flags & OPf_STACKED)); 1616 rpp_extend(len); 1617 for (i = 0; i < len; ++i) 1618 /* amagic_call() naughtily doesn't increment the ref counts 1619 * of the items it pushes onto the temporary array. So we 1620 * don't need to decrement them when shifting off. */ 1621 rpp_push_1(av_shift((AV *)tmpsv)); 1622 } 1623 else { /* AMGf_want_scalar */ 1624 /* OPf_STACKED: assignment optimised away and target 1625 * on stack */ 1626 SV *targ = (PL_op->op_flags & OPf_STACKED) 1627 ? PL_stack_sp[-1] 1628 : PAD_SV(PL_op->op_targ); 1629 sv_setsv(targ, tmpsv); 1630 SvSETMAGIC(targ); 1631 if (PL_op->op_flags & OPf_STACKED) { 1632 rpp_popfree_1_NN(); 1633 assert(*PL_stack_sp == targ); 1634 } 1635 else 1636 rpp_replace_1_1_NN(targ); 1637 } 1638 return NORMAL; 1639 } 1640 /* end of unrolled tryAMAGICunTARGETlist */ 1641 1642 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp); 1643 #ifdef PERL_RC_STACK 1644 /* PL_last_in_gv appears to be non-refcounted, so won't keep 1645 * GV alive */ 1646 if (SvREFCNT(PL_last_in_gv) < 2) 1647 sv_2mortal((SV*)PL_last_in_gv); 1648 #endif 1649 rpp_popfree_1_NN(); 1650 } 1651 else { 1652 PL_last_in_gv = PL_argvgv; 1653 PL_stack_sp--; 1654 } 1655 1656 1657 /* is it *FOO, $fh, or 'FOO' ? */ 1658 if (!isGV_with_GP(PL_last_in_gv)) { 1659 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv))) 1660 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv)); 1661 else { 1662 rpp_xpush_1(MUTABLE_SV(PL_last_in_gv)); 1663 Perl_pp_rv2gv(aTHX); 1664 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp); 1665 rpp_popfree_1_NN(); 1666 assert( (SV*)PL_last_in_gv == &PL_sv_undef 1667 || isGV_with_GP(PL_last_in_gv)); 1668 } 1669 } 1670 1671 return do_readline(); 1672 } 1673 1674 1675 PP(pp_eq) 1676 { 1677 if (rpp_try_AMAGIC_2(eq_amg, AMGf_numeric)) 1678 return NORMAL; 1679 1680 SV *right = PL_stack_sp[0]; 1681 SV *left = PL_stack_sp[-1]; 1682 1683 U32 flags_and = SvFLAGS(left) & SvFLAGS(right); 1684 U32 flags_or = SvFLAGS(left) | SvFLAGS(right); 1685 1686 rpp_replace_2_IMM_NN(boolSV( 1687 ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) ) 1688 ? (SvIVX(left) == SvIVX(right)) 1689 : (flags_and & SVf_NOK) 1690 ? (SvNVX(left) == SvNVX(right)) 1691 : ( do_ncmp(left, right) == 0) 1692 )); 1693 return NORMAL; 1694 } 1695 1696 1697 /* also used for: pp_i_preinc() */ 1698 1699 PP(pp_preinc) 1700 { 1701 SV *sv = *PL_stack_sp; 1702 1703 if (LIKELY(((sv->sv_flags & 1704 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV| 1705 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK)) 1706 == SVf_IOK)) 1707 && SvIVX(sv) != IV_MAX) 1708 { 1709 SvIV_set(sv, SvIVX(sv) + 1); 1710 } 1711 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */ 1712 sv_inc(sv); 1713 SvSETMAGIC(sv); 1714 return NORMAL; 1715 } 1716 1717 1718 /* also used for: pp_i_predec() */ 1719 1720 PP(pp_predec) 1721 { 1722 SV *sv = *PL_stack_sp; 1723 1724 if (LIKELY(((sv->sv_flags & 1725 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV| 1726 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK)) 1727 == SVf_IOK)) 1728 && SvIVX(sv) != IV_MIN) 1729 { 1730 SvIV_set(sv, SvIVX(sv) - 1); 1731 } 1732 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_dec */ 1733 sv_dec(sv); 1734 SvSETMAGIC(sv); 1735 return NORMAL; 1736 } 1737 1738 1739 /* also used for: pp_orassign() */ 1740 1741 PP(pp_or) 1742 { 1743 SV *sv; 1744 PERL_ASYNC_CHECK(); 1745 sv = *PL_stack_sp; 1746 if (SvTRUE_NN(sv)) 1747 return NORMAL; 1748 else { 1749 if (PL_op->op_type == OP_OR) 1750 rpp_popfree_1_NN(); 1751 return cLOGOP->op_other; 1752 } 1753 } 1754 1755 1756 /* also used for: pp_dor() pp_dorassign() */ 1757 1758 PP(pp_defined) 1759 { 1760 SV* sv = *PL_stack_sp; 1761 bool defined = FALSE; 1762 const int op_type = PL_op->op_type; 1763 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN); 1764 1765 if (is_dor) { 1766 PERL_ASYNC_CHECK(); 1767 if (UNLIKELY(!sv || !SvANY(sv))) { 1768 if (op_type == OP_DOR) 1769 rpp_popfree_1(); 1770 return cLOGOP->op_other; 1771 } 1772 } 1773 else { 1774 /* OP_DEFINED */ 1775 if (UNLIKELY(!sv || !SvANY(sv))) { 1776 rpp_replace_1_1(&PL_sv_no); 1777 return NORMAL; 1778 } 1779 } 1780 1781 /* Historically what followed was a switch on SvTYPE(sv), handling SVt_PVAV, 1782 * SVt_PVCV, SVt_PVHV and "default". `defined &sub` is still valid syntax, 1783 * hence we still need the special case PVCV code. But AVs and HVs now 1784 * should never arrive here... */ 1785 #ifdef DEBUGGING 1786 assert(SvTYPE(sv) != SVt_PVAV); 1787 assert(SvTYPE(sv) != SVt_PVHV); 1788 #endif 1789 1790 if (UNLIKELY(SvTYPE(sv) == SVt_PVCV)) { 1791 if (CvROOT(sv) || CvXSUB(sv)) 1792 defined = TRUE; 1793 } 1794 else { 1795 SvGETMAGIC(sv); 1796 if (SvOK(sv)) 1797 defined = TRUE; 1798 } 1799 1800 if (is_dor) { 1801 if(defined) 1802 return NORMAL; 1803 if(op_type == OP_DOR) 1804 rpp_popfree_1_NN(); 1805 return cLOGOP->op_other; 1806 } 1807 /* assuming OP_DEFINED */ 1808 rpp_replace_1_IMM_NN(defined ? &PL_sv_yes : &PL_sv_no); 1809 return NORMAL; 1810 } 1811 1812 1813 1814 PP(pp_add) 1815 { 1816 bool useleft; SV *svl, *svr; 1817 SV *targ = (PL_op->op_flags & OPf_STACKED) 1818 ? PL_stack_sp[-1] 1819 : PAD_SV(PL_op->op_targ); 1820 1821 if (rpp_try_AMAGIC_2(add_amg, AMGf_assign|AMGf_numeric)) 1822 return NORMAL; 1823 1824 svr = PL_stack_sp[0]; 1825 svl = PL_stack_sp[-1]; 1826 1827 #ifdef PERL_PRESERVE_IVUV 1828 1829 /* special-case some simple common cases */ 1830 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) { 1831 IV il, ir; 1832 U32 flags = (svl->sv_flags & svr->sv_flags); 1833 if (flags & SVf_IOK) { 1834 /* both args are simple IVs */ 1835 UV topl, topr; 1836 il = SvIVX(svl); 1837 ir = SvIVX(svr); 1838 do_iv: 1839 topl = ((UV)il) >> (UVSIZE * 8 - 2); 1840 topr = ((UV)ir) >> (UVSIZE * 8 - 2); 1841 1842 /* if both are in a range that can't under/overflow, do a 1843 * simple integer add: if the top of both numbers 1844 * are 00 or 11, then it's safe */ 1845 if (!( ((topl+1) | (topr+1)) & 2)) { 1846 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */ 1847 goto ret; 1848 } 1849 goto generic; 1850 } 1851 else if (flags & SVf_NOK) { 1852 /* both args are NVs */ 1853 NV nl = SvNVX(svl); 1854 NV nr = SvNVX(svr); 1855 1856 if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) { 1857 /* nothing was lost by converting to IVs */ 1858 goto do_iv; 1859 } 1860 TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */ 1861 goto ret; 1862 } 1863 } 1864 1865 generic: 1866 1867 useleft = USE_LEFT(svl); 1868 /* We must see if we can perform the addition with integers if possible, 1869 as the integer code detects overflow while the NV code doesn't. 1870 If either argument hasn't had a numeric conversion yet attempt to get 1871 the IV. It's important to do this now, rather than just assuming that 1872 it's not IOK as a PV of "9223372036854775806" may not take well to NV 1873 addition, and an SV which is NOK, NV=6.0 ought to be coerced to 1874 integer in case the second argument is IV=9223372036854775806 1875 We can (now) rely on sv_2iv to do the right thing, only setting the 1876 public IOK flag if the value in the NV (or PV) slot is truly integer. 1877 1878 A side effect is that this also aggressively prefers integer maths over 1879 fp maths for integer values. 1880 1881 How to detect overflow? 1882 1883 C 99 section 6.2.6.1 says 1884 1885 The range of nonnegative values of a signed integer type is a subrange 1886 of the corresponding unsigned integer type, and the representation of 1887 the same value in each type is the same. A computation involving 1888 unsigned operands can never overflow, because a result that cannot be 1889 represented by the resulting unsigned integer type is reduced modulo 1890 the number that is one greater than the largest value that can be 1891 represented by the resulting type. 1892 1893 (the 9th paragraph) 1894 1895 which I read as "unsigned ints wrap." 1896 1897 signed integer overflow seems to be classed as "exception condition" 1898 1899 If an exceptional condition occurs during the evaluation of an 1900 expression (that is, if the result is not mathematically defined or not 1901 in the range of representable values for its type), the behavior is 1902 undefined. 1903 1904 (6.5, the 5th paragraph) 1905 1906 I had assumed that on 2s complement machines signed arithmetic would 1907 wrap, hence coded pp_add and pp_subtract on the assumption that 1908 everything perl builds on would be happy. After much wailing and 1909 gnashing of teeth it would seem that irix64 knows its ANSI spec well, 1910 knows that it doesn't need to, and doesn't. Bah. Anyway, the all- 1911 unsigned code below is actually shorter than the old code. :-) 1912 */ 1913 1914 if (SvIV_please_nomg(svr)) { 1915 /* Unless the left argument is integer in range we are going to have to 1916 use NV maths. Hence only attempt to coerce the right argument if 1917 we know the left is integer. */ 1918 UV auv = 0; 1919 bool auvok = FALSE; 1920 bool a_valid = 0; 1921 1922 if (!useleft) { 1923 auv = 0; 1924 a_valid = auvok = 1; 1925 /* left operand is undef, treat as zero. + 0 is identity, 1926 Could TARGi or TARGu right now, but space optimise by not 1927 adding lots of code to speed up what is probably a rare-ish 1928 case. */ 1929 } else { 1930 /* Left operand is defined, so is it IV? */ 1931 if (SvIV_please_nomg(svl)) { 1932 if ((auvok = SvUOK(svl))) 1933 auv = SvUVX(svl); 1934 else { 1935 const IV aiv = SvIVX(svl); 1936 if (aiv >= 0) { 1937 auv = aiv; 1938 auvok = 1; /* Now acting as a sign flag. */ 1939 } else { 1940 /* Using 0- here and later to silence bogus warning 1941 * from MS VC */ 1942 auv = (UV) (0 - (UV) aiv); 1943 } 1944 } 1945 a_valid = 1; 1946 } 1947 } 1948 if (a_valid) { 1949 bool result_good = 0; 1950 UV result; 1951 UV buv; 1952 bool buvok = SvUOK(svr); 1953 1954 if (buvok) 1955 buv = SvUVX(svr); 1956 else { 1957 const IV biv = SvIVX(svr); 1958 if (biv >= 0) { 1959 buv = biv; 1960 buvok = 1; 1961 } else 1962 buv = (UV) (0 - (UV) biv); 1963 } 1964 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, 1965 else "IV" now, independent of how it came in. 1966 if a, b represents positive, A, B negative, a maps to -A etc 1967 a + b => (a + b) 1968 A + b => -(a - b) 1969 a + B => (a - b) 1970 A + B => -(a + b) 1971 all UV maths. negate result if A negative. 1972 add if signs same, subtract if signs differ. */ 1973 1974 if (auvok ^ buvok) { 1975 /* Signs differ. */ 1976 if (auv >= buv) { 1977 result = auv - buv; 1978 /* Must get smaller */ 1979 if (result <= auv) 1980 result_good = 1; 1981 } else { 1982 result = buv - auv; 1983 if (result <= buv) { 1984 /* result really should be -(auv-buv). as its negation 1985 of true value, need to swap our result flag */ 1986 auvok = !auvok; 1987 result_good = 1; 1988 } 1989 } 1990 } else { 1991 /* Signs same */ 1992 result = auv + buv; 1993 if (result >= auv) 1994 result_good = 1; 1995 } 1996 if (result_good) { 1997 if (auvok) 1998 TARGu(result,1); 1999 else { 2000 /* Negate result */ 2001 if (result <= (UV)IV_MIN) 2002 TARGi(result == (UV)IV_MIN 2003 ? IV_MIN : -(IV)result, 1); 2004 else { 2005 /* result valid, but out of range for IV. */ 2006 TARGn(-(NV)result, 1); 2007 } 2008 } 2009 goto ret; 2010 } /* Overflow, drop through to NVs. */ 2011 } 2012 } 2013 2014 #else 2015 useleft = USE_LEFT(svl); 2016 #endif 2017 2018 { 2019 NV value = SvNV_nomg(svr); 2020 if (!useleft) { 2021 /* left operand is undef, treat as zero. + 0.0 is identity. */ 2022 TARGn(value, 1); 2023 } 2024 else { 2025 TARGn(value + SvNV_nomg(svl), 1); 2026 } 2027 } 2028 2029 ret: 2030 rpp_replace_2_1_NN(targ); 2031 return NORMAL; 2032 } 2033 2034 2035 /* also used for: pp_aelemfast_lex() */ 2036 2037 PP(pp_aelemfast) 2038 { 2039 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX 2040 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv); 2041 const U32 lval = PL_op->op_flags & OPf_MOD; 2042 const I8 key = (I8)PL_op->op_private; 2043 SV** svp; 2044 SV *sv; 2045 2046 assert(SvTYPE(av) == SVt_PVAV); 2047 2048 /* inlined av_fetch() for simple cases ... */ 2049 if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) { 2050 sv = AvARRAY(av)[key]; 2051 if (sv) 2052 goto ret; 2053 if (!lval) { 2054 sv = &PL_sv_undef; 2055 goto ret; 2056 } 2057 } 2058 2059 /* ... else do it the hard way */ 2060 svp = av_fetch(av, key, lval); 2061 sv = (svp ? *svp : &PL_sv_undef); 2062 2063 if (UNLIKELY(!svp && lval)) 2064 DIE(aTHX_ PL_no_aelem, (int)key); 2065 2066 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */ 2067 mg_get(sv); 2068 2069 ret: 2070 rpp_xpush_1(sv); 2071 return NORMAL; 2072 } 2073 2074 PP(pp_join) 2075 { 2076 dMARK; dTARGET; 2077 MARK++; 2078 do_join(TARG, *MARK, MARK, PL_stack_sp); 2079 rpp_popfree_to_NN(MARK - 1); 2080 rpp_push_1(TARG); 2081 return NORMAL; 2082 } 2083 2084 2085 /* Oversized hot code. */ 2086 2087 /* also used for: pp_say() */ 2088 2089 PP(pp_print) 2090 { 2091 dMARK; dORIGMARK; 2092 PerlIO *fp; 2093 MAGIC *mg; 2094 GV * const gv 2095 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv; 2096 IO *io = GvIO(gv); 2097 SV *retval = &PL_sv_undef; 2098 2099 if (io 2100 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 2101 { 2102 had_magic: 2103 if (MARK == ORIGMARK) { 2104 /* If using default handle then we need to make space to 2105 * pass object as 1st arg, so move other args up ... 2106 */ 2107 rpp_extend(1); 2108 MARK = ORIGMARK; /* stack may have been realloced */ 2109 ++MARK; 2110 Move(MARK, MARK + 1, (PL_stack_sp - MARK) + 1, SV*); 2111 *MARK = NULL; 2112 ++PL_stack_sp; 2113 } 2114 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io), 2115 mg, 2116 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK 2117 | (PL_op->op_type == OP_SAY 2118 ? TIED_METHOD_SAY : 0)), 2119 PL_stack_sp - mark); 2120 } 2121 2122 if (!io) { 2123 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv))) 2124 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 2125 goto had_magic; 2126 report_evil_fh(gv); 2127 SETERRNO(EBADF,RMS_IFI); 2128 goto just_say_no; 2129 } 2130 else if (!(fp = IoOFP(io))) { 2131 if (IoIFP(io)) 2132 report_wrongway_fh(gv, '<'); 2133 else 2134 report_evil_fh(gv); 2135 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); 2136 goto just_say_no; 2137 } 2138 else { 2139 SV * const ofs = GvSV(PL_ofsgv); /* $, */ 2140 MARK++; 2141 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) { 2142 while (MARK <= PL_stack_sp) { 2143 if (!do_print(*MARK, fp)) 2144 break; 2145 MARK++; 2146 if (MARK <= PL_stack_sp) { 2147 /* don't use 'ofs' here - it may be invalidated by magic callbacks */ 2148 if (!do_print(GvSV(PL_ofsgv), fp)) { 2149 MARK--; 2150 break; 2151 } 2152 } 2153 } 2154 } 2155 else { 2156 while (MARK <= PL_stack_sp) { 2157 if (!do_print(*MARK, fp)) 2158 break; 2159 MARK++; 2160 } 2161 } 2162 if (MARK <= PL_stack_sp) 2163 goto just_say_no; 2164 else { 2165 if (PL_op->op_type == OP_SAY) { 2166 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp)) 2167 goto just_say_no; 2168 } 2169 else if (PL_ors_sv && SvOK(PL_ors_sv)) 2170 if (!do_print(PL_ors_sv, fp)) /* $\ */ 2171 goto just_say_no; 2172 2173 if (IoFLAGS(io) & IOf_FLUSH) 2174 if (PerlIO_flush(fp) == EOF) 2175 goto just_say_no; 2176 } 2177 } 2178 retval = &PL_sv_yes; 2179 2180 just_say_no: 2181 rpp_popfree_to_NN(ORIGMARK); 2182 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) 2183 rpp_xpush_IMM(retval); 2184 return NORMAL; 2185 } 2186 2187 2188 /* do the common parts of pp_padhv() and pp_rv2hv() 2189 * It assumes the caller has done rpp_extend(1) or equivalent. 2190 * 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set. 2191 * 'has_targ' indicates that the op has a target - this should 2192 * be a compile-time constant so that the code can constant-folded as 2193 * appropriate. has_targ also implies that the caller has left an 2194 * arg on the stack which needs freeing. 2195 * */ 2196 2197 PERL_STATIC_INLINE OP* 2198 S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ) 2199 { 2200 assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV); 2201 2202 if (gimme == G_LIST) { 2203 /* push all (key,value) pairs onto stack */ 2204 if (has_targ) { /* i.e. if has arg still on stack */ 2205 #ifdef PERL_RC_STACK 2206 SSize_t sp_base = PL_stack_sp - PL_stack_base; 2207 hv_pushkv(hv, 3); 2208 /* Now safe to free the original arg on the stack and shuffle 2209 * down one place anything pushed on top of it */ 2210 SSize_t nitems = PL_stack_sp - (PL_stack_base + sp_base); 2211 SV *old_sv = PL_stack_sp[-nitems]; 2212 if (nitems) 2213 Move(PL_stack_sp - nitems + 1, 2214 PL_stack_sp - nitems, nitems, SV*); 2215 PL_stack_sp--; 2216 SvREFCNT_dec_NN(old_sv); 2217 #else 2218 rpp_popfree_1_NN(); 2219 hv_pushkv(hv, 3); 2220 #endif 2221 } 2222 else 2223 hv_pushkv(hv, 3); 2224 return NORMAL; 2225 } 2226 2227 if (is_keys) 2228 /* 'keys %h' masquerading as '%h': reset iterator */ 2229 (void)hv_iterinit(hv); 2230 2231 if (gimme == G_VOID) { 2232 if (has_targ) 2233 rpp_popfree_1_NN(); 2234 return NORMAL; 2235 } 2236 2237 bool is_bool = ( PL_op->op_private & OPpTRUEBOOL 2238 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL 2239 && block_gimme() == G_VOID)); 2240 2241 MAGIC *is_tied_mg = SvRMAGICAL(hv) 2242 ? mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied) 2243 : NULL; 2244 2245 IV i = 0; 2246 SV *sv = NULL; 2247 if (UNLIKELY(is_tied_mg)) { 2248 if (is_keys && !is_bool) { 2249 i = 0; 2250 while (hv_iternext(hv)) 2251 i++; 2252 /* hv finished with. Safe to free arg now */ 2253 if (has_targ) 2254 rpp_popfree_1_NN(); 2255 goto push_i; 2256 } 2257 else { 2258 sv = magic_scalarpack(hv, is_tied_mg); 2259 /* hv finished with. Safe to free arg now */ 2260 if (has_targ) 2261 rpp_popfree_1_NN(); 2262 rpp_push_1(sv); 2263 } 2264 } 2265 else { 2266 #if defined(DYNAMIC_ENV_FETCH) && defined(VMS) 2267 /* maybe nothing set up %ENV for iteration yet... 2268 do this always (not just if HvUSEDKEYS(hv) is currently 0) because 2269 we ought to give a *consistent* answer to "how many keys?" 2270 whether we ask this op in scalar context, or get the list of all 2271 keys then check its length, and whether we do either with or without 2272 an %ENV lookup first. prime_env_iter() returns quickly if nothing 2273 needs doing. */ 2274 if (SvRMAGICAL((const SV *)hv) 2275 && mg_find((const SV *)hv, PERL_MAGIC_env)) { 2276 prime_env_iter(); 2277 } 2278 #endif 2279 i = HvUSEDKEYS(hv); 2280 2281 /* hv finished with. Safe to free arg now */ 2282 if (has_targ) 2283 rpp_popfree_1_NN(); 2284 2285 if (is_bool) { 2286 rpp_push_IMM(i ? &PL_sv_yes : &PL_sv_zero); 2287 } 2288 else { 2289 push_i: 2290 if (has_targ) { 2291 dTARGET; 2292 TARGi(i,1); 2293 rpp_push_1(targ); 2294 } 2295 else 2296 if (is_keys) { 2297 /* parent op should be an unused OP_KEYS whose targ we can 2298 * use */ 2299 dTARG; 2300 OP *k; 2301 2302 assert(!OpHAS_SIBLING(PL_op)); 2303 k = PL_op->op_sibparent; 2304 assert(k->op_type == OP_KEYS); 2305 TARG = PAD_SV(k->op_targ); 2306 TARGi(i,1); 2307 rpp_push_1(targ); 2308 } 2309 else 2310 rpp_push_1_norc(newSViv(i)); 2311 } 2312 } 2313 2314 return NORMAL; 2315 } 2316 2317 2318 /* This is also called directly by pp_lvavref. */ 2319 PP(pp_padav) 2320 { 2321 dTARGET; 2322 U8 gimme; 2323 2324 assert(SvTYPE(TARG) == SVt_PVAV); 2325 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO )) 2326 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) )) 2327 SAVECLEARSV(PAD_SVl(PL_op->op_targ)); 2328 2329 2330 if (PL_op->op_flags & OPf_REF) 2331 goto ret; 2332 2333 if (PL_op->op_private & OPpMAYBE_LVSUB) { 2334 const I32 flags = is_lvalue_sub(); 2335 if (flags && !(flags & OPpENTERSUB_INARGS)) { 2336 if (GIMME_V == G_SCALAR) 2337 /* diag_listed_as: Can't return %s to lvalue scalar context */ 2338 Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); 2339 goto ret; 2340 } 2341 } 2342 2343 gimme = GIMME_V; 2344 if (gimme == G_LIST) 2345 return S_pushav(aTHX_ (AV*)TARG); 2346 2347 if (gimme == G_VOID) 2348 return NORMAL; 2349 2350 { 2351 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; 2352 rpp_extend(1); 2353 if (!maxarg) 2354 targ = &PL_sv_zero; 2355 else if (PL_op->op_private & OPpTRUEBOOL) 2356 targ = &PL_sv_yes; 2357 else { 2358 rpp_push_1_norc(newSViv(maxarg)); 2359 return NORMAL; 2360 } 2361 rpp_push_IMM(targ); 2362 return NORMAL; 2363 } 2364 2365 ret: 2366 rpp_xpush_1(targ); 2367 return NORMAL; 2368 } 2369 2370 2371 PP(pp_padhv) 2372 { 2373 dTARGET; 2374 U8 gimme; 2375 2376 assert(SvTYPE(TARG) == SVt_PVHV); 2377 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO )) 2378 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) )) 2379 SAVECLEARSV(PAD_SVl(PL_op->op_targ)); 2380 2381 rpp_extend(1); 2382 2383 if (PL_op->op_flags & OPf_REF) { 2384 rpp_push_1(TARG); 2385 return NORMAL; 2386 } 2387 else if (PL_op->op_private & OPpMAYBE_LVSUB) { 2388 const I32 flags = is_lvalue_sub(); 2389 if (flags && !(flags & OPpENTERSUB_INARGS)) { 2390 if (GIMME_V == G_SCALAR) 2391 /* diag_listed_as: Can't return %s to lvalue scalar context */ 2392 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); 2393 rpp_push_1(TARG); 2394 return NORMAL; 2395 } 2396 } 2397 2398 gimme = GIMME_V; 2399 2400 return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme, 2401 cBOOL(PL_op->op_private & OPpPADHV_ISKEYS), 2402 0 /* has_targ*/); 2403 } 2404 2405 2406 /* also used for: pp_rv2hv() */ 2407 /* also called directly by pp_lvavref */ 2408 2409 PP(pp_rv2av) 2410 { 2411 SV *sv = *PL_stack_sp; 2412 const U8 gimme = GIMME_V; 2413 static const char an_array[] = "an ARRAY"; 2414 static const char a_hash[] = "a HASH"; 2415 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV 2416 || PL_op->op_type == OP_LVAVREF; 2417 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV; 2418 2419 SvGETMAGIC(sv); 2420 if (SvROK(sv)) { 2421 if (UNLIKELY(SvAMAGIC(sv))) { 2422 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg); 2423 } 2424 sv = SvRV(sv); 2425 if (UNLIKELY(SvTYPE(sv) != type)) 2426 /* diag_listed_as: Not an ARRAY reference */ 2427 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash); 2428 else if (UNLIKELY(PL_op->op_flags & OPf_MOD 2429 && PL_op->op_private & OPpLVAL_INTRO)) 2430 Perl_croak(aTHX_ "%s", PL_no_localize_ref); 2431 } 2432 else if (UNLIKELY(SvTYPE(sv) != type)) { 2433 GV *gv; 2434 2435 if (!isGV_with_GP(sv)) { 2436 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash, 2437 type); 2438 if (!gv) 2439 return NORMAL; 2440 } 2441 else { 2442 gv = MUTABLE_GV(sv); 2443 } 2444 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv)); 2445 if (PL_op->op_private & OPpLVAL_INTRO) 2446 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv)); 2447 } 2448 if (PL_op->op_flags & OPf_REF) { 2449 rpp_replace_1_1_NN(sv); 2450 return NORMAL; 2451 } 2452 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) { 2453 const I32 flags = is_lvalue_sub(); 2454 if (flags && !(flags & OPpENTERSUB_INARGS)) { 2455 if (gimme != G_LIST) 2456 goto croak_cant_return; 2457 rpp_replace_1_1_NN(sv); 2458 return NORMAL; 2459 } 2460 } 2461 2462 if (is_pp_rv2av) { 2463 AV *const av = MUTABLE_AV(sv); 2464 2465 if (gimme == G_LIST) { 2466 #ifdef PERL_RC_STACK 2467 SSize_t sp_base = PL_stack_sp - PL_stack_base; 2468 (void)S_pushav(aTHX_ av); 2469 /* Now safe to free the original arg on the stack and shuffle 2470 * down one place anything pushed on top of it */ 2471 SSize_t nitems = PL_stack_sp - (PL_stack_base + sp_base); 2472 SV *old_sv = PL_stack_sp[-nitems]; 2473 if (nitems) 2474 Move(PL_stack_sp - nitems + 1, 2475 PL_stack_sp - nitems, nitems, SV*); 2476 PL_stack_sp--; 2477 SvREFCNT_dec_NN(old_sv); 2478 return NORMAL; 2479 #else 2480 rpp_popfree_1_NN(); 2481 return S_pushav(aTHX_ av); 2482 #endif 2483 } 2484 2485 if (gimme == G_SCALAR) { 2486 const SSize_t maxarg = AvFILL(av) + 1; 2487 if (PL_op->op_private & OPpTRUEBOOL) 2488 rpp_replace_1_IMM_NN(maxarg ? &PL_sv_yes : &PL_sv_zero); 2489 else { 2490 dTARGET; 2491 TARGi(maxarg, 1); 2492 rpp_replace_1_1_NN(targ); 2493 } 2494 } 2495 } 2496 else { 2497 /* this static function is responsible for popping sv off stack */ 2498 return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme, 2499 cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS), 2500 1 /* has_targ*/); 2501 } 2502 return NORMAL; 2503 2504 croak_cant_return: 2505 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context", 2506 is_pp_rv2av ? "array" : "hash"); 2507 } 2508 2509 2510 STATIC void 2511 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey) 2512 { 2513 PERL_ARGS_ASSERT_DO_ODDBALL; 2514 2515 if (*oddkey) { 2516 if (ckWARN(WARN_MISC)) { 2517 const char *err; 2518 if (oddkey == firstkey && 2519 SvROK(*oddkey) && 2520 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV || 2521 SvTYPE(SvRV(*oddkey)) == SVt_PVHV)) 2522 { 2523 err = "Reference found where even-sized list expected"; 2524 } 2525 else 2526 err = "Odd number of elements in hash assignment"; 2527 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err); 2528 } 2529 2530 } 2531 } 2532 2533 2534 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which 2535 * are common to both the LHS and RHS of an aassign, and replace them 2536 * with copies. All these copies are made before the actual list assign is 2537 * done. 2538 * 2539 * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS 2540 * element ($b) to the first LH element ($a), modifies $a; when the 2541 * second assignment is done, the second RH element now has the wrong 2542 * value. So we initially replace the RHS with ($b, copy($a)). 2543 * Note that we don't need to make a copy of $b. 2544 * 2545 * The algorithm below works by, for every RHS element, mark the 2546 * corresponding LHS target element with SVf_BREAK. Then if the RHS 2547 * element is found with SVf_BREAK set, it means it would have been 2548 * modified, so make a copy. 2549 * Note that by scanning both LHS and RHS in lockstep, we avoid 2550 * unnecessary copies (like $b above) compared with a naive 2551 * "mark all LHS; copy all marked RHS; unmark all LHS". 2552 * 2553 * If the LHS element is a 'my' declaration' and has a refcount of 1, then 2554 * it can't be common and can be skipped. 2555 * 2556 * On DEBUGGING builds it takes an extra boolean, fake. If true, it means 2557 * that we thought we didn't need to call S_aassign_copy_common(), but we 2558 * have anyway for sanity checking. If we find we need to copy, then panic. 2559 */ 2560 2561 PERL_STATIC_INLINE void 2562 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem, 2563 SV **firstrelem, SV **lastrelem 2564 #ifdef DEBUGGING 2565 , bool fake 2566 #endif 2567 ) 2568 { 2569 SV **relem; 2570 SV **lelem; 2571 SSize_t lcount = lastlelem - firstlelem + 1; 2572 bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */ 2573 bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1); 2574 bool copy_all = FALSE; 2575 2576 assert(!PL_in_clean_all); /* SVf_BREAK not already in use */ 2577 assert(firstlelem < lastlelem); /* at least 2 LH elements */ 2578 assert(firstrelem < lastrelem); /* at least 2 RH elements */ 2579 2580 2581 lelem = firstlelem; 2582 /* we never have to copy the first RH element; it can't be corrupted 2583 * by assigning something to the corresponding first LH element. 2584 * So this scan does in a loop: mark LHS[N]; test RHS[N+1] 2585 */ 2586 relem = firstrelem + 1; 2587 2588 for (; relem <= lastrelem; relem++) { 2589 SV *svr; 2590 2591 /* mark next LH element */ 2592 2593 if (--lcount >= 0) { 2594 SV *svl = *lelem++; 2595 2596 if (UNLIKELY(!svl)) {/* skip AV alias marker */ 2597 assert (lelem <= lastlelem); 2598 svl = *lelem++; 2599 lcount--; 2600 } 2601 2602 assert(svl); 2603 if (SvSMAGICAL(svl)) { 2604 copy_all = TRUE; 2605 } 2606 if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) { 2607 if (!marked) 2608 return; 2609 /* this LH element will consume all further args; 2610 * no need to mark any further LH elements (if any). 2611 * But we still need to scan any remaining RHS elements; 2612 * set lcount negative to distinguish from lcount == 0, 2613 * so the loop condition continues being true 2614 */ 2615 lcount = -1; 2616 lelem--; /* no need to unmark this element */ 2617 } 2618 else if (!(do_rc1 && 2619 #ifdef PERL_RC_STACK 2620 SvREFCNT(svl) <= 2 2621 #else 2622 SvREFCNT(svl) == 1 2623 #endif 2624 ) && !SvIMMORTAL(svl)) 2625 { 2626 SvFLAGS(svl) |= SVf_BREAK; 2627 marked = TRUE; 2628 } 2629 else if (!marked) { 2630 /* don't check RH element if no SVf_BREAK flags set yet */ 2631 if (!lcount) 2632 break; 2633 continue; 2634 } 2635 } 2636 2637 /* see if corresponding RH element needs copying */ 2638 2639 assert(marked); 2640 svr = *relem; 2641 assert(svr); 2642 2643 if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) { 2644 U32 brk = (SvFLAGS(svr) & SVf_BREAK); 2645 2646 #ifdef DEBUGGING 2647 if (fake) { 2648 /* op_dump(PL_op); */ 2649 Perl_croak(aTHX_ 2650 "panic: aassign skipped needed copy of common RH elem %" 2651 UVuf, (UV)(relem - firstrelem)); 2652 } 2653 #endif 2654 2655 TAINT_NOT; /* Each item is independent */ 2656 2657 #ifndef PERL_RC_STACK 2658 /* The TODO test was eventually commented out. It's now been 2659 * revived, but only on PERL_RC_STACK builds. Continue 2660 * this hacky workaround otherwise - DAPM Sept 2023 */ 2661 2662 /* Dear TODO test in t/op/sort.t, I love you. 2663 (It's relying on a panic, not a "semi-panic" from newSVsv() 2664 and then an assertion failure below.) */ 2665 if (UNLIKELY(SvIS_FREED(svr))) { 2666 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p", 2667 (void*)svr); 2668 } 2669 #endif 2670 2671 /* avoid break flag while copying; otherwise COW etc 2672 * disabled... */ 2673 SvFLAGS(svr) &= ~SVf_BREAK; 2674 /* Not newSVsv(), as it does not allow copy-on-write, 2675 resulting in wasteful copies. 2676 Also, we use SV_NOSTEAL in case the SV is used more than 2677 once, e.g. (...) = (f())[0,0] 2678 Where the same SV appears twice on the RHS without a ref 2679 count bump. (Although I suspect that the SV won't be 2680 stealable here anyway - DAPM). 2681 */ 2682 #ifdef PERL_RC_STACK 2683 *relem = newSVsv_flags(svr, 2684 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL); 2685 SvREFCNT_dec_NN(svr); 2686 #else 2687 *relem = sv_mortalcopy_flags(svr, 2688 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL); 2689 #endif 2690 /* ... but restore afterwards in case it's needed again, 2691 * e.g. ($a,$b,$c) = (1,$a,$a) 2692 */ 2693 SvFLAGS(svr) |= brk; 2694 } 2695 2696 if (!lcount) 2697 break; 2698 } 2699 2700 if (!marked) 2701 return; 2702 2703 /*unmark LHS */ 2704 2705 while (lelem > firstlelem) { 2706 SV * const svl = *(--lelem); 2707 if (svl) 2708 SvFLAGS(svl) &= ~SVf_BREAK; 2709 } 2710 } 2711 2712 2713 /* Helper function for pp_aassign(): after performing something like 2714 * 2715 * ($<,$>) = ($>,$<); # swap real and effective uids 2716 * 2717 * the assignment to the magic variables just sets various flags in 2718 * PL_delaymagic; now we tell the OS to update the uids/gids atomically. 2719 */ 2720 2721 STATIC void 2722 S_aassign_uid(pTHX) 2723 { 2724 /* Will be used to set PL_tainting below */ 2725 Uid_t tmp_uid = PerlProc_getuid(); 2726 Uid_t tmp_euid = PerlProc_geteuid(); 2727 Gid_t tmp_gid = PerlProc_getgid(); 2728 Gid_t tmp_egid = PerlProc_getegid(); 2729 2730 /* XXX $> et al currently silently ignore failures */ 2731 if (PL_delaymagic & DM_UID) { 2732 #ifdef HAS_SETRESUID 2733 PERL_UNUSED_RESULT( 2734 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1, 2735 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1, 2736 (Uid_t)-1)); 2737 #elif defined(HAS_SETREUID) 2738 PERL_UNUSED_RESULT( 2739 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1, 2740 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1)); 2741 #else 2742 # ifdef HAS_SETRUID 2743 if ((PL_delaymagic & DM_UID) == DM_RUID) { 2744 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid)); 2745 PL_delaymagic &= ~DM_RUID; 2746 } 2747 # endif /* HAS_SETRUID */ 2748 # ifdef HAS_SETEUID 2749 if ((PL_delaymagic & DM_UID) == DM_EUID) { 2750 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid)); 2751 PL_delaymagic &= ~DM_EUID; 2752 } 2753 # endif /* HAS_SETEUID */ 2754 if (PL_delaymagic & DM_UID) { 2755 if (PL_delaymagic_uid != PL_delaymagic_euid) 2756 Perl_die(aTHX_ "No setreuid available"); 2757 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid)); 2758 } 2759 #endif /* HAS_SETRESUID */ 2760 2761 tmp_uid = PerlProc_getuid(); 2762 tmp_euid = PerlProc_geteuid(); 2763 } 2764 2765 /* XXX $> et al currently silently ignore failures */ 2766 if (PL_delaymagic & DM_GID) { 2767 #ifdef HAS_SETRESGID 2768 PERL_UNUSED_RESULT( 2769 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1, 2770 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1, 2771 (Gid_t)-1)); 2772 #elif defined(HAS_SETREGID) 2773 PERL_UNUSED_RESULT( 2774 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1, 2775 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1)); 2776 #else 2777 # ifdef HAS_SETRGID 2778 if ((PL_delaymagic & DM_GID) == DM_RGID) { 2779 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid)); 2780 PL_delaymagic &= ~DM_RGID; 2781 } 2782 # endif /* HAS_SETRGID */ 2783 # ifdef HAS_SETEGID 2784 if ((PL_delaymagic & DM_GID) == DM_EGID) { 2785 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid)); 2786 PL_delaymagic &= ~DM_EGID; 2787 } 2788 # endif /* HAS_SETEGID */ 2789 if (PL_delaymagic & DM_GID) { 2790 if (PL_delaymagic_gid != PL_delaymagic_egid) 2791 Perl_die(aTHX_ "No setregid available"); 2792 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid)); 2793 } 2794 #endif /* HAS_SETRESGID */ 2795 2796 tmp_gid = PerlProc_getgid(); 2797 tmp_egid = PerlProc_getegid(); 2798 } 2799 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) ); 2800 #ifdef NO_TAINT_SUPPORT 2801 PERL_UNUSED_VAR(tmp_uid); 2802 PERL_UNUSED_VAR(tmp_euid); 2803 PERL_UNUSED_VAR(tmp_gid); 2804 PERL_UNUSED_VAR(tmp_egid); 2805 #endif 2806 } 2807 2808 2809 PP(pp_aassign) 2810 { 2811 SV **lastlelem = PL_stack_sp; 2812 SV **lastrelem = PL_stack_base + POPMARK; 2813 SV **firstrelem = PL_stack_base + POPMARK + 1; 2814 SV **firstlelem = lastrelem + 1; 2815 2816 SV **relem; 2817 SV **lelem; 2818 U8 gimme; 2819 /* PL_delaymagic is restored by JMPENV_POP on dieing, so we 2820 * only need to save locally, not on the save stack */ 2821 U16 old_delaymagic = PL_delaymagic; 2822 #ifdef DEBUGGING 2823 bool fake = 0; 2824 #endif 2825 2826 PL_delaymagic = DM_DELAY; /* catch simultaneous items */ 2827 2828 /* If there's a common identifier on both sides we have to take 2829 * special care that assigning the identifier on the left doesn't 2830 * clobber a value on the right that's used later in the list. 2831 */ 2832 2833 /* at least 2 LH and RH elements, or commonality isn't an issue */ 2834 if (firstlelem < lastlelem && firstrelem < lastrelem) { 2835 for (relem = firstrelem+1; relem <= lastrelem; relem++) { 2836 if (SvGMAGICAL(*relem)) 2837 goto do_scan; 2838 } 2839 for (lelem = firstlelem; lelem <= lastlelem; lelem++) { 2840 if (*lelem && SvSMAGICAL(*lelem)) 2841 goto do_scan; 2842 } 2843 if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) { 2844 if (PL_op->op_private & OPpASSIGN_COMMON_RC1) { 2845 /* skip the scan if all scalars have a ref count of 1 */ 2846 for (lelem = firstlelem; lelem <= lastlelem; lelem++) { 2847 SV *sv = *lelem; 2848 if (!sv || 2849 #ifdef PERL_RC_STACK 2850 SvREFCNT(sv) <= 2 2851 #else 2852 SvREFCNT(sv) == 1 2853 #endif 2854 ) 2855 continue; 2856 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV) 2857 goto do_scan; 2858 break; 2859 } 2860 } 2861 else { 2862 do_scan: 2863 S_aassign_copy_common(aTHX_ 2864 firstlelem, lastlelem, firstrelem, lastrelem 2865 #ifdef DEBUGGING 2866 , fake 2867 #endif 2868 ); 2869 } 2870 } 2871 } 2872 #ifdef DEBUGGING 2873 else { 2874 /* on debugging builds, do the scan even if we've concluded we 2875 * don't need to, then panic if we find commonality. Note that the 2876 * scanner assumes at least 2 elements */ 2877 if (firstlelem < lastlelem && firstrelem < lastrelem) { 2878 fake = 1; 2879 goto do_scan; 2880 } 2881 } 2882 #endif 2883 2884 gimme = GIMME_V; 2885 bool is_list = (gimme == G_LIST); 2886 relem = firstrelem; 2887 lelem = firstlelem; 2888 #ifdef PERL_RC_STACK 2889 /* Where we can reset stack to at the end, without needing to free 2890 * each element. This is normally all the lelem's, but it can vary for 2891 * things like odd number of hash elements, which pushes a 2892 * &PL_sv_undef into the 'lvalue' part of the stack. 2893 */ 2894 SV ** first_discard = firstlelem; 2895 #endif 2896 2897 if (relem > lastrelem) 2898 goto no_relems; 2899 2900 /* first lelem loop while there are still relems */ 2901 while (LIKELY(lelem <= lastlelem)) { 2902 bool alias = FALSE; 2903 SV *lsv = *lelem; 2904 2905 TAINT_NOT; /* Each item stands on its own, taintwise. */ 2906 2907 assert(relem <= lastrelem); 2908 if (UNLIKELY(!lsv)) { 2909 alias = TRUE; 2910 lsv = *++lelem; 2911 ASSUME(SvTYPE(lsv) == SVt_PVAV); 2912 } 2913 2914 switch (SvTYPE(lsv)) { 2915 case SVt_PVAV: { 2916 SV **svp; 2917 SSize_t i; 2918 SSize_t nelems = lastrelem - relem + 1; 2919 AV *ary = MUTABLE_AV(lsv); 2920 2921 /* Assigning to an aggregate is tricky. First there is the 2922 * issue of commonality, e.g. @a = ($a[0]). Since the 2923 * stack isn't refcounted, clearing @a prior to storing 2924 * elements will free $a[0]. Similarly with 2925 * sub FETCH { $status[$_[1]] } @status = @tied[0,1]; 2926 * 2927 * The way to avoid these issues is to make the copy of each 2928 * SV (and we normally store a *copy* in the array) *before* 2929 * clearing the array. But this has a problem in that 2930 * if the code croaks during copying, the not-yet-stored copies 2931 * could leak. One way to avoid this is to make all the copies 2932 * mortal, but that's quite expensive. 2933 * 2934 * The current solution to these issues is to use a chunk 2935 * of the tmps stack as a temporary refcounted-stack. SVs 2936 * will be put on there during processing to avoid leaks, 2937 * but will be removed again before the end of this block, 2938 * so free_tmps() is never normally called. Also, the 2939 * sv_refcnt of the SVs doesn't have to be manipulated, since 2940 * the ownership of 1 reference count is transferred directly 2941 * from the tmps stack to the AV when the SV is stored. 2942 * 2943 * We disarm slots in the temps stack by storing PL_sv_undef 2944 * there: it doesn't matter if that SV's refcount is 2945 * repeatedly decremented during a croak. But usually this is 2946 * only an interim measure. By the end of this code block 2947 * we try where possible to not leave any PL_sv_undef's on the 2948 * tmps stack e.g. by shuffling newer entries down. 2949 * 2950 * There is one case where we don't copy: non-magical 2951 * SvTEMP(sv)'s with a ref count of 1. The only owner of these 2952 * is on the tmps stack, so its safe to directly steal the SV 2953 * rather than copying. This is common in things like function 2954 * returns, map etc, which all return a list of such SVs. 2955 * 2956 * Note however something like @a = (f())[0,0], where there is 2957 * a danger of the same SV being shared: this avoided because 2958 * when the SV is stored as $a[0], its ref count gets bumped, 2959 * so the RC==1 test fails and the second element is copied 2960 * instead. 2961 * 2962 * We also use one slot in the tmps stack to hold an extra 2963 * ref to the array, to ensure it doesn't get prematurely 2964 * freed. Again, this is removed before the end of this block. 2965 * 2966 * Note that OPpASSIGN_COMMON_AGG is used to flag a possible 2967 * @a = ($a[0]) case, but the current implementation uses the 2968 * same algorithm regardless, so ignores that flag. (It *is* 2969 * used in the hash branch below, however). 2970 * 2971 * 2972 * The net effect of this next block of code (apart from 2973 * optimisations and aliasing) is to make a copy of each 2974 * *relem and store the new SV both in the array and back on 2975 * the *relem slot of the stack, overwriting the original. 2976 * This new list of SVs will later be either returned 2977 * (G_LIST), or popped. 2978 * 2979 * Note that under PERL_RC_STACK builds most of this 2980 * complexity can be thrown away: things can be kept alive on 2981 * the argument stack without involving the temps stack. In 2982 * particular, the args are kept on the argument stack and 2983 * processed from there, rather than their pointers being 2984 * copied to the temps stack and then processed from there. 2985 */ 2986 2987 #ifndef PERL_RC_STACK 2988 /* Reserve slots for ary, plus the elems we're about to copy, 2989 * then protect ary and temporarily void the remaining slots 2990 * with &PL_sv_undef */ 2991 EXTEND_MORTAL(nelems + 1); 2992 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary); 2993 SSize_t tmps_base = PL_tmps_ix + 1; 2994 for (i = 0; i < nelems; i++) 2995 PL_tmps_stack[tmps_base + i] = &PL_sv_undef; 2996 PL_tmps_ix += nelems; 2997 #endif 2998 2999 /* Make a copy of each RHS elem and save on the tmps_stack 3000 * (or pass through where we can optimise away the copy) */ 3001 3002 if (UNLIKELY(alias)) { 3003 U32 lval = (is_list) 3004 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0; 3005 for (svp = relem; svp <= lastrelem; svp++) { 3006 SV *rsv = *svp; 3007 3008 SvGETMAGIC(rsv); 3009 if (!SvROK(rsv)) 3010 DIE(aTHX_ "Assigned value is not a reference"); 3011 if (SvTYPE(SvRV(rsv)) > SVt_PVLV) 3012 /* diag_listed_as: Assigned value is not %s reference */ 3013 DIE(aTHX_ 3014 "Assigned value is not a SCALAR reference"); 3015 if (lval) { 3016 /* XXX the 'mortal' part here is probably 3017 * unnecessary under PERL_RC_STACK. 3018 */ 3019 rsv = sv_mortalcopy(rsv); 3020 rpp_replace_at_NN(svp, rsv); 3021 } 3022 /* XXX else check for weak refs? */ 3023 #ifndef PERL_RC_STACK 3024 rsv = SvREFCNT_inc_NN(SvRV(rsv)); 3025 assert(tmps_base <= PL_tmps_max); 3026 PL_tmps_stack[tmps_base++] = rsv; 3027 #endif 3028 } 3029 } 3030 else { 3031 for (svp = relem; svp <= lastrelem; svp++) { 3032 SV *rsv = *svp; 3033 3034 if (rpp_is_lone(rsv) && !SvGMAGICAL(rsv)) { 3035 /* can skip the copy */ 3036 #ifndef PERL_RC_STACK 3037 SvREFCNT_inc_simple_void_NN(rsv); 3038 #endif 3039 SvTEMP_off(rsv); 3040 } 3041 else { 3042 SV *nsv; 3043 /* see comment in S_aassign_copy_common about 3044 * SV_NOSTEAL */ 3045 nsv = newSVsv_flags(rsv, 3046 (SV_DO_COW_SVSETSV|SV_NOSTEAL|SV_GMAGIC)); 3047 #ifdef PERL_RC_STACK 3048 rpp_replace_at_norc_NN(svp, nsv); 3049 #else 3050 /* using rpp_replace_at_norc() would mortalise, 3051 * but we're manually adding nsv to the tmps stack 3052 * below already */ 3053 rpp_replace_at_NN(svp, nsv); 3054 #endif 3055 3056 rsv = nsv; 3057 } 3058 3059 #ifndef PERL_RC_STACK 3060 assert(tmps_base <= PL_tmps_max); 3061 PL_tmps_stack[tmps_base++] = rsv; 3062 #endif 3063 } 3064 } 3065 3066 if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */ 3067 av_clear(ary); 3068 3069 /* Store in the array, the argument copies that are in the 3070 * tmps stack (or for PERL_RC_STACK, on the args stack) */ 3071 3072 #ifndef PERL_RC_STACK 3073 tmps_base -= nelems; 3074 #endif 3075 if (alias || SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) { 3076 /* for arrays we can't cheat with, use the official API */ 3077 av_extend(ary, nelems - 1); 3078 for (i = 0; i < nelems; i++) { 3079 SV **svp = 3080 #ifdef PERL_RC_STACK 3081 &relem[i]; 3082 #else 3083 &(PL_tmps_stack[tmps_base + i]); 3084 #endif 3085 3086 SV *rsv = *svp; 3087 #ifdef PERL_RC_STACK 3088 if (alias) { 3089 assert(SvROK(rsv)); 3090 rsv = SvRV(rsv); 3091 } 3092 #endif 3093 3094 /* A tied store won't take ownership of rsv, so keep 3095 * the 1 refcnt on the tmps stack; otherwise disarm 3096 * the tmps stack entry */ 3097 if (av_store(ary, i, rsv)) 3098 #ifdef PERL_RC_STACK 3099 SvREFCNT_inc_simple_NN(rsv); 3100 #else 3101 *svp = &PL_sv_undef; 3102 #endif 3103 /* av_store() may have added set magic to rsv */; 3104 SvSETMAGIC(rsv); 3105 } 3106 #ifndef PERL_RC_STACK 3107 /* disarm ary refcount: see comments below about leak */ 3108 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef; 3109 #endif 3110 } 3111 else { 3112 /* Simple array: directly access/set the guts of the AV */ 3113 SSize_t fill = nelems - 1; 3114 if (fill > AvMAX(ary)) 3115 av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary), 3116 &AvARRAY(ary)); 3117 AvFILLp(ary) = fill; 3118 #ifdef PERL_RC_STACK 3119 Copy(relem, AvARRAY(ary), nelems, SV*); 3120 /* ownership of one ref count of each elem passed to 3121 * array. Quietly remove old SVs from stack, or if need 3122 * to keep the list on the stack too, bump the count */ 3123 if (UNLIKELY(is_list)) 3124 for (i = 0; i < nelems; i++) 3125 SvREFCNT_inc_void_NN(relem[i]); 3126 else { 3127 assert(first_discard == relem + nelems); 3128 Zero(relem, nelems, SV*); 3129 first_discard = relem; 3130 } 3131 #else 3132 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*); 3133 /* Quietly remove all the SVs from the tmps stack slots, 3134 * since ary has now taken ownership of the refcnt. 3135 * Also remove ary: which will now leak if we die before 3136 * the SvREFCNT_dec_NN(ary) below */ 3137 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems)) 3138 Move(&PL_tmps_stack[tmps_base + nelems], 3139 &PL_tmps_stack[tmps_base - 1], 3140 PL_tmps_ix - (tmps_base + nelems) + 1, 3141 SV*); 3142 PL_tmps_ix -= (nelems + 1); 3143 #endif 3144 } 3145 3146 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA)) 3147 /* its assumed @ISA set magic can't die and leak ary */ 3148 SvSETMAGIC(MUTABLE_SV(ary)); 3149 3150 #ifdef PERL_RC_STACK 3151 assert(*lelem == (SV*)ary); 3152 *lelem = NULL; 3153 #endif 3154 lelem++; 3155 SvREFCNT_dec_NN(ary); 3156 relem = lastrelem + 1; 3157 goto no_relems; 3158 } 3159 3160 case SVt_PVHV: { /* normal hash */ 3161 3162 SV **svp; 3163 SSize_t i; 3164 SSize_t nelems = lastrelem - relem + 1; 3165 HV *hash = MUTABLE_HV(lsv); 3166 3167 if (UNLIKELY(nelems & 1)) { 3168 do_oddball(lastrelem, relem); 3169 /* we have firstlelem to reuse, it's not needed any more */ 3170 #ifdef PERL_RC_STACK 3171 if (lelem == lastrelem + 1) { 3172 /* the lelem slot we want to use is the 3173 * one keeping hash alive. Mortalise the hash 3174 * so it doesn't leak */ 3175 assert(lastrelem[1] == (SV*)hash); 3176 sv_2mortal((SV*)hash); 3177 } 3178 else { 3179 /* safe to repurpose old lelem slot */ 3180 assert(!lastrelem[1] || SvIMMORTAL(lastrelem[1])); 3181 } 3182 first_discard++; 3183 assert(first_discard = lastrelem + 2); 3184 #endif 3185 *++lastrelem = &PL_sv_undef; 3186 nelems++; 3187 } 3188 3189 /* See the SVt_PVAV branch above for a long description of 3190 * how the following all works. The main difference for hashes 3191 * is that we treat keys and values separately (and have 3192 * separate loops for them): as for arrays, values are always 3193 * copied (except for the SvTEMP optimisation), since they 3194 * need to be stored in the hash; while keys are only 3195 * processed where they might get prematurely freed or 3196 * whatever. The same comments about simplifying under 3197 * PERL_RC_STACK apply here too */ 3198 3199 /* tmps stack slots: 3200 * * reserve a slot for the hash keepalive; 3201 * * reserve slots for the hash values we're about to copy; 3202 * * preallocate for the keys we'll possibly copy or refcount bump 3203 * later; 3204 * then protect hash and temporarily void the remaining 3205 * value slots with &PL_sv_undef */ 3206 #ifndef PERL_RC_STACK 3207 EXTEND_MORTAL(nelems + 1); 3208 #endif 3209 /* convert to number of key/value pairs */ 3210 nelems >>= 1; 3211 3212 #ifndef PERL_RC_STACK 3213 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash); 3214 SSize_t tmps_base = PL_tmps_ix + 1; 3215 for (i = 0; i < nelems; i++) 3216 PL_tmps_stack[tmps_base + i] = &PL_sv_undef; 3217 PL_tmps_ix += nelems; 3218 #endif 3219 3220 /* Make a copy of each RHS hash value and save on the tmps_stack 3221 * (or pass through where we can optimise away the copy) */ 3222 3223 for (svp = relem + 1; svp <= lastrelem; svp += 2) { 3224 SV *rsv = *svp; 3225 3226 if (rpp_is_lone(rsv) && !SvGMAGICAL(rsv)) { 3227 /* can skip the copy */ 3228 #ifndef PERL_RC_STACK 3229 SvREFCNT_inc_simple_void_NN(rsv); 3230 #endif 3231 SvTEMP_off(rsv); 3232 } 3233 else { 3234 SV *nsv; 3235 /* see comment in S_aassign_copy_common about 3236 * SV_NOSTEAL */ 3237 nsv = newSVsv_flags(rsv, 3238 (SV_DO_COW_SVSETSV|SV_NOSTEAL|SV_GMAGIC)); 3239 #ifdef PERL_RC_STACK 3240 rpp_replace_at_norc_NN(svp, nsv); 3241 #else 3242 /* using rpp_replace_at_norc() would mortalise, 3243 * but we're manually adding nsv to the tmps stack 3244 * below already */ 3245 rpp_replace_at_NN(svp, nsv); 3246 #endif 3247 rsv = nsv; 3248 } 3249 3250 #ifndef PERL_RC_STACK 3251 assert(tmps_base <= PL_tmps_max); 3252 PL_tmps_stack[tmps_base++] = rsv; 3253 #endif 3254 } 3255 3256 #ifndef PERL_RC_STACK 3257 tmps_base -= nelems; 3258 #endif 3259 3260 3261 /* possibly protect keys */ 3262 3263 if (UNLIKELY(is_list)) { 3264 /* handle e.g. 3265 * @a = ((%h = ($$r, 1)), $r = "x"); 3266 * $_++ for %h = (1,2,3,4); 3267 */ 3268 #ifndef PERL_RC_STACK 3269 EXTEND_MORTAL(nelems); 3270 #endif 3271 for (svp = relem; svp <= lastrelem; svp += 2) { 3272 rpp_replace_at_norc_NN(svp, 3273 newSVsv_flags(*svp, 3274 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL)); 3275 } 3276 } 3277 else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) { 3278 /* for possible commonality, e.g. 3279 * %h = ($h{a},1) 3280 * avoid premature freeing RHS keys by mortalising 3281 * them. 3282 * For a magic element, make a copy so that its magic is 3283 * called *before* the hash is emptied (which may affect 3284 * a tied value for example). 3285 * In theory we should check for magic keys in all 3286 * cases, not just under OPpASSIGN_COMMON_AGG, but in 3287 * practice, !OPpASSIGN_COMMON_AGG implies only 3288 * constants or padtmps on the RHS. 3289 * 3290 * For PERL_RC_STACK, no danger of premature frees, so 3291 * just handle the magic. 3292 */ 3293 #ifdef PERL_RC_STACK 3294 for (svp = relem; svp <= lastrelem; svp += 2) { 3295 SV *rsv = *svp; 3296 if (UNLIKELY(SvGMAGICAL(rsv))) 3297 /* XXX does this actually need to be copied, or 3298 * could we just call the get magic??? */ 3299 rpp_replace_at_norc_NN(svp, 3300 newSVsv_flags(rsv, 3301 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL)); 3302 } 3303 #else 3304 EXTEND_MORTAL(nelems); 3305 for (svp = relem; svp <= lastrelem; svp += 2) { 3306 SV *rsv = *svp; 3307 if (UNLIKELY(SvGMAGICAL(rsv))) { 3308 SSize_t n; 3309 rpp_replace_at_norc_NN(svp, 3310 newSVsv_flags(rsv, 3311 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL)); 3312 /* allow other branch to continue pushing 3313 * onto tmps stack without checking each time */ 3314 n = (lastrelem - relem) >> 1; 3315 EXTEND_MORTAL(n); 3316 } 3317 else 3318 PL_tmps_stack[++PL_tmps_ix] = 3319 SvREFCNT_inc_simple_NN(rsv); 3320 } 3321 #endif 3322 } 3323 3324 if (SvRMAGICAL(hash) || HvUSEDKEYS(hash)) 3325 hv_clear(hash); 3326 3327 /* "nelems" was converted to the number of pairs earlier. */ 3328 if (nelems > PERL_HASH_DEFAULT_HvMAX) { 3329 hv_ksplit(hash, nelems); 3330 } 3331 3332 /* now assign the keys and values to the hash */ 3333 3334 #ifndef PERL_RC_STACK 3335 bool dirty_tmps = FALSE; 3336 #endif 3337 if (UNLIKELY(is_list)) { 3338 /* @a = (%h = (...)) etc */ 3339 SV **svp; 3340 SV **topelem = relem; 3341 3342 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) { 3343 SV *key = *svp++; 3344 SV *val = *svp; 3345 /* remove duplicates from list we return */ 3346 if (!hv_exists_ent(hash, key, 0)) { 3347 /* copy key back: possibly to an earlier 3348 * stack location if we encountered dups earlier, 3349 * The values will be updated later 3350 */ 3351 rpp_replace_at_NN(topelem, key); 3352 topelem += 2; 3353 } 3354 /* A tied store won't take ownership of val, so keep 3355 * the 1 refcnt on the tmps stack; otherwise disarm 3356 * the tmps stack entry */ 3357 if (hv_store_ent(hash, key, val, 0)) 3358 #ifdef PERL_RC_STACK 3359 SvREFCNT_inc_simple_NN(val); 3360 #else 3361 PL_tmps_stack[tmps_base + i] = &PL_sv_undef; 3362 else 3363 dirty_tmps = TRUE; 3364 #endif 3365 /* hv_store_ent() may have added set magic to val */; 3366 SvSETMAGIC(val); 3367 } 3368 3369 if (topelem < svp) { 3370 /* at this point we have removed the duplicate key/value 3371 * pairs from the stack, but the remaining values may be 3372 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed 3373 * the (a 2), but the stack now probably contains 3374 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) } 3375 * obliterates the earlier key. So refresh all values. */ 3376 lastrelem = topelem - 1; 3377 while (relem < lastrelem) { 3378 HE *he; 3379 he = hv_fetch_ent(hash, *relem++, 0, 0); 3380 rpp_replace_at_NN(relem++, 3381 (he ? HeVAL(he) : &PL_sv_undef)); 3382 } 3383 } 3384 } 3385 else { 3386 SV **svp; 3387 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) { 3388 SV *key = *svp++; 3389 SV *val = *svp; 3390 #ifdef PERL_RC_STACK 3391 { 3392 HE *stored = hv_store_ent(hash, key, val, 0); 3393 /* hv_store_ent() may have added set magic to val */; 3394 SvSETMAGIC(val); 3395 /* remove key and val from stack */ 3396 *svp = NULL; 3397 if (!stored) 3398 SvREFCNT_dec_NN(val); 3399 svp[-1] = NULL; 3400 SvREFCNT_dec_NN(key); 3401 } 3402 #else 3403 if (hv_store_ent(hash, key, val, 0)) 3404 PL_tmps_stack[tmps_base + i] = &PL_sv_undef; 3405 else 3406 dirty_tmps = TRUE; 3407 /* hv_store_ent() may have added set magic to val */; 3408 SvSETMAGIC(val); 3409 #endif 3410 } 3411 #ifdef PERL_RC_STACK 3412 /* now that all the key and val slots on the stack have 3413 * been discarded, we can skip freeing them on return */ 3414 assert(first_discard == lastrelem + 1); 3415 first_discard = relem; 3416 #endif 3417 } 3418 3419 #ifdef PERL_RC_STACK 3420 /* Disarm the ref-counted pointer on the stack. This will 3421 * usually point to the hash, except for the case of an odd 3422 * number of elems where the hash was mortalised and its slot 3423 * on the stack was made part of the relems with the slot's 3424 * value overwritten with &PL_sv_undef. */ 3425 if (*lelem == (SV*)hash) { 3426 *lelem = NULL; 3427 SvREFCNT_dec_NN(hash); 3428 } 3429 #else 3430 if (dirty_tmps) { 3431 /* there are still some 'live' recounts on the tmps stack 3432 * - usually caused by storing into a tied hash. So let 3433 * free_tmps() do the proper but slow job later. 3434 * Just disarm hash refcount: see comments below about leak 3435 */ 3436 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef; 3437 } 3438 else { 3439 /* Quietly remove all the SVs from the tmps stack slots, 3440 * since hash has now taken ownership of the refcnt. 3441 * Also remove hash: which will now leak if we die before 3442 * the SvREFCNT_dec_NN(hash) below */ 3443 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems)) 3444 Move(&PL_tmps_stack[tmps_base + nelems], 3445 &PL_tmps_stack[tmps_base - 1], 3446 PL_tmps_ix - (tmps_base + nelems) + 1, 3447 SV*); 3448 PL_tmps_ix -= (nelems + 1); 3449 } 3450 3451 SvREFCNT_dec_NN(hash); 3452 #endif 3453 lelem++; 3454 relem = lastrelem + 1; 3455 goto no_relems; 3456 } 3457 3458 default: 3459 if (!SvIMMORTAL(lsv)) { 3460 if (UNLIKELY( 3461 rpp_is_lone(lsv) && !SvSMAGICAL(lsv) && 3462 (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC) 3463 )) 3464 Perl_warner(aTHX_ 3465 packWARN(WARN_MISC), 3466 "Useless assignment to a temporary" 3467 ); 3468 3469 #ifndef PERL_RC_STACK 3470 /* avoid freeing $$lsv if it might be needed for further 3471 * elements, e.g. ($ref, $foo) = (1, $$ref) */ 3472 SV *ref; 3473 if ( SvROK(lsv) 3474 && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1) 3475 && lelem < lastlelem 3476 ) { 3477 SSize_t ix; 3478 SvREFCNT_inc_simple_void_NN(ref); 3479 /* an unrolled sv_2mortal */ 3480 ix = ++PL_tmps_ix; 3481 if (UNLIKELY(ix >= PL_tmps_max)) 3482 /* speculatively grow enough to cover other 3483 * possible refs */ 3484 (void)tmps_grow_p(ix + (lastlelem - lelem + 1)); 3485 PL_tmps_stack[ix] = ref; 3486 } 3487 #endif 3488 3489 sv_setsv(lsv, *relem); 3490 SvSETMAGIC(lsv); 3491 if (UNLIKELY(is_list)) 3492 rpp_replace_at_NN(relem, lsv); 3493 #ifdef PERL_RC_STACK 3494 *lelem = NULL; 3495 SvREFCNT_dec_NN(lsv); 3496 #endif 3497 } 3498 lelem++; 3499 if (++relem > lastrelem) 3500 goto no_relems; 3501 break; 3502 } /* switch */ 3503 } /* while */ 3504 3505 3506 no_relems: 3507 3508 /* simplified lelem loop for when there are no relems left */ 3509 while (LIKELY(lelem <= lastlelem)) { 3510 SV *lsv = *lelem; 3511 3512 TAINT_NOT; /* Each item stands on its own, taintwise. */ 3513 3514 if (UNLIKELY(!lsv)) { 3515 lsv = *++lelem; 3516 ASSUME(SvTYPE(lsv) == SVt_PVAV); 3517 } 3518 3519 switch (SvTYPE(lsv)) { 3520 case SVt_PVAV: 3521 if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) { 3522 av_clear((AV*)lsv); 3523 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA)) 3524 SvSETMAGIC(lsv); 3525 } 3526 break; 3527 3528 case SVt_PVHV: 3529 if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv)) 3530 hv_clear((HV*)lsv); 3531 break; 3532 3533 default: 3534 if (!SvIMMORTAL(lsv)) { 3535 sv_set_undef(lsv); 3536 SvSETMAGIC(lsv); 3537 } 3538 if (UNLIKELY(is_list)) { 3539 /* this usually grows the list of relems to be returned 3540 * into the stack space holding lelems (unless 3541 * there was previously a hash with dup elements) */ 3542 #ifdef PERL_RC_STACK 3543 assert(relem <= first_discard); 3544 assert(relem <= lelem); 3545 if (relem == first_discard) 3546 first_discard++; 3547 #endif 3548 rpp_replace_at(relem++, lsv); 3549 #ifdef PERL_RC_STACK 3550 if (relem == lelem + 1) { 3551 lelem++; 3552 /* skip the NULLing of the slot */ 3553 continue; 3554 } 3555 #endif 3556 } 3557 break; 3558 } /* switch */ 3559 #ifdef PERL_RC_STACK 3560 *lelem = NULL; 3561 SvREFCNT_dec_NN(lsv); 3562 #endif 3563 lelem++; 3564 } /* while */ 3565 3566 TAINT_NOT; /* result of list assign isn't tainted */ 3567 3568 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) 3569 /* update system UIDs and/or GIDs */ 3570 S_aassign_uid(aTHX); 3571 PL_delaymagic = old_delaymagic; 3572 3573 #ifdef PERL_RC_STACK 3574 /* On ref-counted builds, the code above should have stored 3575 * NULL in each lelem field and already freed each lelem. Thus 3576 * the popfree_to() can start at a lower point. 3577 * Under some circumstances, &PL_sv_undef might be stored rather than 3578 * NULL, but this also doesn't need its refcount decrementing. 3579 * Assert that this is true. 3580 * Note that duplicate hash keys in list context can cause 3581 * lastrelem and relem to be lower than at the start; 3582 * while an odd number of hash elements can cause lastrelem to 3583 * have a value one higher than at the start */ 3584 # ifdef DEBUGGING 3585 for (SV **svp = first_discard; svp <= PL_stack_sp; svp++) 3586 assert(!*svp || SvIMMORTAL(*svp)); 3587 # endif 3588 PL_stack_sp = first_discard - 1; 3589 3590 /* now pop all the R elements too */ 3591 rpp_popfree_to_NN((is_list ? relem : firstrelem) - 1); 3592 3593 #else 3594 /* pop all L and R elements apart from any being returned */ 3595 rpp_popfree_to_NN((is_list ? relem : firstrelem) - 1); 3596 #endif 3597 3598 if (gimme == G_SCALAR) { 3599 rpp_extend(1); 3600 SV *sv; 3601 if (PL_op->op_private & OPpASSIGN_TRUEBOOL) 3602 rpp_push_IMM((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero); 3603 else { 3604 dTARGET; 3605 TARGi(firstlelem - firstrelem, 1); 3606 sv = targ; 3607 rpp_push_1(sv); 3608 } 3609 } 3610 3611 return NORMAL; 3612 } 3613 3614 3615 PP(pp_qr) 3616 { 3617 PMOP * const pm = cPMOP; 3618 REGEXP * rx = PM_GETRE(pm); 3619 regexp *prog = ReANY(rx); 3620 SV * const pkg = RXp_ENGINE(prog)->qr_package(aTHX_ (rx)); 3621 SV * const rv = newSV_type_mortal(SVt_IV); 3622 CV **cvp; 3623 CV *cv; 3624 3625 SvUPGRADE(rv, SVt_IV); 3626 /* For a subroutine describing itself as "This is a hacky workaround" I'm 3627 loathe to use it here, but it seems to be the right fix. Or close. 3628 The key part appears to be that it's essential for pp_qr to return a new 3629 object (SV), which implies that there needs to be an effective way to 3630 generate a new SV from the existing SV that is pre-compiled in the 3631 optree. */ 3632 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx))); 3633 SvROK_on(rv); 3634 3635 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv); 3636 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) { 3637 *cvp = cv_clone(cv); 3638 SvREFCNT_dec_NN(cv); 3639 } 3640 3641 if (pkg) { 3642 HV *const stash = gv_stashsv(pkg, GV_ADD); 3643 SvREFCNT_dec_NN(pkg); 3644 (void)sv_bless(rv, stash); 3645 } 3646 3647 if (UNLIKELY(RXp_ISTAINTED(prog))) { 3648 SvTAINTED_on(rv); 3649 SvTAINTED_on(SvRV(rv)); 3650 } 3651 rpp_xpush_1(rv); 3652 return NORMAL; 3653 } 3654 3655 STATIC bool 3656 S_are_we_in_Debug_EXECUTE_r(pTHX) 3657 { 3658 /* Given a 'use re' is in effect, does it ask for outputting execution 3659 * debug info? 3660 * 3661 * This is separated from the sole place it's called, an inline function, 3662 * because it is the large-ish slow portion of the function */ 3663 3664 DECLARE_AND_GET_RE_DEBUG_FLAGS_NON_REGEX; 3665 3666 return cBOOL(RE_DEBUG_FLAG(RE_DEBUG_EXECUTE_MASK)); 3667 } 3668 3669 PERL_STATIC_INLINE bool 3670 S_should_we_output_Debug_r(pTHX_ regexp *prog) 3671 { 3672 PERL_ARGS_ASSERT_SHOULD_WE_OUTPUT_DEBUG_R; 3673 3674 /* pp_match can output regex debugging info. This function returns a 3675 * boolean as to whether or not it should. 3676 * 3677 * Under -Dr, it should. Any reasonable compiler will optimize this bit of 3678 * code away on non-debugging builds. */ 3679 if (UNLIKELY(DEBUG_r_TEST)) { 3680 return TRUE; 3681 } 3682 3683 /* If the regex engine is using the non-debugging execution routine, then 3684 * no debugging should be output. Same if the field is NULL that pluggable 3685 * engines are not supposed to fill. */ 3686 if ( LIKELY(prog->engine->exec == &Perl_regexec_flags) 3687 || UNLIKELY(prog->engine->op_comp == NULL)) 3688 { 3689 return FALSE; 3690 } 3691 3692 /* Otherwise have to check */ 3693 return S_are_we_in_Debug_EXECUTE_r(aTHX); 3694 } 3695 3696 3697 PP(pp_match) 3698 { 3699 SV *targ; 3700 PMOP *pm = cPMOP; 3701 PMOP *dynpm = pm; 3702 const char *s; 3703 const char *strend; 3704 SSize_t curpos = 0; /* initial pos() or current $+[0] */ 3705 I32 global; 3706 U8 r_flags = 0; 3707 const char *truebase; /* Start of string */ 3708 REGEXP *rx = PM_GETRE(pm); 3709 regexp *prog = ReANY(rx); 3710 bool rxtainted; 3711 const U8 gimme = GIMME_V; 3712 STRLEN len; 3713 const I32 oldsave = PL_savestack_ix; 3714 I32 had_zerolen = 0; 3715 MAGIC *mg = NULL; 3716 SSize_t sp_base; 3717 3718 if (PL_op->op_flags & OPf_STACKED) { 3719 targ = PL_stack_sp[0]; 3720 /* We have to keep targ alive on the stack. At the end we have to 3721 * free it and shuffle down all the return values by one. 3722 * Remember the position. 3723 */ 3724 sp_base = PL_stack_sp - PL_stack_base; 3725 assert(sp_base > 0); 3726 } 3727 else { 3728 sp_base = 0; 3729 if (PL_op->op_targ) 3730 targ = PAD_SV(PL_op->op_targ); 3731 else { 3732 targ = DEFSV; 3733 } 3734 rpp_extend(1); 3735 } 3736 3737 /* Skip get-magic if this is a qr// clone, because regcomp has 3738 already done it. */ 3739 truebase = prog->mother_re 3740 ? SvPV_nomg_const(TARG, len) 3741 : SvPV_const(TARG, len); 3742 if (!truebase) 3743 DIE(aTHX_ "panic: pp_match"); 3744 strend = truebase + len; 3745 rxtainted = (RXp_ISTAINTED(prog) || 3746 (TAINT_get && (pm->op_pmflags & PMf_RETAINT))); 3747 TAINT_NOT; 3748 3749 /* We need to know this in case we fail out early - pos() must be reset */ 3750 global = dynpm->op_pmflags & PMf_GLOBAL; 3751 3752 /* PMdf_USED is set after a ?? matches once */ 3753 if ( 3754 #ifdef USE_ITHREADS 3755 SvREADONLY(PL_regex_pad[pm->op_pmoffset]) 3756 #else 3757 pm->op_pmflags & PMf_USED 3758 #endif 3759 ) { 3760 if (UNLIKELY(should_we_output_Debug_r(prog))) { 3761 PerlIO_printf(Perl_debug_log, "?? already matched once"); 3762 } 3763 goto nope; 3764 } 3765 3766 /* handle the empty pattern */ 3767 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) { 3768 if (PL_curpm == PL_reg_curpm) { 3769 if (PL_curpm_under) { 3770 if (PL_curpm_under == PL_reg_curpm) { 3771 Perl_croak(aTHX_ "Infinite recursion via empty pattern"); 3772 } else { 3773 pm = PL_curpm_under; 3774 } 3775 } 3776 } else { 3777 pm = PL_curpm; 3778 } 3779 rx = PM_GETRE(pm); 3780 prog = ReANY(rx); 3781 } 3782 3783 if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) { 3784 if (UNLIKELY(should_we_output_Debug_r(prog))) { 3785 PerlIO_printf(Perl_debug_log, 3786 "String shorter than min possible regex match (%zd < %zd)\n", 3787 len, RXp_MINLEN(prog)); 3788 } 3789 goto nope; 3790 } 3791 3792 /* get pos() if //g */ 3793 if (global) { 3794 mg = mg_find_mglob(TARG); 3795 if (mg && mg->mg_len >= 0) { 3796 curpos = MgBYTEPOS(mg, TARG, truebase, len); 3797 /* last time pos() was set, it was zero-length match */ 3798 if (mg->mg_flags & MGf_MINMATCH) 3799 had_zerolen = 1; 3800 } 3801 } 3802 3803 #ifdef PERL_SAWAMPERSAND 3804 if ( RXp_NPARENS(prog) 3805 || PL_sawampersand 3806 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) 3807 || (dynpm->op_pmflags & PMf_KEEPCOPY) 3808 ) 3809 #endif 3810 { 3811 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE); 3812 /* In @a = /(.)/g, we iterate multiple times, but copy the buffer 3813 * only on the first iteration. Therefore we need to copy $' as well 3814 * as $&, to make the rest of the string available for captures in 3815 * subsequent iterations */ 3816 if (! (global && gimme == G_LIST)) 3817 r_flags |= REXEC_COPY_SKIP_POST; 3818 }; 3819 #ifdef PERL_SAWAMPERSAND 3820 if (dynpm->op_pmflags & PMf_KEEPCOPY) 3821 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */ 3822 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST); 3823 #endif 3824 3825 s = truebase; 3826 3827 play_it_again: 3828 if (global) 3829 s = truebase + curpos; 3830 3831 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, 3832 had_zerolen, TARG, NULL, r_flags)) 3833 goto nope; 3834 3835 PL_curpm = pm; 3836 if (dynpm->op_pmflags & PMf_ONCE) 3837 #ifdef USE_ITHREADS 3838 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]); 3839 #else 3840 dynpm->op_pmflags |= PMf_USED; 3841 #endif 3842 3843 if (rxtainted) 3844 RXp_MATCH_TAINTED_on(prog); 3845 TAINT_IF(RXp_MATCH_TAINTED(prog)); 3846 3847 /* update pos */ 3848 3849 if (global && (gimme != G_LIST || (dynpm->op_pmflags & PMf_CONTINUE))) { 3850 if (!mg) 3851 mg = sv_magicext_mglob(TARG); 3852 MgBYTEPOS_set(mg, TARG, truebase, RXp_OFFS_END(prog,0)); 3853 if (RXp_ZERO_LEN(prog)) 3854 mg->mg_flags |= MGf_MINMATCH; 3855 else 3856 mg->mg_flags &= ~MGf_MINMATCH; 3857 } 3858 3859 if ((!RXp_NPARENS(prog) && !global) || gimme != G_LIST) { 3860 LEAVE_SCOPE(oldsave); 3861 if (sp_base) 3862 rpp_popfree_1(); /* free arg */ 3863 rpp_push_IMM(&PL_sv_yes); 3864 return NORMAL; 3865 } 3866 3867 /* push captures on stack */ 3868 3869 { 3870 const I32 logical_nparens = RXp_LOGICAL_NPARENS(prog); 3871 /* This following statement is *devious* code. If we are in a global 3872 match and the pattern has no parens in it, we should return $& 3873 (offset pair 0). So we set logical_paren to 1 when we should return 3874 $&, otherwise we set it to 0. 3875 3876 This allows us to simply add logical_nparens to logical_paren to 3877 compute the number of elements we are going to return. 3878 3879 In the loop init we "not" it with: logical_paren = !logical_paren 3880 which results in it being 0 inside the loop when we want to return 3881 $&, and results in it being 1 when we want to return the parens. 3882 Thus we either loop over 1..logical_nparens, or just over 0. 3883 3884 This is an elegant way to do this code-wise, but is super devious 3885 and potentially confusing. When I first saw this logic I thought 3886 "WTF?". But it makes sense after you poke it a while. 3887 3888 Frankly I probably would have done it differently, but it works so 3889 I am leaving it. - Yves */ 3890 I32 logical_paren = (global && !logical_nparens) ? 1 : 0; 3891 I32 *l2p = RXp_LOGICAL_TO_PARNO(prog); 3892 /* This is used to step through the physical parens associated 3893 with a given logical paren. */ 3894 I32 *p2l_next = RXp_PARNO_TO_LOGICAL_NEXT(prog); 3895 3896 rpp_extend(logical_nparens + logical_paren); /* devious code ... */ 3897 EXTEND_MORTAL(logical_nparens + logical_paren); /* ... see above */ 3898 3899 /* Loop over the logical parens in the pattern. This may not 3900 correspond to the actual paren checked, as branch reset may 3901 mean that there is more than one paren "behind" the logical 3902 parens. Eg, in /(?|(a)|(b))/ there are two parens, but one 3903 logical paren. */ 3904 for (logical_paren = !logical_paren; 3905 logical_paren <= logical_nparens; 3906 logical_paren++) 3907 { 3908 /* Now convert the logical_paren to the physical parens which 3909 are "behind" it. If branch reset was not used, then 3910 physical_paren and logical_paren are the same as each other 3911 and we will only perform one iteration of the loop. */ 3912 I32 phys_paren = l2p ? l2p[logical_paren] : logical_paren; 3913 SSize_t offs_start, offs_end; 3914 /* We check the loop invariants below and break out of the loop 3915 explicitly if our checks fail, so we use while (1) here to 3916 avoid double testing a conditional. */ 3917 while (1) { 3918 /* Check end offset first, as the start might be >=0 even 3919 though the end is -1, so testing the end first helps 3920 us avoid the start check. Really we should be able to 3921 get away with ONLY testing the end, but testing both 3922 doesn't hurt much and preserves sanity. */ 3923 if (((offs_end = RXp_OFFS_END(prog, phys_paren)) != -1) && 3924 ((offs_start = RXp_OFFS_START(prog, phys_paren)) != -1)) 3925 { 3926 const SSize_t len = offs_end - offs_start; 3927 const char * const s = offs_start + truebase; 3928 if ( UNLIKELY( len < 0 || len > strend - s) ) { 3929 DIE(aTHX_ "panic: pp_match start/end pointers, paren=%" I32df ", " 3930 "start=%zd, end=%zd, s=%p, strend=%p, len=%zd", 3931 phys_paren, offs_start, offs_end, s, strend, len); 3932 } 3933 rpp_push_1(newSVpvn_flags(s, len, 3934 (DO_UTF8(TARG)) 3935 ? SVf_UTF8|SVs_TEMP 3936 : SVs_TEMP) 3937 ); 3938 break; 3939 } else if (!p2l_next || !(phys_paren = p2l_next[phys_paren])) { 3940 /* Either logical_paren and phys_paren are the same and 3941 we won't have a p2l_next, or they aren't the same (and 3942 we do have a p2l_next) but we have exhausted the list 3943 of physical parens associated with this logical paren. 3944 Either way we are done, and we can push undef and break 3945 out of the loop. */ 3946 rpp_push_1(sv_newmortal()); 3947 break; 3948 } 3949 } 3950 } 3951 if (global) { 3952 curpos = (UV)RXp_OFFS_END(prog,0); 3953 had_zerolen = RXp_ZERO_LEN(prog); 3954 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; 3955 goto play_it_again; 3956 } 3957 LEAVE_SCOPE(oldsave); 3958 goto ret_list; 3959 } 3960 NOT_REACHED; /* NOTREACHED */ 3961 3962 nope: 3963 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) { 3964 if (!mg) 3965 mg = mg_find_mglob(TARG); 3966 if (mg) 3967 mg->mg_len = -1; 3968 } 3969 LEAVE_SCOPE(oldsave); 3970 if (gimme != G_LIST) { 3971 if (sp_base) 3972 rpp_popfree_1(); /* free arg */ 3973 rpp_push_IMM(&PL_sv_no); 3974 return NORMAL; 3975 } 3976 3977 ret_list: 3978 /* return when in list context (i.e. don't push YES/NO, but do return 3979 * a (possibly empty) list of matches */ 3980 if (sp_base) { 3981 /* need to free the original argument and shift any results down 3982 * by one */ 3983 SSize_t nitems = PL_stack_sp - (PL_stack_base + sp_base); 3984 #ifdef PERL_RC_STACK 3985 SV *old_sv = PL_stack_sp[-nitems]; 3986 #endif 3987 if (nitems) 3988 Move(PL_stack_sp - nitems + 1, 3989 PL_stack_sp - nitems, nitems, SV*); 3990 PL_stack_sp--; 3991 #ifdef PERL_RC_STACK 3992 SvREFCNT_dec_NN(old_sv); 3993 #endif 3994 } 3995 3996 return NORMAL; 3997 } 3998 3999 4000 /* Perl_do_readline(): implement <$fh>, readline($fh) and glob('*.h') 4001 * 4002 * This function is tail-called by pp_readline(), pp_rcatline() and 4003 * pp_glob(), and it may check PL_op's op_type and op_flags as 4004 * appropriate. 4005 * 4006 * For file reading: 4007 * It reads the line(s) from PL_last_in_gv. 4008 * It returns a list of lines, or in scalar context, reads one line into 4009 * targ (or if OPf_STACKED, into the top SV on the stack), and 4010 * returns that. (If OP_RCATLINE, concats rather than sets). 4011 * 4012 * So it normally expects zero args, or one arg when the OPf_STACKED 4013 * optimisation is present. 4014 * 4015 * For file globbing: 4016 * Note that we don't normally reach here: we only get here if perl is 4017 * built with PERL_EXTERNAL_GLOB, which is normally only when 4018 * building miniperl. 4019 * 4020 * Expects one arg, which is the pattern string (e.g. '*.h'). 4021 * The caller sets PL_last_in_gv to a plain GV that just has a new 4022 * IO::File PVIO attached. That PVIO is used to attach a pipe file 4023 * handle to when an external glob is being run in scalar context, 4024 * so the pipe is available on subsequent iterations. 4025 * 4026 * Handles tied IO magic, but not overloading - that's the caller's 4027 * responsibility. 4028 * 4029 * Handles the *ARGV filehandle specially, to do all the <> wizardry. 4030 * 4031 * In summary: on entry, the stack has zero or one items pushed, and 4032 * looks like: 4033 * 4034 * - when OP_READLINE without OPf_STACKED 4035 * target when OP_READLINE with OPf_STACKED, or when OP_RCATLINE 4036 * '*.h' when OP_GLOB 4037 */ 4038 4039 OP * 4040 Perl_do_readline(pTHX) 4041 { 4042 4043 const I32 type = PL_op->op_type; 4044 4045 /* only readline/rcatline can have the STACKED optimisation, 4046 * and rcatline *always* has it */ 4047 if (PL_op->op_flags & OPf_STACKED) { 4048 assert(type != OP_GLOB); 4049 assert(GIMME_V == G_SCALAR); 4050 } 4051 if (type == OP_RCATLINE) 4052 assert(PL_op->op_flags & OPf_STACKED); 4053 4054 const U8 gimme = GIMME_V; 4055 SV *targ = (gimme == G_SCALAR) 4056 ? (PL_op->op_flags & OPf_STACKED) 4057 ? *PL_stack_sp 4058 : PAD_SV(PL_op->op_targ) 4059 : NULL; 4060 SV *sv; 4061 STRLEN tmplen = 0; 4062 STRLEN offset; 4063 PerlIO *fp; 4064 IO * const io = GvIO(PL_last_in_gv); 4065 4066 /* process tied file handle if present */ 4067 4068 if (io) { 4069 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); 4070 if (mg) { 4071 /* not possible for the faked-up IO passed by an OP_GLOB to be 4072 * tied */ 4073 assert(type != OP_GLOB); 4074 /* OPf_STACKED only applies when in scalar context */ 4075 assert(!(gimme != G_SCALAR && (PL_op->op_flags & OPf_STACKED))); 4076 4077 /* tied_method() frees everything currently above the passed 4078 * mark, and returns any values at mark[1] onwards */ 4079 Perl_tied_method(aTHX_ SV_CONST(READLINE), 4080 /* mark => */ PL_stack_sp, 4081 MUTABLE_SV(io), mg, gimme, 0); 4082 4083 if (gimme == G_SCALAR) { 4084 SvSetSV_nosteal(targ, *PL_stack_sp); 4085 SvSETMAGIC(targ); 4086 if (PL_op->op_flags & OPf_STACKED) { 4087 /* free the tied method call's return value */ 4088 rpp_popfree_1(); 4089 assert(*PL_stack_sp == targ); 4090 } 4091 else 4092 rpp_replace_1_1(targ); 4093 } 4094 else 4095 /* no targ to pop off the stack - any returned values 4096 * are in the right place in the stack */ 4097 assert(!(PL_op->op_flags & OPf_STACKED)); 4098 4099 return NORMAL; 4100 } 4101 } 4102 4103 fp = NULL; 4104 4105 /* handle possible *ARGV, and check for read on write-only FH */ 4106 4107 if (io) { 4108 fp = IoIFP(io); 4109 if (fp) { 4110 if (IoTYPE(io) == IoTYPE_WRONLY) 4111 report_wrongway_fh(PL_last_in_gv, '>'); 4112 } 4113 else { 4114 if (IoFLAGS(io) & IOf_ARGV) { 4115 if (IoFLAGS(io) & IOf_START) { 4116 IoLINES(io) = 0; 4117 if (av_count(GvAVn(PL_last_in_gv)) == 0) { 4118 IoFLAGS(io) &= ~IOf_START; 4119 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0); 4120 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */ 4121 sv_setpvs(GvSVn(PL_last_in_gv), "-"); 4122 SvSETMAGIC(GvSV(PL_last_in_gv)); 4123 fp = IoIFP(io); 4124 goto have_fp; 4125 } 4126 } 4127 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL); 4128 if (!fp) { /* Note: fp != IoIFP(io) */ 4129 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ 4130 } 4131 } 4132 else if (type == OP_GLOB) { 4133 fp = Perl_start_glob(aTHX_ *PL_stack_sp, io); 4134 rpp_popfree_1_NN(); 4135 } 4136 } 4137 } 4138 4139 /* handle bad file handle */ 4140 4141 if (!fp) { 4142 if ((!io || !(IoFLAGS(io) & IOf_START)) 4143 && ckWARN(WARN_CLOSED) 4144 && type != OP_GLOB) 4145 { 4146 report_evil_fh(PL_last_in_gv); 4147 } 4148 4149 if (gimme == G_SCALAR) { 4150 /* undef targ, and return that undefined value */ 4151 if (type != OP_RCATLINE) 4152 sv_set_undef(targ); 4153 if (!(PL_op->op_flags & OPf_STACKED)) 4154 rpp_push_1(targ); 4155 } 4156 return NORMAL; 4157 } 4158 4159 have_fp: 4160 4161 /* prepare targ to have a string assigned to it */ 4162 4163 if (gimme == G_SCALAR) { 4164 sv = targ; 4165 if (type == OP_RCATLINE && SvGMAGICAL(sv)) 4166 mg_get(sv); 4167 4168 if (SvROK(sv)) { 4169 if (type == OP_RCATLINE) 4170 SvPV_force_nomg_nolen(sv); 4171 else 4172 sv_unref(sv); 4173 } 4174 else if (isGV_with_GP(sv)) { 4175 SvPV_force_nomg_nolen(sv); 4176 } 4177 4178 SvUPGRADE(sv, SVt_PV); 4179 tmplen = SvLEN(sv); /* remember if already alloced */ 4180 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) { 4181 /* try short-buffering it. Please update t/op/readline.t 4182 * if you change the growth length. 4183 */ 4184 Sv_Grow(sv, 80); 4185 } 4186 4187 offset = 0; 4188 if (type == OP_RCATLINE && SvOK(sv)) { 4189 if (!SvPOK(sv)) { 4190 SvPV_force_nomg_nolen(sv); 4191 } 4192 offset = SvCUR(sv); 4193 } 4194 } 4195 else { 4196 /* XXX on RC builds, push on stack rather than mortalize ? */ 4197 sv = sv_2mortal(newSV(80)); 4198 offset = 0; 4199 } 4200 4201 /* This should not be marked tainted if the fp is marked clean */ 4202 #define MAYBE_TAINT_LINE(io, sv) \ 4203 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \ 4204 TAINT; \ 4205 SvTAINTED_on(sv); \ 4206 } 4207 4208 /* delay EOF state for a snarfed empty file */ 4209 #define SNARF_EOF(gimme,rs,io,sv) \ 4210 (gimme != G_SCALAR || SvCUR(sv) \ 4211 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs)) 4212 4213 /* create one or more lines, or (if OP_GLOB), pathnames */ 4214 4215 for (;;) { 4216 if (!sv_gets(sv, fp, offset) 4217 && (type == OP_GLOB 4218 || SNARF_EOF(gimme, PL_rs, io, sv) 4219 || PerlIO_error(fp))) 4220 { 4221 if (IoFLAGS(io) & IOf_ARGV) { 4222 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL); 4223 if (fp) { 4224 continue; 4225 } 4226 (void)do_close(PL_last_in_gv, FALSE); 4227 } 4228 else if (type == OP_GLOB) { 4229 /* clear any errors here so we only fail on the pclose() 4230 failing, which should only happen on the child 4231 failing 4232 */ 4233 PerlIO_clearerr(fp); 4234 if (!do_close(PL_last_in_gv, FALSE)) { 4235 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB), 4236 "glob failed (child exited with status %d%s)", 4237 (int)(STATUS_CURRENT >> 8), 4238 (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); 4239 } 4240 } 4241 4242 if (gimme == G_SCALAR) { 4243 if (type != OP_RCATLINE) { 4244 SV_CHECK_THINKFIRST_COW_DROP(targ); 4245 SvOK_off(targ); 4246 } 4247 /* targ not already there? */ 4248 if (!(PL_op->op_flags & OPf_STACKED)) 4249 rpp_push_1(targ); 4250 } 4251 else if (PL_op->op_flags & OPf_STACKED) 4252 rpp_popfree_1_NN(); 4253 4254 MAYBE_TAINT_LINE(io, sv); 4255 return NORMAL; 4256 } 4257 4258 MAYBE_TAINT_LINE(io, sv); 4259 IoLINES(io)++; 4260 IoFLAGS(io) |= IOf_NOLINE; 4261 SvSETMAGIC(sv); 4262 rpp_extend(1); 4263 if (PL_op->op_flags & OPf_STACKED) { 4264 /* push sv while keeping targ above it, so targ doesn't get 4265 * freed */ 4266 assert(*PL_stack_sp == targ); 4267 PL_stack_sp[1] = targ; 4268 *PL_stack_sp++ = NULL; 4269 rpp_replace_at(PL_stack_sp - 1, sv); 4270 } 4271 else 4272 rpp_push_1(sv); 4273 4274 if (type == OP_GLOB) { 4275 const char *t1; 4276 Stat_t statbuf; 4277 4278 /* chomp(sv) */ 4279 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) { 4280 char * const tmps = SvEND(sv) - 1; 4281 if (*tmps == *SvPVX_const(PL_rs)) { 4282 *tmps = '\0'; 4283 SvCUR_set(sv, SvCUR(sv) - 1); 4284 } 4285 } 4286 4287 /* find longest substring of sv up to first metachar */ 4288 for (t1 = SvPVX_const(sv); *t1; t1++) { 4289 #ifdef __VMS 4290 if (memCHRs("*%?", *t1)) 4291 #else 4292 if (memCHRs("$&*(){}[]'\";\\|?<>~`", *t1)) 4293 #endif 4294 break; 4295 } 4296 4297 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) { 4298 /* Unmatched wildcard? Chuck it... */ 4299 /* no need to worry about targ still on top of stack */ 4300 assert(!(PL_op->op_flags & OPf_STACKED)); 4301 rpp_popfree_1(); 4302 continue; 4303 } 4304 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */ 4305 /* check line if valid Unicode */ 4306 if (ckWARN(WARN_UTF8)) { 4307 const U8 * const s = (const U8*)SvPVX_const(sv) + offset; 4308 const STRLEN len = SvCUR(sv) - offset; 4309 const U8 *f; 4310 4311 if (!is_utf8_string_loc(s, len, &f)) 4312 /* Emulate :encoding(utf8) warning in the same case. */ 4313 Perl_warner(aTHX_ packWARN(WARN_UTF8), 4314 "utf8 \"\\x%02X\" does not map to Unicode", 4315 f < (U8*)SvEND(sv) ? *f : 0); 4316 } 4317 } 4318 4319 if (gimme == G_LIST) { 4320 if (SvLEN(sv) - SvCUR(sv) > 20) { 4321 SvPV_shrink_to_cur(sv); 4322 } 4323 /* XXX on RC builds, push on stack rather than mortalize ? */ 4324 sv = sv_2mortal(newSV(80)); 4325 continue; 4326 } 4327 4328 if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) { 4329 /* try to reclaim a bit of scalar space (only on 1st alloc) */ 4330 const STRLEN new_len 4331 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */ 4332 SvPV_renew(sv, new_len); 4333 } 4334 4335 4336 if (PL_op->op_flags & OPf_STACKED) 4337 rpp_popfree_1_NN(); /* finally remove targ */ 4338 /* return sv, which was recently pushed onto the stack */ 4339 return NORMAL; 4340 } /* for (;;) */ 4341 } 4342 4343 4344 PP(pp_helem) 4345 { 4346 HE* he; 4347 SV **svp; 4348 SV * const keysv = PL_stack_sp[0]; 4349 HV * const hv = MUTABLE_HV(PL_stack_sp[-1]); 4350 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET; 4351 const U32 defer = PL_op->op_private & OPpLVAL_DEFER; 4352 SV *sv; 4353 const bool localizing = PL_op->op_private & OPpLVAL_INTRO; 4354 bool preeminent = TRUE; 4355 SV *retsv; 4356 4357 if (SvTYPE(hv) != SVt_PVHV) { 4358 retsv = &PL_sv_undef; 4359 goto ret; 4360 } 4361 4362 if (localizing) { 4363 MAGIC *mg; 4364 HV *stash; 4365 4366 /* Try to preserve the existence of a tied hash 4367 * element by using EXISTS and DELETE if possible. 4368 * Fall back to FETCH and STORE otherwise. */ 4369 if (SvCANEXISTDELETE(hv)) 4370 preeminent = hv_exists_ent(hv, keysv, 0); 4371 } 4372 4373 he = hv_fetch_ent(hv, keysv, lval && !defer, 0); 4374 svp = he ? &HeVAL(he) : NULL; 4375 if (lval) { 4376 if (!svp || !*svp || *svp == &PL_sv_undef) { 4377 SV* lv; 4378 SV* key2; 4379 if (!defer) { 4380 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); 4381 } 4382 lv = newSV_type_mortal(SVt_PVLV); 4383 LvTYPE(lv) = 'y'; 4384 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0); 4385 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */ 4386 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv); 4387 LvTARGLEN(lv) = 1; 4388 retsv = lv; 4389 goto ret; 4390 } 4391 4392 if (localizing) { 4393 if (HvNAME_get(hv) && isGV_or_RVCV(*svp)) 4394 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); 4395 else if (preeminent) 4396 save_helem_flags(hv, keysv, svp, 4397 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC); 4398 else 4399 SAVEHDELETE(hv, keysv); 4400 } 4401 else if (PL_op->op_private & OPpDEREF) { 4402 retsv = vivify_ref(*svp, PL_op->op_private & OPpDEREF); 4403 goto ret;; 4404 } 4405 } 4406 sv = (svp && *svp ? *svp : &PL_sv_undef); 4407 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this 4408 * was to make C<local $tied{foo} = $tied{foo}> possible. 4409 * However, it seems no longer to be needed for that purpose, and 4410 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g> 4411 * would loop endlessly since the pos magic is getting set on the 4412 * mortal copy and lost. However, the copy has the effect of 4413 * triggering the get magic, and losing it altogether made things like 4414 * c<$tied{foo};> in void context no longer do get magic, which some 4415 * code relied on. Also, delayed triggering of magic on @+ and friends 4416 * meant the original regex may be out of scope by now. So as a 4417 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it 4418 * being called too many times). */ 4419 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv)) 4420 mg_get(sv); 4421 retsv = sv; 4422 4423 ret: 4424 rpp_replace_2_1_NN(retsv); 4425 return NORMAL; 4426 } 4427 4428 4429 /* a stripped-down version of Perl_softref2xv() for use by 4430 * pp_multideref(), which doesn't use PL_op->op_flags */ 4431 4432 STATIC GV * 4433 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what, 4434 const svtype type) 4435 { 4436 if (PL_op->op_private & HINT_STRICT_REFS) { 4437 if (SvOK(sv)) 4438 Perl_die(aTHX_ PL_no_symref_sv, sv, 4439 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what); 4440 else 4441 Perl_die(aTHX_ PL_no_usym, what); 4442 } 4443 if (!SvOK(sv)) 4444 Perl_die(aTHX_ PL_no_usym, what); 4445 return gv_fetchsv_nomg(sv, GV_ADD, type); 4446 } 4447 4448 4449 /* Handle one or more aggregate derefs and array/hash indexings, e.g. 4450 * $h->{foo} or $a[0]{$key}[$i] or f()->[1] 4451 * 4452 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET. 4453 * Each of these either contains a set of actions, or an argument, such as 4454 * an IV to use as an array index, or a lexical var to retrieve. 4455 * Several actions are stored per UV; we keep shifting new actions off the 4456 * one UV, and only reload when it becomes zero. 4457 */ 4458 4459 PP(pp_multideref) 4460 { 4461 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */ 4462 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux; 4463 UV actions = items->uv; 4464 4465 assert(actions); 4466 /* this tells find_uninit_var() where we're up to */ 4467 PL_multideref_pc = items; 4468 bool replace = FALSE; 4469 4470 while (1) { 4471 /* there are three main classes of action; the first retrieves 4472 * the initial AV or HV from a variable or the stack; the second 4473 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem), 4474 * the third an unrolled (/DREFHV, rv2hv, helem). 4475 */ 4476 switch (actions & MDEREF_ACTION_MASK) { 4477 4478 case MDEREF_reload: 4479 actions = (++items)->uv; 4480 continue; 4481 4482 case MDEREF_AV_padav_aelem: /* $lex[...] */ 4483 sv = PAD_SVl((++items)->pad_offset); 4484 goto do_AV_aelem; 4485 4486 case MDEREF_AV_gvav_aelem: /* $pkg[...] */ 4487 sv = UNOP_AUX_item_sv(++items); 4488 assert(isGV_with_GP(sv)); 4489 sv = (SV*)GvAVn((GV*)sv); 4490 goto do_AV_aelem; 4491 4492 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */ 4493 { 4494 sv = *PL_stack_sp; 4495 replace = TRUE; 4496 goto do_AV_rv2av_aelem; 4497 } 4498 4499 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */ 4500 sv = UNOP_AUX_item_sv(++items); 4501 assert(isGV_with_GP(sv)); 4502 sv = GvSVn((GV*)sv); 4503 goto do_AV_vivify_rv2av_aelem; 4504 4505 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */ 4506 sv = PAD_SVl((++items)->pad_offset); 4507 /* FALLTHROUGH */ 4508 4509 do_AV_vivify_rv2av_aelem: 4510 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */ 4511 /* this is the OPpDEREF action normally found at the end of 4512 * ops like aelem, helem, rv2sv */ 4513 sv = vivify_ref(sv, OPpDEREF_AV); 4514 /* FALLTHROUGH */ 4515 4516 do_AV_rv2av_aelem: 4517 /* this is basically a copy of pp_rv2av when it just has the 4518 * sKR/1 flags */ 4519 SvGETMAGIC(sv); 4520 if (LIKELY(SvROK(sv))) { 4521 if (UNLIKELY(SvAMAGIC(sv))) { 4522 sv = amagic_deref_call(sv, to_av_amg); 4523 } 4524 sv = SvRV(sv); 4525 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV)) 4526 DIE(aTHX_ "Not an ARRAY reference"); 4527 } 4528 else if (SvTYPE(sv) != SVt_PVAV) { 4529 if (!isGV_with_GP(sv)) 4530 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV); 4531 sv = MUTABLE_SV(GvAVn((GV*)sv)); 4532 } 4533 /* FALLTHROUGH */ 4534 4535 do_AV_aelem: 4536 { 4537 /* retrieve the key; this may be either a lexical or package 4538 * var (whose index/ptr is stored as an item) or a signed 4539 * integer constant stored as an item. 4540 */ 4541 SV *elemsv; 4542 IV elem = 0; /* to shut up stupid compiler warnings */ 4543 4544 4545 assert(SvTYPE(sv) == SVt_PVAV); 4546 4547 switch (actions & MDEREF_INDEX_MASK) { 4548 case MDEREF_INDEX_none: 4549 goto finish; 4550 case MDEREF_INDEX_const: 4551 elem = (++items)->iv; 4552 break; 4553 case MDEREF_INDEX_padsv: 4554 elemsv = PAD_SVl((++items)->pad_offset); 4555 goto check_elem; 4556 case MDEREF_INDEX_gvsv: 4557 elemsv = UNOP_AUX_item_sv(++items); 4558 assert(isGV_with_GP(elemsv)); 4559 elemsv = GvSVn((GV*)elemsv); 4560 check_elem: 4561 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) 4562 && ckWARN(WARN_MISC))) 4563 Perl_warner(aTHX_ packWARN(WARN_MISC), 4564 "Use of reference \"%" SVf "\" as array index", 4565 SVfARG(elemsv)); 4566 /* the only time that S_find_uninit_var() needs this 4567 * is to determine which index value triggered the 4568 * undef warning. So just update it here. Note that 4569 * since we don't save and restore this var (e.g. for 4570 * tie or overload execution), its value will be 4571 * meaningless apart from just here */ 4572 PL_multideref_pc = items; 4573 elem = SvIV(elemsv); 4574 break; 4575 } 4576 4577 4578 /* this is basically a copy of pp_aelem with OPpDEREF skipped */ 4579 4580 if (!(actions & MDEREF_FLAG_last)) { 4581 SV** svp = av_fetch((AV*)sv, elem, 1); 4582 if (!svp || ! (sv=*svp)) 4583 DIE(aTHX_ PL_no_aelem, elem); 4584 break; 4585 } 4586 4587 if (PL_op->op_private & 4588 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE)) 4589 { 4590 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) { 4591 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no; 4592 } 4593 else { 4594 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0; 4595 sv = av_delete((AV*)sv, elem, discard); 4596 if (discard) 4597 return NORMAL; 4598 if (!sv) 4599 sv = &PL_sv_undef; 4600 } 4601 } 4602 else { 4603 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET; 4604 const U32 defer = PL_op->op_private & OPpLVAL_DEFER; 4605 const bool localizing = PL_op->op_private & OPpLVAL_INTRO; 4606 bool preeminent = TRUE; 4607 AV *const av = (AV*)sv; 4608 SV** svp; 4609 4610 if (UNLIKELY(localizing)) { 4611 MAGIC *mg; 4612 HV *stash; 4613 4614 /* Try to preserve the existence of a tied array 4615 * element by using EXISTS and DELETE if possible. 4616 * Fall back to FETCH and STORE otherwise. */ 4617 if (SvCANEXISTDELETE(av)) 4618 preeminent = av_exists(av, elem); 4619 } 4620 4621 svp = av_fetch(av, elem, lval && !defer); 4622 4623 if (lval) { 4624 if (!svp || !(sv = *svp)) { 4625 IV len; 4626 if (!defer) 4627 DIE(aTHX_ PL_no_aelem, elem); 4628 len = av_top_index(av); 4629 /* Resolve a negative index that falls within 4630 * the array. Leave it negative it if falls 4631 * outside the array. */ 4632 if (elem < 0 && len + elem >= 0) 4633 elem = len + elem; 4634 if (elem >= 0 && elem <= len) 4635 /* Falls within the array. */ 4636 sv = av_nonelem(av,elem); 4637 else 4638 /* Falls outside the array. If it is neg- 4639 ative, magic_setdefelem will use the 4640 index for error reporting. */ 4641 sv = sv_2mortal(newSVavdefelem(av,elem,1)); 4642 } 4643 else { 4644 if (UNLIKELY(localizing)) { 4645 if (preeminent) { 4646 save_aelem(av, elem, svp); 4647 sv = *svp; /* may have changed */ 4648 } 4649 else 4650 SAVEADELETE(av, elem); 4651 } 4652 } 4653 } 4654 else { 4655 sv = (svp ? *svp : &PL_sv_undef); 4656 /* see note in pp_helem() */ 4657 if (SvRMAGICAL(av) && SvGMAGICAL(sv)) 4658 mg_get(sv); 4659 } 4660 } 4661 4662 } 4663 finish: 4664 { 4665 if (replace) 4666 rpp_replace_1_1_NN(sv); 4667 else 4668 rpp_xpush_1(sv); 4669 return NORMAL; 4670 } 4671 /* NOTREACHED */ 4672 4673 4674 4675 4676 case MDEREF_HV_padhv_helem: /* $lex{...} */ 4677 sv = PAD_SVl((++items)->pad_offset); 4678 goto do_HV_helem; 4679 4680 case MDEREF_HV_gvhv_helem: /* $pkg{...} */ 4681 sv = UNOP_AUX_item_sv(++items); 4682 assert(isGV_with_GP(sv)); 4683 sv = (SV*)GvHVn((GV*)sv); 4684 goto do_HV_helem; 4685 4686 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */ 4687 { 4688 sv = *PL_stack_sp; 4689 replace = TRUE; 4690 goto do_HV_rv2hv_helem; 4691 } 4692 4693 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */ 4694 sv = UNOP_AUX_item_sv(++items); 4695 assert(isGV_with_GP(sv)); 4696 sv = GvSVn((GV*)sv); 4697 goto do_HV_vivify_rv2hv_helem; 4698 4699 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */ 4700 sv = PAD_SVl((++items)->pad_offset); 4701 /* FALLTHROUGH */ 4702 4703 do_HV_vivify_rv2hv_helem: 4704 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */ 4705 /* this is the OPpDEREF action normally found at the end of 4706 * ops like aelem, helem, rv2sv */ 4707 sv = vivify_ref(sv, OPpDEREF_HV); 4708 /* FALLTHROUGH */ 4709 4710 do_HV_rv2hv_helem: 4711 /* this is basically a copy of pp_rv2hv when it just has the 4712 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */ 4713 4714 SvGETMAGIC(sv); 4715 if (LIKELY(SvROK(sv))) { 4716 if (UNLIKELY(SvAMAGIC(sv))) { 4717 sv = amagic_deref_call(sv, to_hv_amg); 4718 } 4719 sv = SvRV(sv); 4720 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV)) 4721 DIE(aTHX_ "Not a HASH reference"); 4722 } 4723 else if (SvTYPE(sv) != SVt_PVHV) { 4724 if (!isGV_with_GP(sv)) 4725 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV); 4726 sv = MUTABLE_SV(GvHVn((GV*)sv)); 4727 } 4728 /* FALLTHROUGH */ 4729 4730 do_HV_helem: 4731 { 4732 /* retrieve the key; this may be either a lexical / package 4733 * var or a string constant, whose index/ptr is stored as an 4734 * item 4735 */ 4736 SV *keysv = NULL; /* to shut up stupid compiler warnings */ 4737 4738 assert(SvTYPE(sv) == SVt_PVHV); 4739 4740 switch (actions & MDEREF_INDEX_MASK) { 4741 case MDEREF_INDEX_none: 4742 goto finish; 4743 4744 case MDEREF_INDEX_const: 4745 keysv = UNOP_AUX_item_sv(++items); 4746 break; 4747 4748 case MDEREF_INDEX_padsv: 4749 keysv = PAD_SVl((++items)->pad_offset); 4750 break; 4751 4752 case MDEREF_INDEX_gvsv: 4753 keysv = UNOP_AUX_item_sv(++items); 4754 keysv = GvSVn((GV*)keysv); 4755 break; 4756 } 4757 4758 /* see comment above about setting this var */ 4759 PL_multideref_pc = items; 4760 4761 4762 /* ensure that candidate CONSTs have been HEKified */ 4763 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const) 4764 || SvTYPE(keysv) >= SVt_PVMG 4765 || !SvOK(keysv) 4766 || SvROK(keysv) 4767 || SvIsCOW_shared_hash(keysv)); 4768 4769 /* this is basically a copy of pp_helem with OPpDEREF skipped */ 4770 4771 if (!(actions & MDEREF_FLAG_last)) { 4772 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0); 4773 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef) 4774 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); 4775 break; 4776 } 4777 4778 if (PL_op->op_private & 4779 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE)) 4780 { 4781 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) { 4782 sv = hv_exists_ent((HV*)sv, keysv, 0) 4783 ? &PL_sv_yes : &PL_sv_no; 4784 } 4785 else { 4786 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0; 4787 sv = hv_delete_ent((HV*)sv, keysv, discard, 0); 4788 if (discard) 4789 return NORMAL; 4790 if (!sv) 4791 sv = &PL_sv_undef; 4792 } 4793 } 4794 else { 4795 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET; 4796 const U32 defer = PL_op->op_private & OPpLVAL_DEFER; 4797 const bool localizing = PL_op->op_private & OPpLVAL_INTRO; 4798 bool preeminent = TRUE; 4799 SV **svp; 4800 HV * const hv = (HV*)sv; 4801 HE* he; 4802 4803 if (UNLIKELY(localizing)) { 4804 MAGIC *mg; 4805 HV *stash; 4806 4807 /* Try to preserve the existence of a tied hash 4808 * element by using EXISTS and DELETE if possible. 4809 * Fall back to FETCH and STORE otherwise. */ 4810 if (SvCANEXISTDELETE(hv)) 4811 preeminent = hv_exists_ent(hv, keysv, 0); 4812 } 4813 4814 he = hv_fetch_ent(hv, keysv, lval && !defer, 0); 4815 svp = he ? &HeVAL(he) : NULL; 4816 4817 4818 if (lval) { 4819 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) { 4820 SV* lv; 4821 SV* key2; 4822 if (!defer) 4823 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); 4824 lv = newSV_type_mortal(SVt_PVLV); 4825 LvTYPE(lv) = 'y'; 4826 sv_magic(lv, key2 = newSVsv(keysv), 4827 PERL_MAGIC_defelem, NULL, 0); 4828 /* sv_magic() increments refcount */ 4829 SvREFCNT_dec_NN(key2); 4830 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv); 4831 LvTARGLEN(lv) = 1; 4832 sv = lv; 4833 } 4834 else { 4835 if (localizing) { 4836 if (HvNAME_get(hv) && isGV_or_RVCV(sv)) 4837 save_gp(MUTABLE_GV(sv), 4838 !(PL_op->op_flags & OPf_SPECIAL)); 4839 else if (preeminent) { 4840 save_helem_flags(hv, keysv, svp, 4841 (PL_op->op_flags & OPf_SPECIAL) 4842 ? 0 : SAVEf_SETMAGIC); 4843 sv = *svp; /* may have changed */ 4844 } 4845 else 4846 SAVEHDELETE(hv, keysv); 4847 } 4848 } 4849 } 4850 else { 4851 sv = (svp && *svp ? *svp : &PL_sv_undef); 4852 /* see note in pp_helem() */ 4853 if (SvRMAGICAL(hv) && SvGMAGICAL(sv)) 4854 mg_get(sv); 4855 } 4856 } 4857 goto finish; 4858 } 4859 4860 } /* switch */ 4861 4862 actions >>= MDEREF_SHIFT; 4863 } /* while */ 4864 /* NOTREACHED */ 4865 } 4866 4867 4868 PP(pp_iter) 4869 { 4870 PERL_CONTEXT *cx = CX_CUR(); 4871 SV **itersvp = CxITERVAR(cx); 4872 const U8 type = CxTYPE(cx); 4873 4874 /* Classic "for" syntax iterates one-at-a-time. 4875 Many-at-a-time for loops are only for lexicals declared as part of the 4876 for loop, and rely on all the lexicals being in adjacent pad slots. 4877 4878 Curiously, even if the iterator variable is a lexical, the pad offset is 4879 stored in the targ slot of the ENTERITER op, meaning that targ of this OP 4880 has always been zero. Hence we can use this op's targ to hold "how many" 4881 for many-at-a-time. We actually store C<how_many - 1>, so that for the 4882 case of one-at-a-time we have zero (as before), as this makes all the 4883 logic of the for loop below much simpler, with all the other 4884 one-at-a-time cases just falling out of this "naturally". */ 4885 PADOFFSET how_many = PL_op->op_targ; 4886 PADOFFSET i = 0; 4887 4888 assert(itersvp); 4889 4890 for (; i <= how_many; ++i ) { 4891 SV *oldsv; 4892 SV *sv; 4893 AV *av; 4894 IV ix; 4895 IV inc; 4896 4897 switch (type) { 4898 4899 case CXt_LOOP_LAZYSV: /* string increment */ 4900 { 4901 SV* cur = cx->blk_loop.state_u.lazysv.cur; 4902 SV *end = cx->blk_loop.state_u.lazysv.end; 4903 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no. 4904 It has SvPVX of "" and SvCUR of 0, which is what we want. */ 4905 STRLEN maxlen = 0; 4906 const char *max = SvPV_const(end, maxlen); 4907 bool pad_it = FALSE; 4908 if (DO_UTF8(end) && IN_UNI_8_BIT) 4909 maxlen = sv_len_utf8_nomg(end); 4910 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen)) { 4911 if (LIKELY(!i)) { 4912 goto retno; 4913 } 4914 /* We are looping n-at-a-time and the range isn't a multiple 4915 of n, so we fill the rest of the lexicals with undef. 4916 This only happens on the last iteration of the loop, and 4917 we will have already set up the "terminate next time" 4918 condition earlier in this for loop for this call of the 4919 ITER op when we set up the lexical corresponding to the 4920 last value in the range. Hence we don't goto retno (yet), 4921 and just below we don't repeat the setup for "terminate 4922 next time". */ 4923 pad_it = TRUE; 4924 } 4925 4926 oldsv = *itersvp; 4927 /* NB: on the first iteration, oldsv will have a ref count of at 4928 * least 2 (one extra from blk_loop.itersave), so the GV or pad 4929 * slot will get localised; on subsequent iterations the RC==1 4930 * optimisation may kick in and the SV will be reused. */ 4931 if (UNLIKELY(pad_it)) { 4932 *itersvp = &PL_sv_undef; 4933 SvREFCNT_dec(oldsv); 4934 } 4935 else if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) { 4936 /* safe to reuse old SV */ 4937 sv_setsv(oldsv, cur); 4938 } 4939 else { 4940 /* we need a fresh SV every time so that loop body sees a 4941 * completely new SV for closures/references to work as 4942 * they used to */ 4943 *itersvp = newSVsv(cur); 4944 SvREFCNT_dec(oldsv); 4945 } 4946 4947 if (UNLIKELY(pad_it)) { 4948 /* We're "beyond the end" of the iterator here, filling the 4949 extra lexicals with undef, so we mustn't do anything 4950 (further) to the iterator itself at this point. 4951 (Observe how the other two blocks modify the iterator's 4952 value) */ 4953 } 4954 else if (strEQ(SvPVX_const(cur), max)) 4955 sv_setiv(cur, 0); /* terminate next time */ 4956 else 4957 sv_inc(cur); 4958 break; 4959 } 4960 4961 case CXt_LOOP_LAZYIV: /* integer increment */ 4962 { 4963 IV cur = cx->blk_loop.state_u.lazyiv.cur; 4964 bool pad_it = FALSE; 4965 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end)) { 4966 if (LIKELY(!i)) { 4967 goto retno; 4968 } 4969 pad_it = TRUE; 4970 } 4971 4972 oldsv = *itersvp; 4973 /* see NB comment above */ 4974 if (UNLIKELY(pad_it)) { 4975 *itersvp = &PL_sv_undef; 4976 SvREFCNT_dec(oldsv); 4977 } 4978 else if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) { 4979 /* safe to reuse old SV */ 4980 4981 if ( (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV)) 4982 == SVt_IV) { 4983 /* Cheap SvIOK_only(). 4984 * Assert that flags which SvIOK_only() would test or 4985 * clear can't be set, because we're SVt_IV */ 4986 assert(!(SvFLAGS(oldsv) & 4987 (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK))))); 4988 SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK); 4989 /* SvIV_set() where sv_any points to head */ 4990 oldsv->sv_u.svu_iv = cur; 4991 4992 } 4993 else 4994 sv_setiv(oldsv, cur); 4995 } 4996 else { 4997 /* we need a fresh SV every time so that loop body sees a 4998 * completely new SV for closures/references to work as they 4999 * used to */ 5000 *itersvp = newSViv(cur); 5001 SvREFCNT_dec(oldsv); 5002 } 5003 5004 if (UNLIKELY(pad_it)) { 5005 /* We're good (see "We are looping n-at-a-time" comment 5006 above). */ 5007 } 5008 else if (UNLIKELY(cur == IV_MAX)) { 5009 /* Handle end of range at IV_MAX */ 5010 cx->blk_loop.state_u.lazyiv.end = IV_MIN; 5011 } else 5012 ++cx->blk_loop.state_u.lazyiv.cur; 5013 break; 5014 } 5015 5016 case CXt_LOOP_LIST: /* for (1,2,3) */ 5017 5018 assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */ 5019 inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED); 5020 ix = (cx->blk_loop.state_u.stack.ix += inc); 5021 if (UNLIKELY(inc > 0 5022 ? ix > cx->blk_oldsp 5023 : ix <= cx->blk_loop.state_u.stack.basesp) 5024 ) { 5025 if (LIKELY(!i)) { 5026 goto retno; 5027 } 5028 5029 sv = &PL_sv_undef; 5030 } 5031 else { 5032 sv = PL_stack_base[ix]; 5033 } 5034 5035 av = NULL; 5036 goto loop_ary_common; 5037 5038 case CXt_LOOP_ARY: /* for (@ary) */ 5039 5040 av = cx->blk_loop.state_u.ary.ary; 5041 inc = (IV)1 - (IV)(PL_op->op_private & OPpITER_REVERSED); 5042 ix = (cx->blk_loop.state_u.ary.ix += inc); 5043 if (UNLIKELY(inc > 0 5044 ? ix > AvFILL(av) 5045 : ix < 0) 5046 ) { 5047 if (LIKELY(!i)) { 5048 goto retno; 5049 } 5050 5051 sv = &PL_sv_undef; 5052 } else if (UNLIKELY(SvRMAGICAL(av))) { 5053 SV * const * const svp = av_fetch(av, ix, FALSE); 5054 sv = svp ? *svp : NULL; 5055 } 5056 else { 5057 sv = AvARRAY(av)[ix]; 5058 } 5059 5060 loop_ary_common: 5061 5062 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) { 5063 SvSetMagicSV(*itersvp, sv); 5064 break; 5065 } 5066 5067 if (LIKELY(sv)) { 5068 if (UNLIKELY(SvIS_FREED(sv))) { 5069 *itersvp = NULL; 5070 Perl_croak(aTHX_ "Use of freed value in iteration"); 5071 } 5072 if (SvPADTMP(sv)) { 5073 sv = newSVsv(sv); 5074 } 5075 else { 5076 SvTEMP_off(sv); 5077 SvREFCNT_inc_simple_void_NN(sv); 5078 } 5079 } 5080 else if (av) { 5081 sv = newSVavdefelem(av, ix, 0); 5082 } 5083 else 5084 sv = &PL_sv_undef; 5085 5086 oldsv = *itersvp; 5087 *itersvp = sv; 5088 SvREFCNT_dec(oldsv); 5089 break; 5090 5091 default: 5092 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx)); 5093 } 5094 5095 /* Only relevant for a many-at-a-time loop: */ 5096 ++itersvp; 5097 } 5098 5099 /* Try to bypass pushing &PL_sv_yes and calling pp_and(); instead 5100 * jump straight to the AND op's op_other */ 5101 assert(PL_op->op_next->op_type == OP_AND); 5102 if (PL_op->op_next->op_ppaddr == Perl_pp_and) { 5103 return cLOGOPx(PL_op->op_next)->op_other; 5104 } 5105 else { 5106 /* An XS module has replaced the op_ppaddr, so fall back to the slow, 5107 * obvious way. */ 5108 /* pp_enteriter should have pre-extended the stack */ 5109 EXTEND_SKIP(PL_stack_sp, 1); 5110 rpp_push_IMM(&PL_sv_yes); 5111 return PL_op->op_next; 5112 } 5113 5114 retno: 5115 /* Try to bypass pushing &PL_sv_no and calling pp_and(); instead 5116 * jump straight to the AND op's op_next */ 5117 assert(PL_op->op_next->op_type == OP_AND); 5118 /* pp_enteriter should have pre-extended the stack */ 5119 EXTEND_SKIP(PL_stack_sp, 1); 5120 /* we only need this for the rare case where the OP_AND isn't 5121 * in void context, e.g. $x = do { for (..) {...} }; 5122 * (or for when an XS module has replaced the op_ppaddr) 5123 * but it's cheaper to just push it rather than testing first 5124 */ 5125 rpp_push_IMM(&PL_sv_no); 5126 if (PL_op->op_next->op_ppaddr == Perl_pp_and) { 5127 return PL_op->op_next->op_next; 5128 } 5129 else { 5130 /* An XS module has replaced the op_ppaddr, so fall back to the slow, 5131 * obvious way. */ 5132 return PL_op->op_next; 5133 } 5134 } 5135 5136 5137 /* 5138 A description of how taint works in pattern matching and substitution. 5139 5140 This is all conditional on NO_TAINT_SUPPORT remaining undefined (the default). 5141 Under NO_TAINT_SUPPORT, taint-related operations should become no-ops. 5142 5143 While the pattern is being assembled/concatenated and then compiled, 5144 PL_tainted will get set (via TAINT_set) if any component of the pattern 5145 is tainted, e.g. /.*$tainted/. At the end of pattern compilation, 5146 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via 5147 TAINT_get). It will also be set if any component of the pattern matches 5148 based on locale-dependent behavior. 5149 5150 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to 5151 the pattern is marked as tainted. This means that subsequent usage, such 5152 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED, 5153 on the new pattern too. 5154 5155 RXf_TAINTED_SEEN is used post-execution by the get magic code 5156 of $1 et al to indicate whether the returned value should be tainted. 5157 It is the responsibility of the caller of the pattern (i.e. pp_match, 5158 pp_subst etc) to set this flag for any other circumstances where $1 needs 5159 to be tainted. 5160 5161 The taint behaviour of pp_subst (and pp_substcont) is quite complex. 5162 5163 There are three possible sources of taint 5164 * the source string 5165 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN) 5166 * the replacement string (or expression under /e) 5167 5168 There are four destinations of taint and they are affected by the sources 5169 according to the rules below: 5170 5171 * the return value (not including /r): 5172 tainted by the source string and pattern, but only for the 5173 number-of-iterations case; boolean returns aren't tainted; 5174 * the modified string (or modified copy under /r): 5175 tainted by the source string, pattern, and replacement strings; 5176 * $1 et al: 5177 tainted by the pattern, and under 'use re "taint"', by the source 5178 string too; 5179 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted: 5180 should always be unset before executing subsequent code. 5181 5182 The overall action of pp_subst is: 5183 5184 * at the start, set bits in rxtainted indicating the taint status of 5185 the various sources. 5186 5187 * After each pattern execution, update the SUBST_TAINT_PAT bit in 5188 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the 5189 pattern has subsequently become tainted via locale ops. 5190 5191 * If control is being passed to pp_substcont to execute a /e block, 5192 save rxtainted in the CXt_SUBST block, for future use by 5193 pp_substcont. 5194 5195 * Whenever control is being returned to perl code (either by falling 5196 off the "end" of pp_subst/pp_substcont, or by entering a /e block), 5197 use the flag bits in rxtainted to make all the appropriate types of 5198 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1 5199 et al will appear tainted. 5200 5201 pp_match is just a simpler version of the above. 5202 5203 */ 5204 5205 PP(pp_subst) 5206 { 5207 dTARG; 5208 PMOP *pm = cPMOP; 5209 PMOP *rpm = pm; 5210 char *s; 5211 char *strend; 5212 const char *c; 5213 STRLEN clen; 5214 SSize_t iters = 0; 5215 SSize_t maxiters; 5216 bool once; 5217 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits. 5218 See "how taint works" above */ 5219 char *orig; 5220 U8 r_flags; 5221 REGEXP *rx = PM_GETRE(pm); 5222 regexp *prog = ReANY(rx); 5223 STRLEN len; 5224 int force_on_match = 0; 5225 const I32 oldsave = PL_savestack_ix; 5226 bool doutf8 = FALSE; /* whether replacement is in utf8 */ 5227 #ifdef PERL_ANY_COW 5228 bool was_cow; 5229 #endif 5230 SV *nsv = NULL; 5231 SSize_t sp_offset = 0; /* number of items left on stack */ 5232 SV *dstr; 5233 SV *retval; 5234 5235 PERL_ASYNC_CHECK(); 5236 5237 if (pm->op_pmflags & PMf_CONST) { 5238 /* known replacement string */ 5239 dstr = *PL_stack_sp; 5240 sp_offset++; 5241 } 5242 else 5243 dstr = NULL; 5244 5245 if (PL_op->op_flags & OPf_STACKED) { 5246 /* expr =~ s///; */ 5247 TARG = PL_stack_sp[-sp_offset]; 5248 sp_offset++; 5249 } 5250 else { 5251 if (ARGTARG) 5252 /* $lex =~ s///; */ 5253 GETTARGET; 5254 else { 5255 /* s///; */ 5256 TARG = DEFSV; 5257 } 5258 if (!sp_offset) 5259 rpp_extend(1); 5260 } 5261 5262 SvGETMAGIC(TARG); /* must come before cow check */ 5263 #ifdef PERL_ANY_COW 5264 /* note that a string might get converted to COW during matching */ 5265 was_cow = cBOOL(SvIsCOW(TARG)); 5266 #endif 5267 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) { 5268 #ifndef PERL_ANY_COW 5269 if (SvIsCOW(TARG)) 5270 sv_force_normal_flags(TARG,0); 5271 #endif 5272 if ((SvREADONLY(TARG) 5273 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG)) 5274 || SvTYPE(TARG) > SVt_PVLV) 5275 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))) 5276 Perl_croak_no_modify(); 5277 } 5278 5279 orig = SvPV_nomg(TARG, len); 5280 /* note we don't (yet) force the var into being a string; if we fail 5281 * to match, we leave as-is; on successful match however, we *will* 5282 * coerce into a string, then repeat the match */ 5283 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG)) 5284 force_on_match = 1; 5285 5286 /* only replace once? */ 5287 once = !(rpm->op_pmflags & PMf_GLOBAL); 5288 5289 /* See "how taint works" above */ 5290 if (TAINTING_get) { 5291 rxtainted = ( 5292 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0) 5293 | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0) 5294 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0) 5295 | (( (once && !(rpm->op_pmflags & PMf_NONDESTRUCT)) 5296 || (PL_op->op_private & OPpTRUEBOOL)) ? SUBST_TAINT_BOOLRET : 0)); 5297 TAINT_NOT; 5298 } 5299 5300 force_it: 5301 if (!pm || !orig) 5302 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig); 5303 5304 strend = orig + len; 5305 /* We can match twice at each position, once with zero-length, 5306 * second time with non-zero. 5307 * Don't handle utf8 specially; we can use length-in-bytes as an 5308 * upper bound on length-in-characters, and avoid the cpu-cost of 5309 * computing a tighter bound. */ 5310 maxiters = 2 * len + 10; 5311 5312 /* handle the empty pattern */ 5313 if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) { 5314 if (PL_curpm == PL_reg_curpm) { 5315 if (PL_curpm_under) { 5316 if (PL_curpm_under == PL_reg_curpm) { 5317 Perl_croak(aTHX_ "Infinite recursion via empty pattern"); 5318 } else { 5319 pm = PL_curpm_under; 5320 } 5321 } 5322 } else { 5323 pm = PL_curpm; 5324 } 5325 rx = PM_GETRE(pm); 5326 prog = ReANY(rx); 5327 } 5328 5329 #ifdef PERL_SAWAMPERSAND 5330 r_flags = ( RXp_NPARENS(prog) 5331 || PL_sawampersand 5332 || (RXp_EXTFLAGS(prog) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) 5333 || (rpm->op_pmflags & PMf_KEEPCOPY) 5334 ) 5335 ? REXEC_COPY_STR 5336 : 0; 5337 #else 5338 r_flags = REXEC_COPY_STR; 5339 #endif 5340 5341 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags)) 5342 { 5343 SV *ret = rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no; 5344 if (dstr) 5345 rpp_popfree_1_NN(); /* pop replacement string */ 5346 if (PL_op->op_flags & OPf_STACKED) 5347 rpp_replace_1_1_NN(ret); /* pop LHS of =~ */ 5348 else 5349 rpp_push_1(ret); 5350 LEAVE_SCOPE(oldsave); 5351 return NORMAL; 5352 } 5353 PL_curpm = pm; 5354 5355 /* known replacement string? */ 5356 if (dstr) { 5357 /* replacement needing upgrading? */ 5358 if (DO_UTF8(TARG) && !doutf8) { 5359 nsv = sv_newmortal(); 5360 SvSetSV(nsv, dstr); 5361 sv_utf8_upgrade(nsv); 5362 c = SvPV_const(nsv, clen); 5363 doutf8 = TRUE; 5364 } 5365 else { 5366 c = SvPV_const(dstr, clen); 5367 doutf8 = DO_UTF8(dstr); 5368 } 5369 5370 if (UNLIKELY(TAINT_get)) 5371 rxtainted |= SUBST_TAINT_REPL; 5372 } 5373 else { 5374 c = NULL; 5375 doutf8 = FALSE; 5376 } 5377 5378 if (c 5379 #ifdef PERL_ANY_COW 5380 && !was_cow 5381 #endif 5382 && (SSize_t)clen <= RXp_MINLENRET(prog) 5383 && ( once 5384 || !(r_flags & REXEC_COPY_STR) 5385 || (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN)) 5386 ) 5387 && !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST) 5388 && (!doutf8 || SvUTF8(TARG)) 5389 && !(rpm->op_pmflags & PMf_NONDESTRUCT)) 5390 { 5391 /* known replacement string and can do in-place substitution */ 5392 5393 #ifdef PERL_ANY_COW 5394 /* string might have got converted to COW since we set was_cow */ 5395 if (SvIsCOW(TARG)) { 5396 if (!force_on_match) 5397 goto have_a_cow; 5398 assert(SvVOK(TARG)); 5399 } 5400 #endif 5401 if (force_on_match) { 5402 /* redo the first match, this time with the orig var 5403 * forced into being a string */ 5404 force_on_match = 0; 5405 orig = SvPV_force_nomg(TARG, len); 5406 goto force_it; 5407 } 5408 5409 if (once) { 5410 char *d, *m; 5411 if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */ 5412 rxtainted |= SUBST_TAINT_PAT; 5413 m = orig + RXp_OFFS_START(prog,0); 5414 d = orig + RXp_OFFS_END(prog,0); 5415 s = orig; 5416 if (m - s > strend - d) { /* faster to shorten from end */ 5417 SSize_t i; 5418 if (clen) { 5419 Copy(c, m, clen, char); 5420 m += clen; 5421 } 5422 i = strend - d; 5423 if (i > 0) { 5424 Move(d, m, i, char); 5425 m += i; 5426 } 5427 *m = '\0'; 5428 SvCUR_set(TARG, m - s); 5429 } 5430 else { /* faster from front */ 5431 SSize_t i = m - s; 5432 d -= clen; 5433 if (i > 0) 5434 Move(s, d - i, i, char); 5435 sv_chop(TARG, d-i); 5436 if (clen) 5437 Copy(c, d, clen, char); 5438 } 5439 retval = &PL_sv_yes; 5440 goto ret; 5441 } 5442 else { 5443 char *d, *m; 5444 d = s = RXp_OFFS_START(prog,0) + orig; 5445 do { 5446 SSize_t i; 5447 if (UNLIKELY(iters++ > maxiters)) 5448 DIE(aTHX_ "Substitution loop"); 5449 /* run time pattern taint, eg locale */ 5450 if (UNLIKELY(RXp_MATCH_TAINTED(prog))) 5451 rxtainted |= SUBST_TAINT_PAT; 5452 m = RXp_OFFS_START(prog,0) + orig; 5453 if ((i = m - s)) { 5454 if (s != d) 5455 Move(s, d, i, char); 5456 d += i; 5457 } 5458 if (clen) { 5459 Copy(c, d, clen, char); 5460 d += clen; 5461 } 5462 s = RXp_OFFS_END(prog,0) + orig; 5463 } while (CALLREGEXEC(rx, s, strend, orig, 5464 s == m, /* don't match same null twice */ 5465 TARG, NULL, 5466 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW)); 5467 if (s != d) { 5468 SSize_t i = strend - s; 5469 SvCUR_set(TARG, d - SvPVX_const(TARG) + i); 5470 Move(s, d, i+1, char); /* include the NUL */ 5471 } 5472 assert(iters); 5473 goto ret_iters; 5474 } 5475 } 5476 else { 5477 /* not known replacement string or can't do in-place substitution) */ 5478 bool first; 5479 char *m; 5480 SV *repl; 5481 if (force_on_match) { 5482 /* redo the first match, this time with the orig var 5483 * forced into being a string */ 5484 force_on_match = 0; 5485 if (rpm->op_pmflags & PMf_NONDESTRUCT) { 5486 /* I feel that it should be possible to avoid this mortal copy 5487 given that the code below copies into a new destination. 5488 However, I suspect it isn't worth the complexity of 5489 unravelling the C<goto force_it> for the small number of 5490 cases where it would be viable to drop into the copy code. */ 5491 TARG = sv_2mortal(newSVsv(TARG)); 5492 } 5493 orig = SvPV_force_nomg(TARG, len); 5494 goto force_it; 5495 } 5496 #ifdef PERL_ANY_COW 5497 have_a_cow: 5498 #endif 5499 if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */ 5500 rxtainted |= SUBST_TAINT_PAT; 5501 repl = dstr; 5502 s = RXp_OFFS_START(prog,0) + orig; 5503 dstr = newSVpvn_flags(orig, s-orig, 5504 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0)); 5505 if (!c) { 5506 /* not known replacement string - call out to ops and OP_SUBSTCONT */ 5507 PERL_CONTEXT *cx; 5508 m = orig; 5509 /* note that a whole bunch of local vars are saved here for 5510 * use by pp_substcont: here's a list of them in case you're 5511 * searching for places in this sub that uses a particular var: 5512 * iters maxiters r_flags oldsave rxtainted orig dstr targ 5513 * s m strend rx once */ 5514 CX_PUSHSUBST(cx); 5515 return cPMOP->op_pmreplrootu.op_pmreplroot; 5516 } 5517 5518 /* We get here if it's a known replacement string, but can't 5519 * substitute in-place */ 5520 5521 first = TRUE; 5522 do { 5523 if (UNLIKELY(iters++ > maxiters)) 5524 DIE(aTHX_ "Substitution loop"); 5525 if (UNLIKELY(RXp_MATCH_TAINTED(prog))) 5526 rxtainted |= SUBST_TAINT_PAT; 5527 if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) { 5528 char *old_s = s; 5529 char *old_orig = orig; 5530 assert(RXp_SUBOFFSET(prog) == 0); 5531 5532 orig = RXp_SUBBEG(prog); 5533 s = orig + (old_s - old_orig); 5534 strend = s + (strend - old_s); 5535 } 5536 m = RXp_OFFS_START(prog,0) + orig; 5537 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG)); 5538 s = RXp_OFFS_END(prog,0) + orig; 5539 if (first) { 5540 /* replacement already stringified */ 5541 if (clen) 5542 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8); 5543 first = FALSE; 5544 } 5545 else { 5546 sv_catsv(dstr, repl); 5547 } 5548 if (once) 5549 break; 5550 } while (CALLREGEXEC(rx, s, strend, orig, 5551 s == m, /* Yields minend of 0 or 1 */ 5552 TARG, NULL, 5553 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW)); 5554 assert(strend >= s); 5555 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG)); 5556 5557 if (rpm->op_pmflags & PMf_NONDESTRUCT) { 5558 /* From here on down we're using the copy, and leaving the original 5559 untouched. */ 5560 TARG = dstr; 5561 retval = dstr; 5562 goto ret; 5563 } else { 5564 #ifdef PERL_ANY_COW 5565 /* The match may make the string COW. If so, brilliant, because 5566 that's just saved us one malloc, copy and free - the regexp has 5567 donated the old buffer, and we malloc an entirely new one, rather 5568 than the regexp malloc()ing a buffer and copying our original, 5569 only for us to throw it away here during the substitution. */ 5570 if (SvIsCOW(TARG)) { 5571 sv_force_normal_flags(TARG, SV_COW_DROP_PV); 5572 } else 5573 #endif 5574 { 5575 SvPV_free(TARG); 5576 } 5577 SvPV_set(TARG, SvPVX(dstr)); 5578 SvCUR_set(TARG, SvCUR(dstr)); 5579 SvLEN_set(TARG, SvLEN(dstr)); 5580 SvFLAGS(TARG) |= SvUTF8(dstr); 5581 SvPV_set(dstr, NULL); 5582 goto ret_iters; 5583 } 5584 } 5585 5586 ret_iters: 5587 if (PL_op->op_private & OPpTRUEBOOL) 5588 retval = &PL_sv_yes; 5589 else { 5590 retval = sv_newmortal(); 5591 sv_setiv(retval, iters); 5592 } 5593 5594 ret: 5595 if (dstr) 5596 rpp_popfree_1_NN(); /* pop replacement string */ 5597 if (PL_op->op_flags & OPf_STACKED) 5598 rpp_replace_1_1_NN(retval); /* pop LHS of =~ */ 5599 else 5600 rpp_push_1(retval); 5601 5602 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) { 5603 (void)SvPOK_only_UTF8(TARG); 5604 } 5605 5606 /* See "how taint works" above */ 5607 if (TAINTING_get) { 5608 if ((rxtainted & SUBST_TAINT_PAT) || 5609 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) == 5610 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) 5611 ) 5612 (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */ 5613 5614 if (!(rxtainted & SUBST_TAINT_BOOLRET) 5615 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT)) 5616 ) 5617 SvTAINTED_on(retval); /* taint return value */ 5618 else 5619 SvTAINTED_off(retval); /* may have got tainted earlier */ 5620 5621 /* needed for mg_set below */ 5622 TAINT_set( 5623 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)) 5624 ); 5625 SvTAINT(TARG); 5626 } 5627 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */ 5628 TAINT_NOT; 5629 LEAVE_SCOPE(oldsave); 5630 return NORMAL; 5631 } 5632 5633 5634 PP(pp_grepwhile) 5635 { 5636 /* Understanding the stack during a grep. 5637 * 5638 * 'grep expr, args' is implemented in the form of 5639 * grepstart; 5640 * do { 5641 * expr; 5642 * grepwhile; 5643 * } while (args); 5644 * 5645 * The stack examples below are in the form of 'perl -Ds' output, 5646 * where any stack element indexed by PL_markstack_ptr[i] has a star 5647 * just to the right of it. In addition, the corresponding i value 5648 * is displayed under the indexed stack element. 5649 * 5650 * On entry to grepwhile, the stack looks like this: 5651 * 5652 * => * M1..Mn X1 * X2..Xn C * R1..Rn BOOL 5653 * [-2] [-1] [0] 5654 * 5655 * where: 5656 * M1..Mn Accumulated args which have been matched so far. 5657 * X1..Xn Random discardable elements from previous iterations. 5658 * C The current (just processed) arg, still aliased to $_. 5659 * R1..Rn The args remaining to be processed. 5660 * BOOL the result of the just-executed grep expression. 5661 * 5662 * Note that it is easiest to think of the top two stack marks as both 5663 * being one too high, and so it would make more sense to have had the 5664 * marks like this: 5665 * 5666 * => * M1..Mn * X1..Xn * C R1..Rn BOOL 5667 * [-2] [-1] [0] 5668 * 5669 * where the stack is divided neatly into 3 groups: 5670 * - matched, 5671 * - discarded, 5672 * - being, or yet to be, processed. 5673 * But off-by-one is the way it is currently, and it works as long as 5674 * we keep it consistent and bear it in mind. 5675 * 5676 * pp_grepwhile() does the following: 5677 * 5678 * - for a match, replace the X1 pointer with a pointer to C and bump 5679 * PL_markstack_ptr[-1] 5680 * - if more args to process, bump PL_markstack_ptr[0] and update the 5681 * $_ alias, else 5682 * - remove top 3 MARKs and return M1..Mn, or a scalar, 5683 * or void as appropriate. 5684 * 5685 */ 5686 5687 bool match = SvTRUE_NN(*PL_stack_sp); 5688 rpp_popfree_1_NN(); 5689 5690 if (match) { 5691 SV **from_p = PL_stack_base + PL_markstack_ptr[0]; 5692 SV **to_p = PL_stack_base + PL_markstack_ptr[-1]++; 5693 SV *from = *from_p; 5694 SV *to = *to_p; 5695 5696 if (from != to) { 5697 *to_p = from; 5698 #ifdef PERL_RC_STACK 5699 SvREFCNT_inc_simple_void_NN(from); 5700 SvREFCNT_dec(to); 5701 #endif 5702 } 5703 } 5704 5705 ++*PL_markstack_ptr; 5706 FREETMPS; 5707 LEAVE_with_name("grep_item"); /* exit inner scope */ 5708 5709 /* All done yet? */ 5710 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > PL_stack_sp)) { 5711 SSize_t items; 5712 const U8 gimme = GIMME_V; 5713 5714 LEAVE_with_name("grep"); /* exit outer scope */ 5715 (void)POPMARK; /* pop src */ 5716 items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; 5717 (void)POPMARK; /* pop dst */ 5718 SV **base = PL_stack_base + POPMARK; /* pop original mark */ 5719 5720 if (gimme == G_LIST) 5721 rpp_popfree_to_NN(base + items); 5722 else { 5723 rpp_popfree_to_NN(base); 5724 if (gimme == G_SCALAR) { 5725 if (PL_op->op_private & OPpTRUEBOOL) 5726 rpp_push_IMM(items ? &PL_sv_yes : &PL_sv_zero); 5727 else { 5728 dTARGET; 5729 TARGi(items,1); 5730 rpp_push_1(TARG); 5731 } 5732 } 5733 } 5734 5735 return NORMAL; 5736 } 5737 else { 5738 SV *src; 5739 5740 ENTER_with_name("grep_item"); /* enter inner scope */ 5741 SAVEVPTR(PL_curpm); 5742 5743 src = PL_stack_base[TOPMARK]; 5744 if (SvPADTMP(src)) { 5745 SV *newsrc = sv_mortalcopy(src); 5746 PL_stack_base[TOPMARK] = newsrc; 5747 #ifdef PERL_RC_STACK 5748 SvREFCNT_inc_simple_void_NN(newsrc); 5749 SvREFCNT_dec(src); 5750 #endif 5751 src = newsrc; 5752 PL_tmps_floor++; 5753 } 5754 SvTEMP_off(src); 5755 DEFSV_set(src); 5756 5757 return cLOGOP->op_other; 5758 } 5759 } 5760 5761 5762 /* leave_adjust_stacks(): 5763 * 5764 * Process a scope's return args (in the range from_sp+1 .. PL_stack_sp), 5765 * positioning them at to_sp+1 onwards, and do the equivalent of a 5766 * FREEMPS and TAINT_NOT. 5767 * 5768 * Not intended to be called in void context. 5769 * 5770 * When leaving a sub, eval, do{} or other scope, the things that need 5771 * doing to process the return args are: 5772 * * in scalar context, only return the last arg (or PL_sv_undef if none); 5773 * * for the types of return that return copies of their args (such 5774 * as rvalue sub return), make a mortal copy of every return arg, 5775 * except where we can optimise the copy away without it being 5776 * semantically visible; 5777 * * make sure that the arg isn't prematurely freed; in the case of an 5778 * arg not copied, this may involve mortalising it. For example, in 5779 * C<sub f { my $x = ...; $x }>, $x would be freed when we do 5780 * CX_LEAVE_SCOPE(cx) unless it's protected or copied. 5781 * 5782 * What condition to use when deciding whether to pass the arg through 5783 * or make a copy, is determined by the 'pass' arg; its valid values are: 5784 * 0: rvalue sub/eval exit 5785 * 1: other rvalue scope exit 5786 * 2: :lvalue sub exit in rvalue context 5787 * 3: :lvalue sub exit in lvalue context and other lvalue scope exits 5788 * 5789 * There is a big issue with doing a FREETMPS. We would like to free any 5790 * temps created by the last statement which the sub executed, rather than 5791 * leaving them for the caller. In a situation where a sub call isn't 5792 * soon followed by a nextstate (e.g. nested recursive calls, a la 5793 * fibonacci()), temps can accumulate, causing memory and performance 5794 * issues. 5795 * 5796 * On the other hand, we don't want to free any TEMPs which are keeping 5797 * alive any return args that we skipped copying; nor do we wish to undo 5798 * any mortalising done here. 5799 * 5800 * The solution is to split the temps stack frame into two, with a cut 5801 * point delineating the two halves. We arrange that by the end of this 5802 * function, all the temps stack frame entries we wish to keep are in the 5803 * range PL_tmps_floor+1.. tmps_base-1, while the ones to free now are in 5804 * the range tmps_base .. PL_tmps_ix. During the course of this 5805 * function, tmps_base starts off as PL_tmps_floor+1, then increases 5806 * whenever we find or create a temp that we know should be kept. In 5807 * general the stuff above tmps_base is undecided until we reach the end, 5808 * and we may need a sort stage for that. 5809 * 5810 * To determine whether a TEMP is keeping a return arg alive, every 5811 * arg that is kept rather than copied and which has the SvTEMP flag 5812 * set, has the flag temporarily unset, to mark it. At the end we scan 5813 * the temps stack frame above the cut for entries without SvTEMP and 5814 * keep them, while turning SvTEMP on again. Note that if we die before 5815 * the SvTEMPs flags are set again, its safe: at worst, subsequent use of 5816 * those SVs may be slightly less efficient. 5817 * 5818 * In practice various optimisations for some common cases mean we can 5819 * avoid most of the scanning and swapping about with the temps stack. 5820 */ 5821 5822 void 5823 Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass) 5824 { 5825 SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */ 5826 SSize_t nargs; 5827 5828 PERL_ARGS_ASSERT_LEAVE_ADJUST_STACKS; 5829 5830 TAINT_NOT; 5831 5832 if (gimme == G_LIST) { 5833 nargs = PL_stack_sp - from_sp; 5834 from_sp++; 5835 } 5836 else { 5837 assert(gimme == G_SCALAR); 5838 if (UNLIKELY(from_sp >= PL_stack_sp)) { 5839 /* no return args */ 5840 assert(from_sp == PL_stack_sp); 5841 rpp_xpush_IMM(&PL_sv_undef); 5842 } 5843 from_sp = PL_stack_sp; 5844 nargs = 1; 5845 } 5846 5847 /* common code for G_SCALAR and G_LIST */ 5848 5849 #ifdef PERL_RC_STACK 5850 { 5851 /* free any items from the stack which are about to get 5852 * over-written */ 5853 SV **p = from_sp - 1; 5854 assert(p >= to_sp); 5855 while (p > to_sp) { 5856 SV *sv = *p; 5857 *p-- = NULL; 5858 SvREFCNT_dec(sv); 5859 } 5860 } 5861 #endif 5862 5863 5864 tmps_base = PL_tmps_floor + 1; 5865 5866 assert(nargs >= 0); 5867 if (nargs) { 5868 /* pointer version of tmps_base. Not safe across temp stack 5869 * reallocs. */ 5870 SV **tmps_basep; 5871 5872 EXTEND_MORTAL(nargs); /* one big extend for worst-case scenario */ 5873 tmps_basep = PL_tmps_stack + tmps_base; 5874 5875 /* process each return arg */ 5876 5877 do { 5878 SV *sv = *from_sp++; 5879 5880 assert(PL_tmps_ix + nargs < PL_tmps_max); 5881 #ifdef DEBUGGING 5882 /* PADTMPs with container set magic shouldn't appear in the 5883 * wild. This assert is more important for pp_leavesublv(), 5884 * but by testing for it here, we're more likely to catch 5885 * bad cases (what with :lvalue subs not being widely 5886 * deployed). The two issues are that for something like 5887 * sub :lvalue { $tied{foo} } 5888 * or 5889 * sub :lvalue { substr($foo,1,2) } 5890 * pp_leavesublv() will croak if the sub returns a PADTMP, 5891 * and currently functions like pp_substr() return a mortal 5892 * rather than using their PADTMP when returning a PVLV. 5893 * This is because the PVLV will hold a ref to $foo, 5894 * so $foo would get delayed in being freed while 5895 * the PADTMP SV remained in the PAD. 5896 * So if this assert fails it means either: 5897 * 1) there is pp code similar to pp_substr that is 5898 * returning a PADTMP instead of a mortal, and probably 5899 * needs fixing, or 5900 * 2) pp_leavesublv is making unwarranted assumptions 5901 * about always croaking on a PADTMP 5902 */ 5903 if (SvPADTMP(sv) && SvSMAGICAL(sv)) { 5904 MAGIC *mg; 5905 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 5906 assert(PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)); 5907 } 5908 } 5909 #endif 5910 5911 if ( 5912 pass == 0 ? (rpp_is_lone(sv) && !SvMAGICAL(sv)) 5913 : pass == 1 ? ((SvTEMP(sv) || SvPADTMP(sv)) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1) 5914 : pass == 2 ? (!SvPADTMP(sv)) 5915 : 1) 5916 { 5917 /* pass through: skip copy for logic or optimisation 5918 * reasons; instead mortalise it, except that ... */ 5919 5920 #ifdef PERL_RC_STACK 5921 from_sp[-1] = NULL; 5922 #endif 5923 *++to_sp = sv; 5924 5925 if (SvTEMP(sv)) { 5926 /* ... since this SV is an SvTEMP , we don't need to 5927 * re-mortalise it; instead we just need to ensure 5928 * that its existing entry in the temps stack frame 5929 * ends up below the cut and so avoids being freed 5930 * this time round. We mark it as needing to be kept 5931 * by temporarily unsetting SvTEMP; then at the end, 5932 * we shuffle any !SvTEMP entries on the tmps stack 5933 * back below the cut. 5934 * However, there's a significant chance that there's 5935 * a 1:1 correspondence between the first few (or all) 5936 * elements in the return args stack frame and those 5937 * in the temps stack frame; e,g.: 5938 * sub f { ....; map {...} .... }, 5939 * or if we're exiting multiple scopes and one of the 5940 * inner scopes has already made mortal copies of each 5941 * return arg. 5942 * 5943 * If so, this arg sv will correspond to the next item 5944 * on the tmps stack above the cut, and so can be kept 5945 * merely by moving the cut boundary up one, rather 5946 * than messing with SvTEMP. If all args are 1:1 then 5947 * we can avoid the sorting stage below completely. 5948 * 5949 * If there are no items above the cut on the tmps 5950 * stack, then the SvTEMP must comne from an item 5951 * below the cut, so there's nothing to do. 5952 */ 5953 if (tmps_basep <= &PL_tmps_stack[PL_tmps_ix]) { 5954 if (sv == *tmps_basep) 5955 tmps_basep++; 5956 else 5957 SvTEMP_off(sv); 5958 } 5959 } 5960 else if (!SvPADTMP(sv)) { 5961 /* mortalise arg to avoid it being freed during save 5962 * stack unwinding. Pad tmps don't need mortalising as 5963 * they're never freed. This is the equivalent of 5964 * sv_2mortal(SvREFCNT_inc(sv)), except that: 5965 * * it assumes that the temps stack has already been 5966 * extended; 5967 * * it puts the new item at the cut rather than at 5968 * ++PL_tmps_ix, moving the previous occupant there 5969 * instead. 5970 */ 5971 if (!SvIMMORTAL(sv)) { 5972 SvREFCNT_inc_simple_void_NN(sv); 5973 SvTEMP_on(sv); 5974 /* Note that if there's nothing above the cut, 5975 * this copies the garbage one slot above 5976 * PL_tmps_ix onto itself. This is harmless (the 5977 * stack's already been extended), but might in 5978 * theory trigger warnings from tools like ASan 5979 */ 5980 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep; 5981 *tmps_basep++ = sv; 5982 } 5983 } 5984 } 5985 else { 5986 /* Make a mortal copy of the SV. 5987 * The following code is the equivalent of sv_mortalcopy() 5988 * except that: 5989 * * it assumes the temps stack has already been extended; 5990 * * it optimises the copying for some simple SV types; 5991 * * it puts the new item at the cut rather than at 5992 * ++PL_tmps_ix, moving the previous occupant there 5993 * instead. 5994 */ 5995 SV *newsv = newSV_type(SVt_NULL); 5996 5997 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep; 5998 /* put it on the tmps stack early so it gets freed if we die */ 5999 *tmps_basep++ = newsv; 6000 6001 if (SvTYPE(sv) <= SVt_IV) { 6002 /* arg must be one of undef, IV/UV, or RV: skip 6003 * sv_setsv_flags() and do the copy directly */ 6004 U32 dstflags; 6005 U32 srcflags = SvFLAGS(sv); 6006 6007 assert(!SvGMAGICAL(sv)); 6008 if (srcflags & (SVf_IOK|SVf_ROK)) { 6009 SET_SVANY_FOR_BODYLESS_IV(newsv); 6010 6011 if (srcflags & SVf_ROK) { 6012 newsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(sv)); 6013 /* SV type plus flags */ 6014 dstflags = (SVt_IV|SVf_ROK|SVs_TEMP); 6015 } 6016 else { 6017 /* both src and dst are <= SVt_IV, so sv_any 6018 * points to the head; so access the heads 6019 * directly rather than going via sv_any. 6020 */ 6021 assert( &(sv->sv_u.svu_iv) 6022 == &(((XPVIV*) SvANY(sv))->xiv_iv)); 6023 assert( &(newsv->sv_u.svu_iv) 6024 == &(((XPVIV*) SvANY(newsv))->xiv_iv)); 6025 newsv->sv_u.svu_iv = sv->sv_u.svu_iv; 6026 /* SV type plus flags */ 6027 dstflags = (SVt_IV|SVf_IOK|SVp_IOK|SVs_TEMP 6028 |(srcflags & SVf_IVisUV)); 6029 } 6030 } 6031 else { 6032 assert(!(srcflags & SVf_OK)); 6033 dstflags = (SVt_NULL|SVs_TEMP); /* SV type plus flags */ 6034 } 6035 SvFLAGS(newsv) = dstflags; 6036 6037 } 6038 else { 6039 /* do the full sv_setsv() */ 6040 SSize_t old_base; 6041 6042 SvTEMP_on(newsv); 6043 old_base = tmps_basep - PL_tmps_stack; 6044 SvGETMAGIC(sv); 6045 sv_setsv_flags(newsv, sv, SV_DO_COW_SVSETSV); 6046 /* the mg_get or sv_setsv might have created new temps 6047 * or realloced the tmps stack; regrow and reload */ 6048 EXTEND_MORTAL(nargs); 6049 tmps_basep = PL_tmps_stack + old_base; 6050 TAINT_NOT; /* Each item is independent */ 6051 } 6052 6053 6054 #ifdef PERL_RC_STACK 6055 from_sp[-1] = NULL; 6056 SvREFCNT_dec_NN(sv); 6057 assert(!to_sp[1]); 6058 *++to_sp = newsv; 6059 SvREFCNT_inc_simple_void_NN(newsv); 6060 #else 6061 *++to_sp = newsv; 6062 #endif 6063 6064 } 6065 } while (--nargs); 6066 6067 /* If there are any temps left above the cut, we need to sort 6068 * them into those to keep and those to free. The only ones to 6069 * keep are those for which we've temporarily unset SvTEMP. 6070 * Work inwards from the two ends at tmps_basep .. PL_tmps_ix, 6071 * swapping pairs as necessary. Stop when we meet in the middle. 6072 */ 6073 { 6074 SV **top = PL_tmps_stack + PL_tmps_ix; 6075 while (tmps_basep <= top) { 6076 SV *sv = *top; 6077 if (SvTEMP(sv)) 6078 top--; 6079 else { 6080 SvTEMP_on(sv); 6081 *top = *tmps_basep; 6082 *tmps_basep = sv; 6083 tmps_basep++; 6084 } 6085 } 6086 } 6087 6088 tmps_base = tmps_basep - PL_tmps_stack; 6089 } 6090 6091 PL_stack_sp = to_sp; 6092 6093 /* unrolled FREETMPS() but using tmps_base-1 rather than PL_tmps_floor */ 6094 while (PL_tmps_ix >= tmps_base) { 6095 SV* const sv = PL_tmps_stack[PL_tmps_ix--]; 6096 #ifdef PERL_POISON 6097 PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB); 6098 #endif 6099 if (LIKELY(sv)) { 6100 SvTEMP_off(sv); 6101 SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */ 6102 } 6103 } 6104 } 6105 6106 6107 /* also tail-called by pp_return */ 6108 6109 PP(pp_leavesub) 6110 { 6111 U8 gimme; 6112 PERL_CONTEXT *cx; 6113 SV **oldsp; 6114 OP *retop; 6115 6116 cx = CX_CUR(); 6117 assert(CxTYPE(cx) == CXt_SUB); 6118 6119 if (CxMULTICALL(cx)) { 6120 /* entry zero of a stack is always PL_sv_undef, which 6121 * simplifies converting a '()' return into undef in scalar context */ 6122 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef); 6123 return 0; 6124 } 6125 6126 gimme = cx->blk_gimme; 6127 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */ 6128 6129 if (gimme == G_VOID) 6130 rpp_popfree_to_NN(oldsp); 6131 else 6132 leave_adjust_stacks(oldsp, oldsp, gimme, 0); 6133 6134 CX_LEAVE_SCOPE(cx); 6135 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */ 6136 cx_popblock(cx); 6137 retop = cx->blk_sub.retop; 6138 CX_POP(cx); 6139 6140 return retop; 6141 } 6142 6143 6144 /* clear (if possible) or abandon the current @_. If 'abandon' is true, 6145 * forces an abandon */ 6146 6147 void 6148 Perl_clear_defarray(pTHX_ AV* av, bool abandon) 6149 { 6150 PERL_ARGS_ASSERT_CLEAR_DEFARRAY; 6151 6152 if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av)) 6153 #ifndef PERL_RC_STACK 6154 && !AvREAL(av) 6155 #endif 6156 ) { 6157 clear_defarray_simple(av); 6158 #ifndef PERL_RC_STACK 6159 AvREIFY_only(av); 6160 #endif 6161 } 6162 else { 6163 /* abandon */ 6164 const SSize_t size = AvFILLp(av) + 1; 6165 /* The ternary gives consistency with av_extend() */ 6166 AV *newav = newAV_alloc_xz(size < PERL_ARRAY_NEW_MIN_KEY ? 6167 PERL_ARRAY_NEW_MIN_KEY : size); 6168 #ifndef PERL_RC_STACK 6169 AvREIFY_only(newav); 6170 #endif 6171 PAD_SVl(0) = MUTABLE_SV(newav); 6172 SvREFCNT_dec_NN(av); 6173 } 6174 } 6175 6176 6177 PP(pp_entersub) 6178 { 6179 GV *gv; 6180 CV *cv; 6181 PERL_CONTEXT *cx; 6182 I32 old_savestack_ix; 6183 SV *sv = *PL_stack_sp; 6184 6185 if (UNLIKELY(!sv)) 6186 goto do_die; 6187 6188 /* Locate the CV to call: 6189 * - most common case: RV->CV: f(), $ref->(): 6190 * note that if a sub is compiled before its caller is compiled, 6191 * the stash entry will be a ref to a CV, rather than being a GV. 6192 * - second most common case: CV: $ref->method() 6193 */ 6194 6195 /* a non-magic-RV -> CV ? */ 6196 if (LIKELY( (SvFLAGS(sv) & (SVf_ROK|SVs_GMG)) == SVf_ROK)) { 6197 cv = MUTABLE_CV(SvRV(sv)); 6198 if (UNLIKELY(SvOBJECT(cv))) /* might be overloaded */ 6199 goto do_ref; 6200 } 6201 else 6202 cv = MUTABLE_CV(sv); 6203 6204 /* a CV ? */ 6205 if (UNLIKELY(SvTYPE(cv) != SVt_PVCV)) { 6206 /* handle all the weird cases */ 6207 switch (SvTYPE(sv)) { 6208 case SVt_PVLV: 6209 if (!isGV_with_GP(sv)) 6210 goto do_default; 6211 /* FALLTHROUGH */ 6212 case SVt_PVGV: 6213 cv = GvCVu((const GV *)sv); 6214 if (UNLIKELY(!cv)) { 6215 HV *stash; 6216 cv = sv_2cv(sv, &stash, &gv, 0); 6217 if (!cv) { 6218 old_savestack_ix = PL_savestack_ix; 6219 goto try_autoload; 6220 } 6221 } 6222 break; 6223 6224 default: 6225 do_default: 6226 SvGETMAGIC(sv); 6227 if (SvROK(sv)) { 6228 do_ref: 6229 if (UNLIKELY(SvAMAGIC(sv))) { 6230 sv = amagic_deref_call(sv, to_cv_amg); 6231 } 6232 } 6233 else { 6234 const char *sym; 6235 STRLEN len; 6236 if (UNLIKELY(!SvOK(sv))) 6237 DIE(aTHX_ PL_no_usym, "a subroutine"); 6238 6239 sym = SvPV_nomg_const(sv, len); 6240 if (PL_op->op_private & HINT_STRICT_REFS) 6241 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : ""); 6242 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv)); 6243 break; 6244 } 6245 cv = MUTABLE_CV(SvRV(sv)); 6246 if (LIKELY(SvTYPE(cv) == SVt_PVCV)) 6247 break; 6248 /* FALLTHROUGH */ 6249 case SVt_PVHV: 6250 case SVt_PVAV: 6251 do_die: 6252 DIE(aTHX_ "Not a CODE reference"); 6253 } 6254 } 6255 6256 /* At this point we want to save PL_savestack_ix, either by doing a 6257 * cx_pushsub(), or for XS, doing an ENTER. But we don't yet know the final 6258 * CV we will be using (so we don't know whether its XS, so we can't 6259 * cx_pushsub() or ENTER yet), and determining cv may itself push stuff on 6260 * the save stack. So remember where we are currently on the save 6261 * stack, and later update the CX or scopestack entry accordingly. */ 6262 old_savestack_ix = PL_savestack_ix; 6263 6264 /* these two fields are in a union. If they ever become separate, 6265 * we have to test for both of them being null below */ 6266 assert(cv); 6267 assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv)); 6268 while (UNLIKELY(!CvROOT(cv))) { 6269 GV* autogv; 6270 SV* sub_name; 6271 6272 /* anonymous or undef'd function leaves us no recourse */ 6273 if (CvLEXICAL(cv) && CvHASGV(cv)) 6274 DIE(aTHX_ "Undefined subroutine &%" SVf " called", 6275 SVfARG(cv_name(cv, NULL, 0))); 6276 if (CvANON(cv) || !CvHASGV(cv)) { 6277 DIE(aTHX_ "Undefined subroutine called"); 6278 } 6279 6280 /* autoloaded stub? */ 6281 if (cv != GvCV(gv = CvGV(cv))) { 6282 cv = GvCV(gv); 6283 } 6284 /* should call AUTOLOAD now? */ 6285 else { 6286 try_autoload: 6287 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), 6288 (GvNAMEUTF8(gv) ? SVf_UTF8 : 0) 6289 |(PL_op->op_flags & OPf_REF 6290 ? GV_AUTOLOAD_ISMETHOD 6291 : 0)); 6292 cv = autogv ? GvCV(autogv) : NULL; 6293 } 6294 if (!cv) { 6295 sub_name = sv_newmortal(); 6296 gv_efullname3(sub_name, gv, NULL); 6297 DIE(aTHX_ "Undefined subroutine &%" SVf " called", SVfARG(sub_name)); 6298 } 6299 } 6300 6301 /* unrolled "CvCLONE(cv) && ! CvCLONED(cv)" */ 6302 if (UNLIKELY((CvFLAGS(cv) & (CVf_CLONE|CVf_CLONED)) == CVf_CLONE)) 6303 DIE(aTHX_ "Closure prototype called"); 6304 6305 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) 6306 && !CvNODEBUG(cv))) 6307 { 6308 Perl_get_db_sub(aTHX_ &sv, cv); 6309 if (CvISXSUB(cv)) 6310 PL_curcopdb = PL_curcop; 6311 if (CvLVALUE(cv)) { 6312 /* check for lsub that handles lvalue subroutines */ 6313 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV)); 6314 /* if lsub not found then fall back to DB::sub */ 6315 if (!cv) cv = GvCV(PL_DBsub); 6316 } else { 6317 cv = GvCV(PL_DBsub); 6318 } 6319 6320 if (!cv || (!CvXSUB(cv) && !CvSTART(cv))) 6321 DIE(aTHX_ "No DB::sub routine defined"); 6322 } 6323 6324 rpp_popfree_1_NN(); /* finished with sv now */ 6325 6326 if (!(CvISXSUB(cv))) { 6327 /* This path taken at least 75% of the time */ 6328 dMARK; 6329 PADLIST *padlist; 6330 I32 depth; 6331 bool hasargs; 6332 U8 gimme; 6333 6334 /* keep PADTMP args alive throughout the call (we need to do this 6335 * because @_ isn't refcounted). Note that we create the mortals 6336 * in the caller's tmps frame, so they won't be freed until after 6337 * we return from the sub. 6338 */ 6339 { 6340 SV **svp = MARK; 6341 while (svp < PL_stack_sp) { 6342 SV *sv = *++svp; 6343 if (!sv) 6344 continue; 6345 if (SvPADTMP(sv)) { 6346 SV *newsv = sv_mortalcopy(sv); 6347 *svp = newsv; 6348 #ifdef PERL_RC_STACK 6349 /* should just skip the mortalisation instead */ 6350 SvREFCNT_inc_simple_void_NN(newsv); 6351 SvREFCNT_dec_NN(sv); 6352 #endif 6353 sv = newsv; 6354 } 6355 SvTEMP_off(sv); 6356 } 6357 } 6358 6359 gimme = GIMME_V; 6360 cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix); 6361 hasargs = cBOOL(PL_op->op_flags & OPf_STACKED); 6362 cx_pushsub(cx, cv, PL_op->op_next, hasargs); 6363 6364 padlist = CvPADLIST(cv); 6365 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) 6366 pad_push(padlist, depth); 6367 PAD_SET_CUR_NOSAVE(padlist, depth); 6368 if (LIKELY(hasargs)) { 6369 AV *const av = MUTABLE_AV(PAD_SVl(0)); 6370 SSize_t items; 6371 AV **defavp; 6372 6373 defavp = &GvAV(PL_defgv); 6374 cx->blk_sub.savearray = *defavp; 6375 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av)); 6376 6377 /* it's the responsibility of whoever leaves a sub to ensure 6378 * that a clean, empty AV is left in pad[0]. This is normally 6379 * done by cx_popsub() */ 6380 6381 #ifdef PERL_RC_STACK 6382 assert(AvREAL(av)); 6383 #else 6384 assert(!AvREAL(av)); 6385 #endif 6386 assert(AvFILLp(av) == -1); 6387 6388 items = PL_stack_sp - MARK; 6389 if (UNLIKELY(items - 1 > AvMAX(av))) { 6390 SV **ary = AvALLOC(av); 6391 Renew(ary, items, SV*); 6392 AvMAX(av) = items - 1; 6393 AvALLOC(av) = ary; 6394 AvARRAY(av) = ary; 6395 } 6396 6397 if (items) 6398 Copy(MARK+1,AvARRAY(av),items,SV*); 6399 AvFILLp(av) = items - 1; 6400 #ifdef PERL_RC_STACK 6401 /* transfer ownership of the arguments' refcounts to av */ 6402 PL_stack_sp = MARK; 6403 #endif 6404 } 6405 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && 6406 !CvLVALUE(cv))) 6407 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf, 6408 SVfARG(cv_name(cv, NULL, 0))); 6409 /* warning must come *after* we fully set up the context 6410 * stuff so that __WARN__ handlers can safely dounwind() 6411 * if they want to 6412 */ 6413 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN 6414 && ckWARN(WARN_RECURSION) 6415 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))) 6416 sub_crush_depth(cv); 6417 return CvSTART(cv); 6418 } 6419 else { 6420 SSize_t markix = TOPMARK; 6421 bool is_scalar; 6422 6423 ENTER; 6424 /* pretend we did the ENTER earlier */ 6425 PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix; 6426 6427 SAVETMPS; 6428 6429 if (UNLIKELY(((PL_op->op_private 6430 & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub) 6431 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && 6432 !CvLVALUE(cv))) 6433 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf, 6434 SVfARG(cv_name(cv, NULL, 0))); 6435 6436 if (UNLIKELY(!(PL_op->op_flags & OPf_STACKED) && GvAV(PL_defgv))) { 6437 /* Need to copy @_ to stack. Alternative may be to 6438 * switch stack to @_, and copy return values 6439 * back. This would allow popping @_ in XSUB, e.g.. XXXX */ 6440 AV * const av = GvAV(PL_defgv); 6441 const SSize_t items = AvFILL(av) + 1; 6442 6443 if (items) { 6444 SSize_t i = 0; 6445 const bool m = cBOOL(SvRMAGICAL(av)); 6446 /* Mark is at the end of the stack. */ 6447 rpp_extend(items); 6448 for (; i < items; ++i) 6449 { 6450 SV *sv; 6451 if (m) { 6452 SV ** const svp = av_fetch(av, i, 0); 6453 sv = svp ? *svp : NULL; 6454 } 6455 else 6456 sv = AvARRAY(av)[i]; 6457 6458 rpp_push_1(sv ? sv : av_nonelem(av, i)); 6459 } 6460 } 6461 } 6462 else { 6463 SV **mark = PL_stack_base + markix; 6464 SSize_t items = PL_stack_sp - mark; 6465 while (items--) { 6466 mark++; 6467 if (*mark && SvPADTMP(*mark)) { 6468 SV *oldsv = *mark; 6469 SV *newsv = sv_mortalcopy(oldsv); 6470 *mark = newsv; 6471 #ifdef PERL_RC_STACK 6472 /* should just skip the mortalisation instead */ 6473 SvREFCNT_inc_simple_void_NN(newsv); 6474 SvREFCNT_dec_NN(oldsv); 6475 #endif 6476 } 6477 } 6478 } 6479 6480 /* We assume first XSUB in &DB::sub is the called one. */ 6481 if (UNLIKELY(PL_curcopdb)) { 6482 SAVEVPTR(PL_curcop); 6483 PL_curcop = PL_curcopdb; 6484 PL_curcopdb = NULL; 6485 } 6486 /* Do we need to open block here? XXXX */ 6487 6488 /* calculate gimme here as PL_op might get changed and then not 6489 * restored until the LEAVE further down */ 6490 is_scalar = (GIMME_V == G_SCALAR); 6491 6492 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */ 6493 assert(CvXSUB(cv)); 6494 6495 rpp_invoke_xs(cv); 6496 6497 #ifdef PERL_USE_HWM 6498 /* This duplicates the check done in runops_debug(), but provides more 6499 * information in the common case of the fault being with an XSUB. 6500 * 6501 * It should also catch an XSUB pushing more than it extends 6502 * in scalar context. 6503 */ 6504 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base) 6505 Perl_croak_nocontext( 6506 "panic: XSUB %s::%s (%s) failed to extend arg stack: " 6507 "base=%p, sp=%p, hwm=%p\n", 6508 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)), CvFILE(cv), 6509 PL_stack_base, PL_stack_sp, 6510 PL_stack_base + PL_curstackinfo->si_stack_hwm); 6511 #endif 6512 /* Enforce some sanity in scalar context. */ 6513 if (is_scalar) { 6514 SV **svp = PL_stack_base + markix + 1; 6515 if (svp != PL_stack_sp) { 6516 #ifdef PERL_RC_STACK 6517 if (svp < PL_stack_sp) { 6518 /* move return value to bottom of stack frame 6519 * and free everything else */ 6520 SV* retsv = *PL_stack_sp; 6521 *PL_stack_sp = *svp; 6522 *svp = retsv; 6523 rpp_popfree_to_NN(svp); 6524 } 6525 else 6526 rpp_push_IMM(&PL_sv_undef); 6527 #else 6528 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp; 6529 PL_stack_sp = svp; 6530 #endif 6531 } 6532 } 6533 LEAVE; 6534 return NORMAL; 6535 } 6536 } 6537 6538 void 6539 Perl_sub_crush_depth(pTHX_ CV *cv) 6540 { 6541 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH; 6542 6543 if (CvANON(cv)) 6544 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); 6545 else { 6546 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%" SVf "\"", 6547 SVfARG(cv_name(cv,NULL,0))); 6548 } 6549 } 6550 6551 6552 6553 /* like croak, but report in context of caller */ 6554 6555 void 6556 Perl_croak_caller(const char *pat, ...) 6557 { 6558 dTHX; 6559 va_list args; 6560 const PERL_CONTEXT *cx = caller_cx(0, NULL); 6561 6562 /* make error appear at call site */ 6563 assert(cx); 6564 PL_curcop = cx->blk_oldcop; 6565 6566 va_start(args, pat); 6567 vcroak(pat, &args); 6568 NOT_REACHED; /* NOTREACHED */ 6569 va_end(args); 6570 } 6571 6572 6573 PP(pp_aelem) 6574 { 6575 SV** svp; 6576 SV* const elemsv = PL_stack_sp[0]; 6577 IV elem = SvIV(elemsv); 6578 AV *const av = MUTABLE_AV(PL_stack_sp[-1]); 6579 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET; 6580 const U32 defer = PL_op->op_private & OPpLVAL_DEFER; 6581 const bool localizing = PL_op->op_private & OPpLVAL_INTRO; 6582 bool preeminent = TRUE; 6583 SV *sv; 6584 SV *retsv; 6585 6586 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))) 6587 Perl_warner(aTHX_ packWARN(WARN_MISC), 6588 "Use of reference \"%" SVf "\" as array index", 6589 SVfARG(elemsv)); 6590 if (UNLIKELY(SvTYPE(av) != SVt_PVAV)) { 6591 retsv = &PL_sv_undef; 6592 goto ret; 6593 } 6594 6595 if (UNLIKELY(localizing)) { 6596 MAGIC *mg; 6597 HV *stash; 6598 6599 /* Try to preserve the existence of a tied array 6600 * element by using EXISTS and DELETE if possible. 6601 * Fall back to FETCH and STORE otherwise. */ 6602 if (SvCANEXISTDELETE(av)) 6603 preeminent = av_exists(av, elem); 6604 } 6605 6606 svp = av_fetch(av, elem, lval && !defer); 6607 if (lval) { 6608 #ifdef PERL_MALLOC_WRAP 6609 if (SvUOK(elemsv)) { 6610 const UV uv = SvUV(elemsv); 6611 elem = uv > IV_MAX ? IV_MAX : uv; 6612 } 6613 else if (SvNOK(elemsv)) 6614 elem = (IV)SvNV(elemsv); 6615 if (elem > 0) { 6616 MEM_WRAP_CHECK_s(elem,SV*,"Out of memory during array extend"); 6617 } 6618 #endif 6619 if (!svp || !*svp) { 6620 IV len; 6621 if (!defer) 6622 DIE(aTHX_ PL_no_aelem, elem); 6623 len = av_top_index(av); 6624 /* Resolve a negative index that falls within the array. Leave 6625 it negative it if falls outside the array. */ 6626 if (elem < 0 && len + elem >= 0) 6627 elem = len + elem; 6628 if (elem >= 0 && elem <= len) 6629 /* Falls within the array. */ 6630 retsv = av_nonelem(av, elem); 6631 else 6632 /* Falls outside the array. If it is negative, 6633 magic_setdefelem will use the index for error reporting. 6634 */ 6635 retsv = sv_2mortal(newSVavdefelem(av, elem, 1)); 6636 goto ret; 6637 } 6638 if (UNLIKELY(localizing)) { 6639 if (preeminent) 6640 save_aelem(av, elem, svp); 6641 else 6642 SAVEADELETE(av, elem); 6643 } 6644 else if (PL_op->op_private & OPpDEREF) { 6645 retsv = vivify_ref(*svp, PL_op->op_private & OPpDEREF); 6646 goto ret; 6647 } 6648 } 6649 sv = (svp ? *svp : &PL_sv_undef); 6650 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */ 6651 mg_get(sv); 6652 retsv = sv; 6653 6654 ret: 6655 rpp_replace_2_1_NN(retsv); 6656 return NORMAL; 6657 } 6658 6659 SV* 6660 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) 6661 { 6662 PERL_ARGS_ASSERT_VIVIFY_REF; 6663 6664 SvGETMAGIC(sv); 6665 if (!SvOK(sv)) { 6666 if (SvREADONLY(sv)) 6667 Perl_croak_no_modify(); 6668 prepare_SV_for_RV(sv); 6669 switch (to_what) { 6670 case OPpDEREF_SV: 6671 SvRV_set(sv, newSV_type(SVt_NULL)); 6672 break; 6673 case OPpDEREF_AV: 6674 SvRV_set(sv, MUTABLE_SV(newAV())); 6675 break; 6676 case OPpDEREF_HV: 6677 SvRV_set(sv, MUTABLE_SV(newHV())); 6678 break; 6679 } 6680 SvROK_on(sv); 6681 SvSETMAGIC(sv); 6682 SvGETMAGIC(sv); 6683 } 6684 if (SvGMAGICAL(sv)) { 6685 /* copy the sv without magic to prevent magic from being 6686 executed twice */ 6687 SV* msv = sv_newmortal(); 6688 sv_setsv_nomg(msv, sv); 6689 return msv; 6690 } 6691 return sv; 6692 } 6693 6694 PERL_STATIC_INLINE HV * 6695 S_opmethod_stash(pTHX_ SV* meth) 6696 { 6697 SV* ob; 6698 HV* stash; 6699 6700 SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp 6701 ? (Perl_croak(aTHX_ "Can't call method \"%" SVf "\" without a " 6702 "package or object reference", SVfARG(meth)), 6703 (SV *)NULL) 6704 : *(PL_stack_base + TOPMARK + 1); 6705 6706 PERL_ARGS_ASSERT_OPMETHOD_STASH; 6707 6708 if (UNLIKELY(!sv)) 6709 undefined: 6710 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on an undefined value", 6711 SVfARG(meth)); 6712 6713 if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv); 6714 else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */ 6715 stash = gv_stashsv(sv, GV_CACHE_ONLY); 6716 if (stash) return stash; 6717 } 6718 6719 if (SvROK(sv)) 6720 ob = MUTABLE_SV(SvRV(sv)); 6721 else if (!SvOK(sv)) goto undefined; 6722 else if (isGV_with_GP(sv)) { 6723 if (!GvIO(sv)) 6724 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" " 6725 "without a package or object reference", 6726 SVfARG(meth)); 6727 ob = sv; 6728 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') { 6729 assert(!LvTARGLEN(ob)); 6730 ob = LvTARG(ob); 6731 assert(ob); 6732 } 6733 /* Replace the object at the base of the stack frame. 6734 * This is "below" whatever pp_wrap has wrapped, so needs freeing. 6735 */ 6736 SV *newsv = sv_2mortal(newRV(ob)); 6737 SV **svp = (PL_stack_base + TOPMARK + 1); 6738 #ifdef PERL_RC_STACK 6739 SV *oldsv = *svp; 6740 #endif 6741 *svp = newsv; 6742 #ifdef PERL_RC_STACK 6743 SvREFCNT_inc_simple_void_NN(newsv); 6744 SvREFCNT_dec_NN(oldsv); 6745 #endif 6746 } 6747 else { 6748 /* this isn't a reference */ 6749 GV* iogv; 6750 STRLEN packlen; 6751 const char * const packname = SvPV_nomg_const(sv, packlen); 6752 const U32 packname_utf8 = SvUTF8(sv); 6753 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY); 6754 if (stash) return stash; 6755 6756 if ((PL_op->op_private & OPpMETH_NO_BAREWORD_IO) || 6757 !(iogv = gv_fetchpvn_flags( 6758 packname, packlen, packname_utf8, SVt_PVIO 6759 )) || 6760 !(ob=MUTABLE_SV(GvIO(iogv)))) 6761 { 6762 /* this isn't the name of a filehandle either */ 6763 if (!packlen) 6764 { 6765 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" " 6766 "without a package or object reference", 6767 SVfARG(meth)); 6768 } 6769 /* assume it's a package name */ 6770 stash = gv_stashpvn(packname, packlen, packname_utf8); 6771 if (stash) return stash; 6772 else return MUTABLE_HV(sv); 6773 } 6774 /* it _is_ a filehandle name -- replace with a reference. 6775 * Replace the object at the base of the stack frame. 6776 * This is "below" whatever pp_wrap has wrapped, so needs freeing. 6777 */ 6778 SV *newsv = sv_2mortal(newRV(MUTABLE_SV(iogv))); 6779 SV **svp = (PL_stack_base + TOPMARK + 1); 6780 #ifdef PERL_RC_STACK 6781 SV *oldsv = *svp; 6782 #endif 6783 *svp = newsv; 6784 #ifdef PERL_RC_STACK 6785 SvREFCNT_inc_simple_void_NN(newsv); 6786 SvREFCNT_dec_NN(oldsv); 6787 #endif 6788 } 6789 6790 /* if we got here, ob should be an object or a glob */ 6791 if (!ob || !(SvOBJECT(ob) 6792 || (isGV_with_GP(ob) 6793 && (ob = MUTABLE_SV(GvIO((const GV *)ob))) 6794 && SvOBJECT(ob)))) 6795 { 6796 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on unblessed reference", 6797 SVfARG((SvPOK(meth) && SvPVX(meth) == PL_isa_DOES) 6798 ? newSVpvs_flags("DOES", SVs_TEMP) 6799 : meth)); 6800 } 6801 6802 return SvSTASH(ob); 6803 } 6804 6805 PP(pp_method) 6806 { 6807 GV* gv; 6808 HV* stash; 6809 SV* const meth = *PL_stack_sp; 6810 6811 if (SvROK(meth)) { 6812 SV* const rmeth = SvRV(meth); 6813 if (SvTYPE(rmeth) == SVt_PVCV) { 6814 rpp_replace_1_1_NN(rmeth); 6815 return NORMAL; 6816 } 6817 } 6818 6819 stash = opmethod_stash(meth); 6820 6821 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK); 6822 assert(gv); 6823 6824 rpp_replace_1_1_NN(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv)); 6825 return NORMAL; 6826 } 6827 6828 #define METHOD_CHECK_CACHE(stash,cache,meth) \ 6829 const HE* const he = hv_fetch_ent(cache, meth, 0, 0); \ 6830 if (he) { \ 6831 gv = MUTABLE_GV(HeVAL(he)); \ 6832 if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) \ 6833 == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) \ 6834 { \ 6835 rpp_xpush_1(MUTABLE_SV(GvCV(gv))); \ 6836 return NORMAL; \ 6837 } \ 6838 } \ 6839 6840 PP(pp_method_named) 6841 { 6842 GV* gv; 6843 SV* const meth = cMETHOP_meth; 6844 HV* const stash = opmethod_stash(meth); 6845 6846 if (LIKELY(SvTYPE(stash) == SVt_PVHV)) { 6847 METHOD_CHECK_CACHE(stash, stash, meth); 6848 } 6849 6850 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK); 6851 assert(gv); 6852 6853 rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv)); 6854 return NORMAL; 6855 } 6856 6857 PP(pp_method_super) 6858 { 6859 GV* gv; 6860 HV* cache; 6861 SV* const meth = cMETHOP_meth; 6862 HV* const stash = CopSTASH(PL_curcop); 6863 /* Actually, SUPER doesn't need real object's (or class') stash at all, 6864 * as it uses CopSTASH. However, we must ensure that object(class) is 6865 * correct (this check is done by S_opmethod_stash) */ 6866 opmethod_stash(meth); 6867 6868 if ((cache = HvMROMETA(stash)->super)) { 6869 METHOD_CHECK_CACHE(stash, cache, meth); 6870 } 6871 6872 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER); 6873 assert(gv); 6874 6875 rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv)); 6876 return NORMAL; 6877 } 6878 6879 PP(pp_method_redir) 6880 { 6881 GV* gv; 6882 SV* const meth = cMETHOP_meth; 6883 HV* stash = gv_stashsv(cMETHOP_rclass, 0); 6884 opmethod_stash(meth); /* not used but needed for error checks */ 6885 6886 if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); } 6887 else stash = MUTABLE_HV(cMETHOP_rclass); 6888 6889 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK); 6890 assert(gv); 6891 6892 rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv)); 6893 return NORMAL; 6894 } 6895 6896 PP(pp_method_redir_super) 6897 { 6898 GV* gv; 6899 HV* cache; 6900 SV* const meth = cMETHOP_meth; 6901 HV* stash = gv_stashsv(cMETHOP_rclass, 0); 6902 opmethod_stash(meth); /* not used but needed for error checks */ 6903 6904 if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOP_rclass); 6905 else if ((cache = HvMROMETA(stash)->super)) { 6906 METHOD_CHECK_CACHE(stash, cache, meth); 6907 } 6908 6909 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER); 6910 assert(gv); 6911 6912 rpp_xpush_1(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv)); 6913 return NORMAL; 6914 } 6915 6916 /* 6917 * ex: set ts=8 sts=4 sw=4 et: 6918 */ 6919