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