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