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