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