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