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