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