1 /* pp_ctl.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 /* 12 * Now far ahead the Road has gone, 13 * And I must follow, if I can, 14 * Pursuing it with eager feet, 15 * Until it joins some larger way 16 * Where many paths and errands meet. 17 * And whither then? I cannot say. 18 * 19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] 20 */ 21 22 /* This file contains control-oriented pp ("push/pop") functions that 23 * execute the opcodes that make up a perl program. A typical pp function 24 * expects to find its arguments on the stack, and usually pushes its 25 * results onto the stack, hence the 'pp' terminology. Each OP structure 26 * contains a pointer to the relevant pp_foo() function. 27 * 28 * Control-oriented means things like pp_enteriter() and pp_next(), which 29 * alter the flow of control of the program. 30 */ 31 32 33 #include "EXTERN.h" 34 #define PERL_IN_PP_CTL_C 35 #include "perl.h" 36 37 #ifndef WORD_ALIGN 38 #define WORD_ALIGN sizeof(U32) 39 #endif 40 41 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) 42 43 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop)) 44 45 PP(pp_wantarray) 46 { 47 dVAR; 48 dSP; 49 I32 cxix; 50 EXTEND(SP, 1); 51 52 cxix = dopoptosub(cxstack_ix); 53 if (cxix < 0) 54 RETPUSHUNDEF; 55 56 switch (cxstack[cxix].blk_gimme) { 57 case G_ARRAY: 58 RETPUSHYES; 59 case G_SCALAR: 60 RETPUSHNO; 61 default: 62 RETPUSHUNDEF; 63 } 64 } 65 66 PP(pp_regcreset) 67 { 68 dVAR; 69 /* XXXX Should store the old value to allow for tie/overload - and 70 restore in regcomp, where marked with XXXX. */ 71 PL_reginterp_cnt = 0; 72 TAINT_NOT; 73 return NORMAL; 74 } 75 76 PP(pp_regcomp) 77 { 78 dVAR; 79 dSP; 80 register PMOP *pm = (PMOP*)cLOGOP->op_other; 81 SV *tmpstr; 82 REGEXP *re = NULL; 83 84 /* prevent recompiling under /o and ithreads. */ 85 #if defined(USE_ITHREADS) 86 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) { 87 if (PL_op->op_flags & OPf_STACKED) { 88 dMARK; 89 SP = MARK; 90 } 91 else 92 (void)POPs; 93 RETURN; 94 } 95 #endif 96 97 #define tryAMAGICregexp(rx) \ 98 STMT_START { \ 99 if (SvROK(rx) && SvAMAGIC(rx)) { \ 100 SV *sv = AMG_CALLun(rx, regexp); \ 101 if (sv) { \ 102 if (SvROK(sv)) \ 103 sv = SvRV(sv); \ 104 if (SvTYPE(sv) != SVt_REGEXP) \ 105 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \ 106 rx = sv; \ 107 } \ 108 } \ 109 } STMT_END 110 111 112 if (PL_op->op_flags & OPf_STACKED) { 113 /* multiple args; concatentate them */ 114 dMARK; dORIGMARK; 115 tmpstr = PAD_SV(ARGTARG); 116 sv_setpvs(tmpstr, ""); 117 while (++MARK <= SP) { 118 SV *msv = *MARK; 119 if (PL_amagic_generation) { 120 SV *sv; 121 122 tryAMAGICregexp(msv); 123 124 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) && 125 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign))) 126 { 127 sv_setsv(tmpstr, sv); 128 continue; 129 } 130 } 131 sv_catsv(tmpstr, msv); 132 } 133 SvSETMAGIC(tmpstr); 134 SP = ORIGMARK; 135 } 136 else { 137 tmpstr = POPs; 138 tryAMAGICregexp(tmpstr); 139 } 140 141 #undef tryAMAGICregexp 142 143 if (SvROK(tmpstr)) { 144 SV * const sv = SvRV(tmpstr); 145 if (SvTYPE(sv) == SVt_REGEXP) 146 re = (REGEXP*) sv; 147 } 148 else if (SvTYPE(tmpstr) == SVt_REGEXP) 149 re = (REGEXP*) tmpstr; 150 151 if (re) { 152 /* The match's LHS's get-magic might need to access this op's reg- 153 exp (as is sometimes the case with $'; see bug 70764). So we 154 must call get-magic now before we replace the regexp. Hopeful- 155 ly this hack can be replaced with the approach described at 156 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03 157 /msg122415.html some day. */ 158 if(pm->op_type == OP_MATCH) { 159 SV *lhs; 160 const bool was_tainted = PL_tainted; 161 if (pm->op_flags & OPf_STACKED) 162 lhs = TOPs; 163 else if (pm->op_private & OPpTARGET_MY) 164 lhs = PAD_SV(pm->op_targ); 165 else lhs = DEFSV; 166 SvGETMAGIC(lhs); 167 /* Restore the previous value of PL_tainted (which may have been 168 modified by get-magic), to avoid incorrectly setting the 169 RXf_TAINTED flag further down. */ 170 PL_tainted = was_tainted; 171 } 172 173 re = reg_temp_copy(NULL, re); 174 ReREFCNT_dec(PM_GETRE(pm)); 175 PM_SETRE(pm, re); 176 } 177 else { 178 STRLEN len; 179 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : ""; 180 re = PM_GETRE(pm); 181 assert (re != (REGEXP*) &PL_sv_undef); 182 183 /* Check against the last compiled regexp. */ 184 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len || 185 memNE(RX_PRECOMP(re), t, len)) 186 { 187 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL; 188 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME; 189 if (re) { 190 ReREFCNT_dec(re); 191 #ifdef USE_ITHREADS 192 PM_SETRE(pm, (REGEXP*) &PL_sv_undef); 193 #else 194 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */ 195 #endif 196 } else if (PL_curcop->cop_hints_hash) { 197 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0, 198 "regcomp", 7, 0, 0); 199 if (ptr && SvIOK(ptr) && SvIV(ptr)) 200 eng = INT2PTR(regexp_engine*,SvIV(ptr)); 201 } 202 203 if (PL_op->op_flags & OPf_SPECIAL) 204 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ 205 206 if (DO_UTF8(tmpstr)) { 207 assert (SvUTF8(tmpstr)); 208 } else if (SvUTF8(tmpstr)) { 209 /* Not doing UTF-8, despite what the SV says. Is this only if 210 we're trapped in use 'bytes'? */ 211 /* Make a copy of the octet sequence, but without the flag on, 212 as the compiler now honours the SvUTF8 flag on tmpstr. */ 213 STRLEN len; 214 const char *const p = SvPV(tmpstr, len); 215 tmpstr = newSVpvn_flags(p, len, SVs_TEMP); 216 } 217 218 if (eng) 219 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags)); 220 else 221 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags)); 222 223 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed 224 inside tie/overload accessors. */ 225 } 226 } 227 228 re = PM_GETRE(pm); 229 230 #ifndef INCOMPLETE_TAINTS 231 if (PL_tainting) { 232 if (PL_tainted) 233 RX_EXTFLAGS(re) |= RXf_TAINTED; 234 else 235 RX_EXTFLAGS(re) &= ~RXf_TAINTED; 236 } 237 #endif 238 239 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) 240 pm = PL_curpm; 241 242 243 #if !defined(USE_ITHREADS) 244 /* can't change the optree at runtime either */ 245 /* PMf_KEEP is handled differently under threads to avoid these problems */ 246 if (pm->op_pmflags & PMf_KEEP) { 247 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ 248 cLOGOP->op_first->op_next = PL_op->op_next; 249 } 250 #endif 251 RETURN; 252 } 253 254 PP(pp_substcont) 255 { 256 dVAR; 257 dSP; 258 register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; 259 register PMOP * const pm = (PMOP*) cLOGOP->op_other; 260 register SV * const dstr = cx->sb_dstr; 261 register char *s = cx->sb_s; 262 register char *m = cx->sb_m; 263 char *orig = cx->sb_orig; 264 register REGEXP * const rx = cx->sb_rx; 265 SV *nsv = NULL; 266 REGEXP *old = PM_GETRE(pm); 267 if(old != rx) { 268 if(old) 269 ReREFCNT_dec(old); 270 PM_SETRE(pm,ReREFCNT_inc(rx)); 271 } 272 273 rxres_restore(&cx->sb_rxres, rx); 274 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ)); 275 276 if (cx->sb_iters++) { 277 const I32 saviters = cx->sb_iters; 278 if (cx->sb_iters > cx->sb_maxiters) 279 DIE(aTHX_ "Substitution loop"); 280 281 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) 282 cx->sb_rxtainted |= 2; 283 sv_catsv(dstr, POPs); 284 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */ 285 s -= RX_GOFS(rx); 286 287 /* Are we done */ 288 if (CxONCE(cx) || s < orig || 289 !CALLREGEXEC(rx, s, cx->sb_strend, orig, 290 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL, 291 ((cx->sb_rflags & REXEC_COPY_STR) 292 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) 293 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST)))) 294 { 295 SV * const targ = cx->sb_targ; 296 297 assert(cx->sb_strend >= s); 298 if(cx->sb_strend > s) { 299 if (DO_UTF8(dstr) && !SvUTF8(targ)) 300 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); 301 else 302 sv_catpvn(dstr, s, cx->sb_strend - s); 303 } 304 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); 305 306 #ifdef PERL_OLD_COPY_ON_WRITE 307 if (SvIsCOW(targ)) { 308 sv_force_normal_flags(targ, SV_COW_DROP_PV); 309 } else 310 #endif 311 { 312 SvPV_free(targ); 313 } 314 SvPV_set(targ, SvPVX(dstr)); 315 SvCUR_set(targ, SvCUR(dstr)); 316 SvLEN_set(targ, SvLEN(dstr)); 317 if (DO_UTF8(dstr)) 318 SvUTF8_on(targ); 319 SvPV_set(dstr, NULL); 320 321 TAINT_IF(cx->sb_rxtainted & 1); 322 mPUSHi(saviters - 1); 323 324 (void)SvPOK_only_UTF8(targ); 325 TAINT_IF(cx->sb_rxtainted); 326 SvSETMAGIC(targ); 327 SvTAINT(targ); 328 329 LEAVE_SCOPE(cx->sb_oldsave); 330 POPSUBST(cx); 331 RETURNOP(pm->op_next); 332 } 333 cx->sb_iters = saviters; 334 } 335 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) { 336 m = s; 337 s = orig; 338 cx->sb_orig = orig = RX_SUBBEG(rx); 339 s = orig + (m - s); 340 cx->sb_strend = s + (cx->sb_strend - m); 341 } 342 cx->sb_m = m = RX_OFFS(rx)[0].start + orig; 343 if (m > s) { 344 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) 345 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv); 346 else 347 sv_catpvn(dstr, s, m-s); 348 } 349 cx->sb_s = RX_OFFS(rx)[0].end + orig; 350 { /* Update the pos() information. */ 351 SV * const sv = cx->sb_targ; 352 MAGIC *mg; 353 SvUPGRADE(sv, SVt_PVMG); 354 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { 355 #ifdef PERL_OLD_COPY_ON_WRITE 356 if (SvIsCOW(sv)) 357 sv_force_normal_flags(sv, 0); 358 #endif 359 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob, 360 NULL, 0); 361 } 362 mg->mg_len = m - orig; 363 } 364 if (old != rx) 365 (void)ReREFCNT_inc(rx); 366 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); 367 rxres_save(&cx->sb_rxres, rx); 368 RETURNOP(pm->op_pmstashstartu.op_pmreplstart); 369 } 370 371 void 372 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) 373 { 374 UV *p = (UV*)*rsp; 375 U32 i; 376 377 PERL_ARGS_ASSERT_RXRES_SAVE; 378 PERL_UNUSED_CONTEXT; 379 380 if (!p || p[1] < RX_NPARENS(rx)) { 381 #ifdef PERL_OLD_COPY_ON_WRITE 382 i = 7 + RX_NPARENS(rx) * 2; 383 #else 384 i = 6 + RX_NPARENS(rx) * 2; 385 #endif 386 if (!p) 387 Newx(p, i, UV); 388 else 389 Renew(p, i, UV); 390 *rsp = (void*)p; 391 } 392 393 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL); 394 RX_MATCH_COPIED_off(rx); 395 396 #ifdef PERL_OLD_COPY_ON_WRITE 397 *p++ = PTR2UV(RX_SAVED_COPY(rx)); 398 RX_SAVED_COPY(rx) = NULL; 399 #endif 400 401 *p++ = RX_NPARENS(rx); 402 403 *p++ = PTR2UV(RX_SUBBEG(rx)); 404 *p++ = (UV)RX_SUBLEN(rx); 405 for (i = 0; i <= RX_NPARENS(rx); ++i) { 406 *p++ = (UV)RX_OFFS(rx)[i].start; 407 *p++ = (UV)RX_OFFS(rx)[i].end; 408 } 409 } 410 411 static void 412 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx) 413 { 414 UV *p = (UV*)*rsp; 415 U32 i; 416 417 PERL_ARGS_ASSERT_RXRES_RESTORE; 418 PERL_UNUSED_CONTEXT; 419 420 RX_MATCH_COPY_FREE(rx); 421 RX_MATCH_COPIED_set(rx, *p); 422 *p++ = 0; 423 424 #ifdef PERL_OLD_COPY_ON_WRITE 425 if (RX_SAVED_COPY(rx)) 426 SvREFCNT_dec (RX_SAVED_COPY(rx)); 427 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p); 428 *p++ = 0; 429 #endif 430 431 RX_NPARENS(rx) = *p++; 432 433 RX_SUBBEG(rx) = INT2PTR(char*,*p++); 434 RX_SUBLEN(rx) = (I32)(*p++); 435 for (i = 0; i <= RX_NPARENS(rx); ++i) { 436 RX_OFFS(rx)[i].start = (I32)(*p++); 437 RX_OFFS(rx)[i].end = (I32)(*p++); 438 } 439 } 440 441 static void 442 S_rxres_free(pTHX_ void **rsp) 443 { 444 UV * const p = (UV*)*rsp; 445 446 PERL_ARGS_ASSERT_RXRES_FREE; 447 PERL_UNUSED_CONTEXT; 448 449 if (p) { 450 #ifdef PERL_POISON 451 void *tmp = INT2PTR(char*,*p); 452 Safefree(tmp); 453 if (*p) 454 PoisonFree(*p, 1, sizeof(*p)); 455 #else 456 Safefree(INT2PTR(char*,*p)); 457 #endif 458 #ifdef PERL_OLD_COPY_ON_WRITE 459 if (p[1]) { 460 SvREFCNT_dec (INT2PTR(SV*,p[1])); 461 } 462 #endif 463 Safefree(p); 464 *rsp = NULL; 465 } 466 } 467 468 PP(pp_formline) 469 { 470 dVAR; dSP; dMARK; dORIGMARK; 471 register SV * const tmpForm = *++MARK; 472 register U32 *fpc; 473 register char *t; 474 const char *f; 475 register I32 arg; 476 register SV *sv = NULL; 477 const char *item = NULL; 478 I32 itemsize = 0; 479 I32 fieldsize = 0; 480 I32 lines = 0; 481 bool chopspace = (strchr(PL_chopset, ' ') != NULL); 482 const char *chophere = NULL; 483 char *linemark = NULL; 484 NV value; 485 bool gotsome = FALSE; 486 STRLEN len; 487 const STRLEN fudge = SvPOK(tmpForm) 488 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0; 489 bool item_is_utf8 = FALSE; 490 bool targ_is_utf8 = FALSE; 491 SV * nsv = NULL; 492 OP * parseres = NULL; 493 const char *fmt; 494 495 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { 496 if (SvREADONLY(tmpForm)) { 497 SvREADONLY_off(tmpForm); 498 parseres = doparseform(tmpForm); 499 SvREADONLY_on(tmpForm); 500 } 501 else 502 parseres = doparseform(tmpForm); 503 if (parseres) 504 return parseres; 505 } 506 SvPV_force(PL_formtarget, len); 507 if (DO_UTF8(PL_formtarget)) 508 targ_is_utf8 = TRUE; 509 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */ 510 t += len; 511 f = SvPV_const(tmpForm, len); 512 /* need to jump to the next word */ 513 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN); 514 515 for (;;) { 516 DEBUG_f( { 517 const char *name = "???"; 518 arg = -1; 519 switch (*fpc) { 520 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break; 521 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break; 522 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break; 523 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break; 524 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break; 525 526 case FF_CHECKNL: name = "CHECKNL"; break; 527 case FF_CHECKCHOP: name = "CHECKCHOP"; break; 528 case FF_SPACE: name = "SPACE"; break; 529 case FF_HALFSPACE: name = "HALFSPACE"; break; 530 case FF_ITEM: name = "ITEM"; break; 531 case FF_CHOP: name = "CHOP"; break; 532 case FF_LINEGLOB: name = "LINEGLOB"; break; 533 case FF_NEWLINE: name = "NEWLINE"; break; 534 case FF_MORE: name = "MORE"; break; 535 case FF_LINEMARK: name = "LINEMARK"; break; 536 case FF_END: name = "END"; break; 537 case FF_0DECIMAL: name = "0DECIMAL"; break; 538 case FF_LINESNGL: name = "LINESNGL"; break; 539 } 540 if (arg >= 0) 541 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg); 542 else 543 PerlIO_printf(Perl_debug_log, "%-16s\n", name); 544 } ); 545 switch (*fpc++) { 546 case FF_LINEMARK: 547 linemark = t; 548 lines++; 549 gotsome = FALSE; 550 break; 551 552 case FF_LITERAL: 553 arg = *fpc++; 554 if (targ_is_utf8 && !SvUTF8(tmpForm)) { 555 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 556 *t = '\0'; 557 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv); 558 t = SvEND(PL_formtarget); 559 f += arg; 560 break; 561 } 562 if (!targ_is_utf8 && DO_UTF8(tmpForm)) { 563 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 564 *t = '\0'; 565 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1); 566 t = SvEND(PL_formtarget); 567 targ_is_utf8 = TRUE; 568 } 569 while (arg--) 570 *t++ = *f++; 571 break; 572 573 case FF_SKIP: 574 f += *fpc++; 575 break; 576 577 case FF_FETCH: 578 arg = *fpc++; 579 f += arg; 580 fieldsize = arg; 581 582 if (MARK < SP) 583 sv = *++MARK; 584 else { 585 sv = &PL_sv_no; 586 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments"); 587 } 588 break; 589 590 case FF_CHECKNL: 591 { 592 const char *send; 593 const char *s = item = SvPV_const(sv, len); 594 itemsize = len; 595 if (DO_UTF8(sv)) { 596 itemsize = sv_len_utf8(sv); 597 if (itemsize != (I32)len) { 598 I32 itembytes; 599 if (itemsize > fieldsize) { 600 itemsize = fieldsize; 601 itembytes = itemsize; 602 sv_pos_u2b(sv, &itembytes, 0); 603 } 604 else 605 itembytes = len; 606 send = chophere = s + itembytes; 607 while (s < send) { 608 if (*s & ~31) 609 gotsome = TRUE; 610 else if (*s == '\n') 611 break; 612 s++; 613 } 614 item_is_utf8 = TRUE; 615 itemsize = s - item; 616 sv_pos_b2u(sv, &itemsize); 617 break; 618 } 619 } 620 item_is_utf8 = FALSE; 621 if (itemsize > fieldsize) 622 itemsize = fieldsize; 623 send = chophere = s + itemsize; 624 while (s < send) { 625 if (*s & ~31) 626 gotsome = TRUE; 627 else if (*s == '\n') 628 break; 629 s++; 630 } 631 itemsize = s - item; 632 break; 633 } 634 635 case FF_CHECKCHOP: 636 { 637 const char *s = item = SvPV_const(sv, len); 638 itemsize = len; 639 if (DO_UTF8(sv)) { 640 itemsize = sv_len_utf8(sv); 641 if (itemsize != (I32)len) { 642 I32 itembytes; 643 if (itemsize <= fieldsize) { 644 const char *send = chophere = s + itemsize; 645 while (s < send) { 646 if (*s == '\r') { 647 itemsize = s - item; 648 chophere = s; 649 break; 650 } 651 if (*s++ & ~31) 652 gotsome = TRUE; 653 } 654 } 655 else { 656 const char *send; 657 itemsize = fieldsize; 658 itembytes = itemsize; 659 sv_pos_u2b(sv, &itembytes, 0); 660 send = chophere = s + itembytes; 661 while (s < send || (s == send && isSPACE(*s))) { 662 if (isSPACE(*s)) { 663 if (chopspace) 664 chophere = s; 665 if (*s == '\r') 666 break; 667 } 668 else { 669 if (*s & ~31) 670 gotsome = TRUE; 671 if (strchr(PL_chopset, *s)) 672 chophere = s + 1; 673 } 674 s++; 675 } 676 itemsize = chophere - item; 677 sv_pos_b2u(sv, &itemsize); 678 } 679 item_is_utf8 = TRUE; 680 break; 681 } 682 } 683 item_is_utf8 = FALSE; 684 if (itemsize <= fieldsize) { 685 const char *const send = chophere = s + itemsize; 686 while (s < send) { 687 if (*s == '\r') { 688 itemsize = s - item; 689 chophere = s; 690 break; 691 } 692 if (*s++ & ~31) 693 gotsome = TRUE; 694 } 695 } 696 else { 697 const char *send; 698 itemsize = fieldsize; 699 send = chophere = s + itemsize; 700 while (s < send || (s == send && isSPACE(*s))) { 701 if (isSPACE(*s)) { 702 if (chopspace) 703 chophere = s; 704 if (*s == '\r') 705 break; 706 } 707 else { 708 if (*s & ~31) 709 gotsome = TRUE; 710 if (strchr(PL_chopset, *s)) 711 chophere = s + 1; 712 } 713 s++; 714 } 715 itemsize = chophere - item; 716 } 717 break; 718 } 719 720 case FF_SPACE: 721 arg = fieldsize - itemsize; 722 if (arg) { 723 fieldsize -= arg; 724 while (arg-- > 0) 725 *t++ = ' '; 726 } 727 break; 728 729 case FF_HALFSPACE: 730 arg = fieldsize - itemsize; 731 if (arg) { 732 arg /= 2; 733 fieldsize -= arg; 734 while (arg-- > 0) 735 *t++ = ' '; 736 } 737 break; 738 739 case FF_ITEM: 740 { 741 const char *s = item; 742 arg = itemsize; 743 if (item_is_utf8) { 744 if (!targ_is_utf8) { 745 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 746 *t = '\0'; 747 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, 748 fudge + 1); 749 t = SvEND(PL_formtarget); 750 targ_is_utf8 = TRUE; 751 } 752 while (arg--) { 753 if (UTF8_IS_CONTINUED(*s)) { 754 STRLEN skip = UTF8SKIP(s); 755 switch (skip) { 756 default: 757 Move(s,t,skip,char); 758 s += skip; 759 t += skip; 760 break; 761 case 7: *t++ = *s++; 762 case 6: *t++ = *s++; 763 case 5: *t++ = *s++; 764 case 4: *t++ = *s++; 765 case 3: *t++ = *s++; 766 case 2: *t++ = *s++; 767 case 1: *t++ = *s++; 768 } 769 } 770 else { 771 if ( !((*t++ = *s++) & ~31) ) 772 t[-1] = ' '; 773 } 774 } 775 break; 776 } 777 if (targ_is_utf8 && !item_is_utf8) { 778 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 779 *t = '\0'; 780 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv); 781 for (; t < SvEND(PL_formtarget); t++) { 782 #ifdef EBCDIC 783 const int ch = *t; 784 if (iscntrl(ch)) 785 #else 786 if (!(*t & ~31)) 787 #endif 788 *t = ' '; 789 } 790 break; 791 } 792 while (arg--) { 793 #ifdef EBCDIC 794 const int ch = *t++ = *s++; 795 if (iscntrl(ch)) 796 #else 797 if ( !((*t++ = *s++) & ~31) ) 798 #endif 799 t[-1] = ' '; 800 } 801 break; 802 } 803 804 case FF_CHOP: 805 { 806 const char *s = chophere; 807 if (chopspace) { 808 while (isSPACE(*s)) 809 s++; 810 } 811 sv_chop(sv,s); 812 SvSETMAGIC(sv); 813 break; 814 } 815 816 case FF_LINESNGL: 817 chopspace = 0; 818 case FF_LINEGLOB: 819 { 820 const bool oneline = fpc[-1] == FF_LINESNGL; 821 const char *s = item = SvPV_const(sv, len); 822 item_is_utf8 = DO_UTF8(sv); 823 itemsize = len; 824 if (itemsize) { 825 STRLEN to_copy = itemsize; 826 const char *const send = s + len; 827 const U8 *source = (const U8 *) s; 828 U8 *tmp = NULL; 829 830 gotsome = TRUE; 831 chophere = s + itemsize; 832 while (s < send) { 833 if (*s++ == '\n') { 834 if (oneline) { 835 to_copy = s - SvPVX_const(sv) - 1; 836 chophere = s; 837 break; 838 } else { 839 if (s == send) { 840 itemsize--; 841 to_copy--; 842 } else 843 lines++; 844 } 845 } 846 } 847 if (targ_is_utf8 && !item_is_utf8) { 848 source = tmp = bytes_to_utf8(source, &to_copy); 849 SvCUR_set(PL_formtarget, 850 t - SvPVX_const(PL_formtarget)); 851 } else { 852 if (item_is_utf8 && !targ_is_utf8) { 853 /* Upgrade targ to UTF8, and then we reduce it to 854 a problem we have a simple solution for. */ 855 SvCUR_set(PL_formtarget, 856 t - SvPVX_const(PL_formtarget)); 857 targ_is_utf8 = TRUE; 858 /* Don't need get magic. */ 859 sv_utf8_upgrade_nomg(PL_formtarget); 860 } else { 861 SvCUR_set(PL_formtarget, 862 t - SvPVX_const(PL_formtarget)); 863 } 864 865 /* Easy. They agree. */ 866 assert (item_is_utf8 == targ_is_utf8); 867 } 868 SvGROW(PL_formtarget, 869 SvCUR(PL_formtarget) + to_copy + fudge + 1); 870 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); 871 872 Copy(source, t, to_copy, char); 873 t += to_copy; 874 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy); 875 if (item_is_utf8) { 876 if (SvGMAGICAL(sv)) { 877 /* Mustn't call sv_pos_b2u() as it does a second 878 mg_get(). Is this a bug? Do we need a _flags() 879 variant? */ 880 itemsize = utf8_length(source, source + itemsize); 881 } else { 882 sv_pos_b2u(sv, &itemsize); 883 } 884 assert(!tmp); 885 } else if (tmp) { 886 Safefree(tmp); 887 } 888 } 889 break; 890 } 891 892 case FF_0DECIMAL: 893 arg = *fpc++; 894 #if defined(USE_LONG_DOUBLE) 895 fmt = (const char *) 896 ((arg & 256) ? 897 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl); 898 #else 899 fmt = (const char *) 900 ((arg & 256) ? 901 "%#0*.*f" : "%0*.*f"); 902 #endif 903 goto ff_dec; 904 case FF_DECIMAL: 905 arg = *fpc++; 906 #if defined(USE_LONG_DOUBLE) 907 fmt = (const char *) 908 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl); 909 #else 910 fmt = (const char *) 911 ((arg & 256) ? "%#*.*f" : "%*.*f"); 912 #endif 913 ff_dec: 914 /* If the field is marked with ^ and the value is undefined, 915 blank it out. */ 916 if ((arg & 512) && !SvOK(sv)) { 917 arg = fieldsize; 918 while (arg--) 919 *t++ = ' '; 920 break; 921 } 922 gotsome = TRUE; 923 value = SvNV(sv); 924 /* overflow evidence */ 925 if (num_overflow(value, fieldsize, arg)) { 926 arg = fieldsize; 927 while (arg--) 928 *t++ = '#'; 929 break; 930 } 931 /* Formats aren't yet marked for locales, so assume "yes". */ 932 { 933 STORE_NUMERIC_STANDARD_SET_LOCAL(); 934 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value); 935 RESTORE_NUMERIC_STANDARD(); 936 } 937 t += fieldsize; 938 break; 939 940 case FF_NEWLINE: 941 f++; 942 while (t-- > linemark && *t == ' ') ; 943 t++; 944 *t++ = '\n'; 945 break; 946 947 case FF_BLANK: 948 arg = *fpc++; 949 if (gotsome) { 950 if (arg) { /* repeat until fields exhausted? */ 951 *t = '\0'; 952 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 953 lines += FmLINES(PL_formtarget); 954 if (targ_is_utf8) 955 SvUTF8_on(PL_formtarget); 956 FmLINES(PL_formtarget) = lines; 957 SP = ORIGMARK; 958 RETURNOP(cLISTOP->op_first); 959 } 960 } 961 else { 962 t = linemark; 963 lines--; 964 } 965 break; 966 967 case FF_MORE: 968 { 969 const char *s = chophere; 970 const char *send = item + len; 971 if (chopspace) { 972 while (isSPACE(*s) && (s < send)) 973 s++; 974 } 975 if (s < send) { 976 char *s1; 977 arg = fieldsize - itemsize; 978 if (arg) { 979 fieldsize -= arg; 980 while (arg-- > 0) 981 *t++ = ' '; 982 } 983 s1 = t - 3; 984 if (strnEQ(s1," ",3)) { 985 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1])) 986 s1--; 987 } 988 *s1++ = '.'; 989 *s1++ = '.'; 990 *s1++ = '.'; 991 } 992 break; 993 } 994 case FF_END: 995 *t = '\0'; 996 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 997 if (targ_is_utf8) 998 SvUTF8_on(PL_formtarget); 999 FmLINES(PL_formtarget) += lines; 1000 SP = ORIGMARK; 1001 RETPUSHYES; 1002 } 1003 } 1004 } 1005 1006 PP(pp_grepstart) 1007 { 1008 dVAR; dSP; 1009 SV *src; 1010 1011 if (PL_stack_base + *PL_markstack_ptr == SP) { 1012 (void)POPMARK; 1013 if (GIMME_V == G_SCALAR) 1014 mXPUSHi(0); 1015 RETURNOP(PL_op->op_next->op_next); 1016 } 1017 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; 1018 pp_pushmark(); /* push dst */ 1019 pp_pushmark(); /* push src */ 1020 ENTER_with_name("grep"); /* enter outer scope */ 1021 1022 SAVETMPS; 1023 if (PL_op->op_private & OPpGREP_LEX) 1024 SAVESPTR(PAD_SVl(PL_op->op_targ)); 1025 else 1026 SAVE_DEFSV; 1027 ENTER_with_name("grep_item"); /* enter inner scope */ 1028 SAVEVPTR(PL_curpm); 1029 1030 src = PL_stack_base[*PL_markstack_ptr]; 1031 SvTEMP_off(src); 1032 if (PL_op->op_private & OPpGREP_LEX) 1033 PAD_SVl(PL_op->op_targ) = src; 1034 else 1035 DEFSV_set(src); 1036 1037 PUTBACK; 1038 if (PL_op->op_type == OP_MAPSTART) 1039 pp_pushmark(); /* push top */ 1040 return ((LOGOP*)PL_op->op_next)->op_other; 1041 } 1042 1043 PP(pp_mapwhile) 1044 { 1045 dVAR; dSP; 1046 const I32 gimme = GIMME_V; 1047 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ 1048 I32 count; 1049 I32 shift; 1050 SV** src; 1051 SV** dst; 1052 1053 /* first, move source pointer to the next item in the source list */ 1054 ++PL_markstack_ptr[-1]; 1055 1056 /* if there are new items, push them into the destination list */ 1057 if (items && gimme != G_VOID) { 1058 /* might need to make room back there first */ 1059 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) { 1060 /* XXX this implementation is very pessimal because the stack 1061 * is repeatedly extended for every set of items. Is possible 1062 * to do this without any stack extension or copying at all 1063 * by maintaining a separate list over which the map iterates 1064 * (like foreach does). --gsar */ 1065 1066 /* everything in the stack after the destination list moves 1067 * towards the end the stack by the amount of room needed */ 1068 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]); 1069 1070 /* items to shift up (accounting for the moved source pointer) */ 1071 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1); 1072 1073 /* This optimization is by Ben Tilly and it does 1074 * things differently from what Sarathy (gsar) 1075 * is describing. The downside of this optimization is 1076 * that leaves "holes" (uninitialized and hopefully unused areas) 1077 * to the Perl stack, but on the other hand this 1078 * shouldn't be a problem. If Sarathy's idea gets 1079 * implemented, this optimization should become 1080 * irrelevant. --jhi */ 1081 if (shift < count) 1082 shift = count; /* Avoid shifting too often --Ben Tilly */ 1083 1084 EXTEND(SP,shift); 1085 src = SP; 1086 dst = (SP += shift); 1087 PL_markstack_ptr[-1] += shift; 1088 *PL_markstack_ptr += shift; 1089 while (count--) 1090 *dst-- = *src--; 1091 } 1092 /* copy the new items down to the destination list */ 1093 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; 1094 if (gimme == G_ARRAY) { 1095 while (items-- > 0) 1096 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); 1097 } 1098 else { 1099 /* scalar context: we don't care about which values map returns 1100 * (we use undef here). And so we certainly don't want to do mortal 1101 * copies of meaningless values. */ 1102 while (items-- > 0) { 1103 (void)POPs; 1104 *dst-- = &PL_sv_undef; 1105 } 1106 } 1107 } 1108 LEAVE_with_name("grep_item"); /* exit inner scope */ 1109 1110 /* All done yet? */ 1111 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { 1112 1113 (void)POPMARK; /* pop top */ 1114 LEAVE_with_name("grep"); /* exit outer scope */ 1115 (void)POPMARK; /* pop src */ 1116 items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; 1117 (void)POPMARK; /* pop dst */ 1118 SP = PL_stack_base + POPMARK; /* pop original mark */ 1119 if (gimme == G_SCALAR) { 1120 if (PL_op->op_private & OPpGREP_LEX) { 1121 SV* sv = sv_newmortal(); 1122 sv_setiv(sv, items); 1123 PUSHs(sv); 1124 } 1125 else { 1126 dTARGET; 1127 XPUSHi(items); 1128 } 1129 } 1130 else if (gimme == G_ARRAY) 1131 SP += items; 1132 RETURN; 1133 } 1134 else { 1135 SV *src; 1136 1137 ENTER_with_name("grep_item"); /* enter inner scope */ 1138 SAVEVPTR(PL_curpm); 1139 1140 /* set $_ to the new source item */ 1141 src = PL_stack_base[PL_markstack_ptr[-1]]; 1142 SvTEMP_off(src); 1143 if (PL_op->op_private & OPpGREP_LEX) 1144 PAD_SVl(PL_op->op_targ) = src; 1145 else 1146 DEFSV_set(src); 1147 1148 RETURNOP(cLOGOP->op_other); 1149 } 1150 } 1151 1152 /* Range stuff. */ 1153 1154 PP(pp_range) 1155 { 1156 dVAR; 1157 if (GIMME == G_ARRAY) 1158 return NORMAL; 1159 if (SvTRUEx(PAD_SV(PL_op->op_targ))) 1160 return cLOGOP->op_other; 1161 else 1162 return NORMAL; 1163 } 1164 1165 PP(pp_flip) 1166 { 1167 dVAR; 1168 dSP; 1169 1170 if (GIMME == G_ARRAY) { 1171 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); 1172 } 1173 else { 1174 dTOPss; 1175 SV * const targ = PAD_SV(PL_op->op_targ); 1176 int flip = 0; 1177 1178 if (PL_op->op_private & OPpFLIP_LINENUM) { 1179 if (GvIO(PL_last_in_gv)) { 1180 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); 1181 } 1182 else { 1183 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV); 1184 if (gv && GvSV(gv)) 1185 flip = SvIV(sv) == SvIV(GvSV(gv)); 1186 } 1187 } else { 1188 flip = SvTRUE(sv); 1189 } 1190 if (flip) { 1191 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); 1192 if (PL_op->op_flags & OPf_SPECIAL) { 1193 sv_setiv(targ, 1); 1194 SETs(targ); 1195 RETURN; 1196 } 1197 else { 1198 sv_setiv(targ, 0); 1199 SP--; 1200 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); 1201 } 1202 } 1203 sv_setpvs(TARG, ""); 1204 SETs(targ); 1205 RETURN; 1206 } 1207 } 1208 1209 /* This code tries to decide if "$left .. $right" should use the 1210 magical string increment, or if the range is numeric (we make 1211 an exception for .."0" [#18165]). AMS 20021031. */ 1212 1213 #define RANGE_IS_NUMERIC(left,right) ( \ 1214 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \ 1215 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \ 1216 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \ 1217 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \ 1218 && (!SvOK(right) || looks_like_number(right)))) 1219 1220 PP(pp_flop) 1221 { 1222 dVAR; dSP; 1223 1224 if (GIMME == G_ARRAY) { 1225 dPOPPOPssrl; 1226 1227 SvGETMAGIC(left); 1228 SvGETMAGIC(right); 1229 1230 if (RANGE_IS_NUMERIC(left,right)) { 1231 register IV i, j; 1232 IV max; 1233 if ((SvOK(left) && SvNV(left) < IV_MIN) || 1234 (SvOK(right) && SvNV(right) > IV_MAX)) 1235 DIE(aTHX_ "Range iterator outside integer range"); 1236 i = SvIV(left); 1237 max = SvIV(right); 1238 if (max >= i) { 1239 j = max - i + 1; 1240 EXTEND_MORTAL(j); 1241 EXTEND(SP, j); 1242 } 1243 else 1244 j = 0; 1245 while (j--) { 1246 SV * const sv = sv_2mortal(newSViv(i++)); 1247 PUSHs(sv); 1248 } 1249 } 1250 else { 1251 SV * const final = sv_mortalcopy(right); 1252 STRLEN len; 1253 const char * const tmps = SvPV_const(final, len); 1254 1255 SV *sv = sv_mortalcopy(left); 1256 SvPV_force_nolen(sv); 1257 while (!SvNIOKp(sv) && SvCUR(sv) <= len) { 1258 XPUSHs(sv); 1259 if (strEQ(SvPVX_const(sv),tmps)) 1260 break; 1261 sv = sv_2mortal(newSVsv(sv)); 1262 sv_inc(sv); 1263 } 1264 } 1265 } 1266 else { 1267 dTOPss; 1268 SV * const targ = PAD_SV(cUNOP->op_first->op_targ); 1269 int flop = 0; 1270 sv_inc(targ); 1271 1272 if (PL_op->op_private & OPpFLIP_LINENUM) { 1273 if (GvIO(PL_last_in_gv)) { 1274 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); 1275 } 1276 else { 1277 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV); 1278 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv)); 1279 } 1280 } 1281 else { 1282 flop = SvTRUE(sv); 1283 } 1284 1285 if (flop) { 1286 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); 1287 sv_catpvs(targ, "E0"); 1288 } 1289 SETs(targ); 1290 } 1291 1292 RETURN; 1293 } 1294 1295 /* Control. */ 1296 1297 static const char * const context_name[] = { 1298 "pseudo-block", 1299 NULL, /* CXt_WHEN never actually needs "block" */ 1300 NULL, /* CXt_BLOCK never actually needs "block" */ 1301 NULL, /* CXt_GIVEN never actually needs "block" */ 1302 NULL, /* CXt_LOOP_FOR never actually needs "loop" */ 1303 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */ 1304 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */ 1305 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */ 1306 "subroutine", 1307 "format", 1308 "eval", 1309 "substitution", 1310 }; 1311 1312 STATIC I32 1313 S_dopoptolabel(pTHX_ const char *label) 1314 { 1315 dVAR; 1316 register I32 i; 1317 1318 PERL_ARGS_ASSERT_DOPOPTOLABEL; 1319 1320 for (i = cxstack_ix; i >= 0; i--) { 1321 register const PERL_CONTEXT * const cx = &cxstack[i]; 1322 switch (CxTYPE(cx)) { 1323 case CXt_SUBST: 1324 case CXt_SUB: 1325 case CXt_FORMAT: 1326 case CXt_EVAL: 1327 case CXt_NULL: 1328 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", 1329 context_name[CxTYPE(cx)], OP_NAME(PL_op)); 1330 if (CxTYPE(cx) == CXt_NULL) 1331 return -1; 1332 break; 1333 case CXt_LOOP_LAZYIV: 1334 case CXt_LOOP_LAZYSV: 1335 case CXt_LOOP_FOR: 1336 case CXt_LOOP_PLAIN: 1337 { 1338 const char *cx_label = CxLABEL(cx); 1339 if (!cx_label || strNE(label, cx_label) ) { 1340 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n", 1341 (long)i, cx_label)); 1342 continue; 1343 } 1344 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label)); 1345 return i; 1346 } 1347 } 1348 } 1349 return i; 1350 } 1351 1352 1353 1354 I32 1355 Perl_dowantarray(pTHX) 1356 { 1357 dVAR; 1358 const I32 gimme = block_gimme(); 1359 return (gimme == G_VOID) ? G_SCALAR : gimme; 1360 } 1361 1362 I32 1363 Perl_block_gimme(pTHX) 1364 { 1365 dVAR; 1366 const I32 cxix = dopoptosub(cxstack_ix); 1367 if (cxix < 0) 1368 return G_VOID; 1369 1370 switch (cxstack[cxix].blk_gimme) { 1371 case G_VOID: 1372 return G_VOID; 1373 case G_SCALAR: 1374 return G_SCALAR; 1375 case G_ARRAY: 1376 return G_ARRAY; 1377 default: 1378 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme); 1379 /* NOTREACHED */ 1380 return 0; 1381 } 1382 } 1383 1384 I32 1385 Perl_is_lvalue_sub(pTHX) 1386 { 1387 dVAR; 1388 const I32 cxix = dopoptosub(cxstack_ix); 1389 assert(cxix >= 0); /* We should only be called from inside subs */ 1390 1391 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv)) 1392 return CxLVAL(cxstack + cxix); 1393 else 1394 return 0; 1395 } 1396 1397 STATIC I32 1398 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) 1399 { 1400 dVAR; 1401 I32 i; 1402 1403 PERL_ARGS_ASSERT_DOPOPTOSUB_AT; 1404 1405 for (i = startingblock; i >= 0; i--) { 1406 register const PERL_CONTEXT * const cx = &cxstk[i]; 1407 switch (CxTYPE(cx)) { 1408 default: 1409 continue; 1410 case CXt_EVAL: 1411 case CXt_SUB: 1412 case CXt_FORMAT: 1413 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i)); 1414 return i; 1415 } 1416 } 1417 return i; 1418 } 1419 1420 STATIC I32 1421 S_dopoptoeval(pTHX_ I32 startingblock) 1422 { 1423 dVAR; 1424 I32 i; 1425 for (i = startingblock; i >= 0; i--) { 1426 register const PERL_CONTEXT *cx = &cxstack[i]; 1427 switch (CxTYPE(cx)) { 1428 default: 1429 continue; 1430 case CXt_EVAL: 1431 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i)); 1432 return i; 1433 } 1434 } 1435 return i; 1436 } 1437 1438 STATIC I32 1439 S_dopoptoloop(pTHX_ I32 startingblock) 1440 { 1441 dVAR; 1442 I32 i; 1443 for (i = startingblock; i >= 0; i--) { 1444 register const PERL_CONTEXT * const cx = &cxstack[i]; 1445 switch (CxTYPE(cx)) { 1446 case CXt_SUBST: 1447 case CXt_SUB: 1448 case CXt_FORMAT: 1449 case CXt_EVAL: 1450 case CXt_NULL: 1451 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", 1452 context_name[CxTYPE(cx)], OP_NAME(PL_op)); 1453 if ((CxTYPE(cx)) == CXt_NULL) 1454 return -1; 1455 break; 1456 case CXt_LOOP_LAZYIV: 1457 case CXt_LOOP_LAZYSV: 1458 case CXt_LOOP_FOR: 1459 case CXt_LOOP_PLAIN: 1460 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); 1461 return i; 1462 } 1463 } 1464 return i; 1465 } 1466 1467 STATIC I32 1468 S_dopoptogiven(pTHX_ I32 startingblock) 1469 { 1470 dVAR; 1471 I32 i; 1472 for (i = startingblock; i >= 0; i--) { 1473 register const PERL_CONTEXT *cx = &cxstack[i]; 1474 switch (CxTYPE(cx)) { 1475 default: 1476 continue; 1477 case CXt_GIVEN: 1478 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i)); 1479 return i; 1480 case CXt_LOOP_PLAIN: 1481 assert(!CxFOREACHDEF(cx)); 1482 break; 1483 case CXt_LOOP_LAZYIV: 1484 case CXt_LOOP_LAZYSV: 1485 case CXt_LOOP_FOR: 1486 if (CxFOREACHDEF(cx)) { 1487 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i)); 1488 return i; 1489 } 1490 } 1491 } 1492 return i; 1493 } 1494 1495 STATIC I32 1496 S_dopoptowhen(pTHX_ I32 startingblock) 1497 { 1498 dVAR; 1499 I32 i; 1500 for (i = startingblock; i >= 0; i--) { 1501 register const PERL_CONTEXT *cx = &cxstack[i]; 1502 switch (CxTYPE(cx)) { 1503 default: 1504 continue; 1505 case CXt_WHEN: 1506 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i)); 1507 return i; 1508 } 1509 } 1510 return i; 1511 } 1512 1513 void 1514 Perl_dounwind(pTHX_ I32 cxix) 1515 { 1516 dVAR; 1517 I32 optype; 1518 1519 while (cxstack_ix > cxix) { 1520 SV *sv; 1521 register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; 1522 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", 1523 (long) cxstack_ix, PL_block_type[CxTYPE(cx)])); 1524 /* Note: we don't need to restore the base context info till the end. */ 1525 switch (CxTYPE(cx)) { 1526 case CXt_SUBST: 1527 POPSUBST(cx); 1528 continue; /* not break */ 1529 case CXt_SUB: 1530 POPSUB(cx,sv); 1531 LEAVESUB(sv); 1532 break; 1533 case CXt_EVAL: 1534 POPEVAL(cx); 1535 break; 1536 case CXt_LOOP_LAZYIV: 1537 case CXt_LOOP_LAZYSV: 1538 case CXt_LOOP_FOR: 1539 case CXt_LOOP_PLAIN: 1540 POPLOOP(cx); 1541 break; 1542 case CXt_NULL: 1543 break; 1544 case CXt_FORMAT: 1545 POPFORMAT(cx); 1546 break; 1547 } 1548 cxstack_ix--; 1549 } 1550 PERL_UNUSED_VAR(optype); 1551 } 1552 1553 void 1554 Perl_qerror(pTHX_ SV *err) 1555 { 1556 dVAR; 1557 1558 PERL_ARGS_ASSERT_QERROR; 1559 1560 if (PL_in_eval) 1561 sv_catsv(ERRSV, err); 1562 else if (PL_errors) 1563 sv_catsv(PL_errors, err); 1564 else 1565 Perl_warn(aTHX_ "%"SVf, SVfARG(err)); 1566 if (PL_parser) 1567 ++PL_parser->error_count; 1568 } 1569 1570 void 1571 Perl_die_where(pTHX_ SV *msv) 1572 { 1573 dVAR; 1574 1575 if (PL_in_eval) { 1576 I32 cxix; 1577 I32 gimme; 1578 1579 if (msv) { 1580 if (PL_in_eval & EVAL_KEEPERR) { 1581 static const char prefix[] = "\t(in cleanup) "; 1582 SV * const err = ERRSV; 1583 const char *e = NULL; 1584 if (!SvPOK(err)) 1585 sv_setpvs(err,""); 1586 else if (SvCUR(err) >= sizeof(prefix)+SvCUR(msv)-1) { 1587 STRLEN len; 1588 STRLEN msglen; 1589 const char* message = SvPV_const(msv, msglen); 1590 e = SvPV_const(err, len); 1591 e += len - msglen; 1592 if (*e != *message || strNE(e,message)) 1593 e = NULL; 1594 } 1595 if (!e) { 1596 STRLEN start; 1597 SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv)); 1598 sv_catpvn(err, prefix, sizeof(prefix)-1); 1599 sv_catsv(err, msv); 1600 start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1; 1601 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s", 1602 SvPVX_const(err)+start); 1603 } 1604 } 1605 else { 1606 STRLEN msglen; 1607 const char* message = SvPV_const(msv, msglen); 1608 sv_setpvn(ERRSV, message, msglen); 1609 SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8; 1610 } 1611 } 1612 1613 while ((cxix = dopoptoeval(cxstack_ix)) < 0 1614 && PL_curstackinfo->si_prev) 1615 { 1616 dounwind(-1); 1617 POPSTACK; 1618 } 1619 1620 if (cxix >= 0) { 1621 I32 optype; 1622 SV *namesv; 1623 register PERL_CONTEXT *cx; 1624 SV **newsp; 1625 1626 if (cxix < cxstack_ix) 1627 dounwind(cxix); 1628 1629 POPBLOCK(cx,PL_curpm); 1630 if (CxTYPE(cx) != CXt_EVAL) { 1631 STRLEN msglen; 1632 const char* message = SvPVx_const( msv ? msv : ERRSV, msglen); 1633 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11); 1634 PerlIO_write(Perl_error_log, message, msglen); 1635 my_exit(1); 1636 } 1637 POPEVAL(cx); 1638 namesv = cx->blk_eval.old_namesv; 1639 1640 if (gimme == G_SCALAR) 1641 *++newsp = &PL_sv_undef; 1642 PL_stack_sp = newsp; 1643 1644 LEAVE; 1645 1646 /* LEAVE could clobber PL_curcop (see save_re_context()) 1647 * XXX it might be better to find a way to avoid messing with 1648 * PL_curcop in save_re_context() instead, but this is a more 1649 * minimal fix --GSAR */ 1650 PL_curcop = cx->blk_oldcop; 1651 1652 if (optype == OP_REQUIRE) { 1653 const char* const msg = SvPVx_nolen_const(ERRSV); 1654 (void)hv_store(GvHVn(PL_incgv), 1655 SvPVX_const(namesv), SvCUR(namesv), 1656 &PL_sv_undef, 0); 1657 DIE(aTHX_ "%sCompilation failed in require", 1658 *msg ? msg : "Unknown error\n"); 1659 } 1660 assert(CxTYPE(cx) == CXt_EVAL); 1661 PL_restartop = cx->blk_eval.retop; 1662 JMPENV_JUMP(3); 1663 /* NOTREACHED */ 1664 } 1665 } 1666 1667 write_to_stderr( msv ? msv : ERRSV ); 1668 my_failure_exit(); 1669 /* NOTREACHED */ 1670 } 1671 1672 PP(pp_xor) 1673 { 1674 dVAR; dSP; dPOPTOPssrl; 1675 if (SvTRUE(left) != SvTRUE(right)) 1676 RETSETYES; 1677 else 1678 RETSETNO; 1679 } 1680 1681 PP(pp_caller) 1682 { 1683 dVAR; 1684 dSP; 1685 register I32 cxix = dopoptosub(cxstack_ix); 1686 register const PERL_CONTEXT *cx; 1687 register const PERL_CONTEXT *ccstack = cxstack; 1688 const PERL_SI *top_si = PL_curstackinfo; 1689 I32 gimme; 1690 const char *stashname; 1691 I32 count = 0; 1692 1693 if (MAXARG) 1694 count = POPi; 1695 1696 for (;;) { 1697 /* we may be in a higher stacklevel, so dig down deeper */ 1698 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { 1699 top_si = top_si->si_prev; 1700 ccstack = top_si->si_cxstack; 1701 cxix = dopoptosub_at(ccstack, top_si->si_cxix); 1702 } 1703 if (cxix < 0) { 1704 if (GIMME != G_ARRAY) { 1705 EXTEND(SP, 1); 1706 RETPUSHUNDEF; 1707 } 1708 RETURN; 1709 } 1710 /* caller() should not report the automatic calls to &DB::sub */ 1711 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && 1712 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) 1713 count++; 1714 if (!count--) 1715 break; 1716 cxix = dopoptosub_at(ccstack, cxix - 1); 1717 } 1718 1719 cx = &ccstack[cxix]; 1720 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 1721 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1); 1722 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the 1723 field below is defined for any cx. */ 1724 /* caller() should not report the automatic calls to &DB::sub */ 1725 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) 1726 cx = &ccstack[dbcxix]; 1727 } 1728 1729 stashname = CopSTASHPV(cx->blk_oldcop); 1730 if (GIMME != G_ARRAY) { 1731 EXTEND(SP, 1); 1732 if (!stashname) 1733 PUSHs(&PL_sv_undef); 1734 else { 1735 dTARGET; 1736 sv_setpv(TARG, stashname); 1737 PUSHs(TARG); 1738 } 1739 RETURN; 1740 } 1741 1742 EXTEND(SP, 11); 1743 1744 if (!stashname) 1745 PUSHs(&PL_sv_undef); 1746 else 1747 mPUSHs(newSVpv(stashname, 0)); 1748 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0)); 1749 mPUSHi((I32)CopLINE(cx->blk_oldcop)); 1750 if (!MAXARG) 1751 RETURN; 1752 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 1753 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv); 1754 /* So is ccstack[dbcxix]. */ 1755 if (isGV(cvgv)) { 1756 SV * const sv = newSV(0); 1757 gv_efullname3(sv, cvgv, NULL); 1758 mPUSHs(sv); 1759 PUSHs(boolSV(CxHASARGS(cx))); 1760 } 1761 else { 1762 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP)); 1763 PUSHs(boolSV(CxHASARGS(cx))); 1764 } 1765 } 1766 else { 1767 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP)); 1768 mPUSHi(0); 1769 } 1770 gimme = (I32)cx->blk_gimme; 1771 if (gimme == G_VOID) 1772 PUSHs(&PL_sv_undef); 1773 else 1774 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY)); 1775 if (CxTYPE(cx) == CXt_EVAL) { 1776 /* eval STRING */ 1777 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { 1778 PUSHs(cx->blk_eval.cur_text); 1779 PUSHs(&PL_sv_no); 1780 } 1781 /* require */ 1782 else if (cx->blk_eval.old_namesv) { 1783 mPUSHs(newSVsv(cx->blk_eval.old_namesv)); 1784 PUSHs(&PL_sv_yes); 1785 } 1786 /* eval BLOCK (try blocks have old_namesv == 0) */ 1787 else { 1788 PUSHs(&PL_sv_undef); 1789 PUSHs(&PL_sv_undef); 1790 } 1791 } 1792 else { 1793 PUSHs(&PL_sv_undef); 1794 PUSHs(&PL_sv_undef); 1795 } 1796 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx) 1797 && CopSTASH_eq(PL_curcop, PL_debstash)) 1798 { 1799 AV * const ary = cx->blk_sub.argarray; 1800 const int off = AvARRAY(ary) - AvALLOC(ary); 1801 1802 if (!PL_dbargs) 1803 Perl_init_dbargs(aTHX); 1804 1805 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) 1806 av_extend(PL_dbargs, AvFILLp(ary) + off); 1807 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*); 1808 AvFILLp(PL_dbargs) = AvFILLp(ary) + off; 1809 } 1810 /* XXX only hints propagated via op_private are currently 1811 * visible (others are not easily accessible, since they 1812 * use the global PL_hints) */ 1813 mPUSHi(CopHINTS_get(cx->blk_oldcop)); 1814 { 1815 SV * mask ; 1816 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ; 1817 1818 if (old_warnings == pWARN_NONE || 1819 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) 1820 mask = newSVpvn(WARN_NONEstring, WARNsize) ; 1821 else if (old_warnings == pWARN_ALL || 1822 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { 1823 /* Get the bit mask for $warnings::Bits{all}, because 1824 * it could have been extended by warnings::register */ 1825 SV **bits_all; 1826 HV * const bits = get_hv("warnings::Bits", 0); 1827 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) { 1828 mask = newSVsv(*bits_all); 1829 } 1830 else { 1831 mask = newSVpvn(WARN_ALLstring, WARNsize) ; 1832 } 1833 } 1834 else 1835 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]); 1836 mPUSHs(mask); 1837 } 1838 1839 PUSHs(cx->blk_oldcop->cop_hints_hash ? 1840 sv_2mortal(newRV_noinc( 1841 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_ 1842 cx->blk_oldcop->cop_hints_hash)))) 1843 : &PL_sv_undef); 1844 RETURN; 1845 } 1846 1847 PP(pp_reset) 1848 { 1849 dVAR; 1850 dSP; 1851 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx; 1852 sv_reset(tmps, CopSTASH(PL_curcop)); 1853 PUSHs(&PL_sv_yes); 1854 RETURN; 1855 } 1856 1857 /* like pp_nextstate, but used instead when the debugger is active */ 1858 1859 PP(pp_dbstate) 1860 { 1861 dVAR; 1862 PL_curcop = (COP*)PL_op; 1863 TAINT_NOT; /* Each statement is presumed innocent */ 1864 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; 1865 FREETMPS; 1866 1867 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */ 1868 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) 1869 { 1870 dSP; 1871 register PERL_CONTEXT *cx; 1872 const I32 gimme = G_ARRAY; 1873 U8 hasargs; 1874 GV * const gv = PL_DBgv; 1875 register CV * const cv = GvCV(gv); 1876 1877 if (!cv) 1878 DIE(aTHX_ "No DB::DB routine defined"); 1879 1880 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG)) 1881 /* don't do recursive DB::DB call */ 1882 return NORMAL; 1883 1884 ENTER; 1885 SAVETMPS; 1886 1887 SAVEI32(PL_debug); 1888 SAVESTACK_POS(); 1889 PL_debug = 0; 1890 hasargs = 0; 1891 SPAGAIN; 1892 1893 if (CvISXSUB(cv)) { 1894 CvDEPTH(cv)++; 1895 PUSHMARK(SP); 1896 (void)(*CvXSUB(cv))(aTHX_ cv); 1897 CvDEPTH(cv)--; 1898 FREETMPS; 1899 LEAVE; 1900 return NORMAL; 1901 } 1902 else { 1903 PUSHBLOCK(cx, CXt_SUB, SP); 1904 PUSHSUB_DB(cx); 1905 cx->blk_sub.retop = PL_op->op_next; 1906 CvDEPTH(cv)++; 1907 SAVECOMPPAD(); 1908 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); 1909 RETURNOP(CvSTART(cv)); 1910 } 1911 } 1912 else 1913 return NORMAL; 1914 } 1915 1916 PP(pp_enteriter) 1917 { 1918 dVAR; dSP; dMARK; 1919 register PERL_CONTEXT *cx; 1920 const I32 gimme = GIMME_V; 1921 SV **svp; 1922 U8 cxtype = CXt_LOOP_FOR; 1923 #ifdef USE_ITHREADS 1924 PAD *iterdata; 1925 #endif 1926 1927 ENTER_with_name("loop1"); 1928 SAVETMPS; 1929 1930 if (PL_op->op_targ) { 1931 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */ 1932 SvPADSTALE_off(PAD_SVl(PL_op->op_targ)); 1933 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ), 1934 SVs_PADSTALE, SVs_PADSTALE); 1935 } 1936 SAVEPADSVANDMORTALIZE(PL_op->op_targ); 1937 #ifndef USE_ITHREADS 1938 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */ 1939 #else 1940 iterdata = NULL; 1941 #endif 1942 } 1943 else { 1944 GV * const gv = MUTABLE_GV(POPs); 1945 svp = &GvSV(gv); /* symbol table variable */ 1946 SAVEGENERICSV(*svp); 1947 *svp = newSV(0); 1948 #ifdef USE_ITHREADS 1949 iterdata = (PAD*)gv; 1950 #endif 1951 } 1952 1953 if (PL_op->op_private & OPpITER_DEF) 1954 cxtype |= CXp_FOR_DEF; 1955 1956 ENTER_with_name("loop2"); 1957 1958 PUSHBLOCK(cx, cxtype, SP); 1959 #ifdef USE_ITHREADS 1960 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ); 1961 #else 1962 PUSHLOOP_FOR(cx, svp, MARK, 0); 1963 #endif 1964 if (PL_op->op_flags & OPf_STACKED) { 1965 SV *maybe_ary = POPs; 1966 if (SvTYPE(maybe_ary) != SVt_PVAV) { 1967 dPOPss; 1968 SV * const right = maybe_ary; 1969 SvGETMAGIC(sv); 1970 SvGETMAGIC(right); 1971 if (RANGE_IS_NUMERIC(sv,right)) { 1972 cx->cx_type &= ~CXTYPEMASK; 1973 cx->cx_type |= CXt_LOOP_LAZYIV; 1974 /* Make sure that no-one re-orders cop.h and breaks our 1975 assumptions */ 1976 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV); 1977 #ifdef NV_PRESERVES_UV 1978 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) || 1979 (SvNV(sv) > (NV)IV_MAX))) 1980 || 1981 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) || 1982 (SvNV(right) < (NV)IV_MIN)))) 1983 #else 1984 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN) 1985 || 1986 ((SvNV(sv) > 0) && 1987 ((SvUV(sv) > (UV)IV_MAX) || 1988 (SvNV(sv) > (NV)UV_MAX))))) 1989 || 1990 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN) 1991 || 1992 ((SvNV(right) > 0) && 1993 ((SvUV(right) > (UV)IV_MAX) || 1994 (SvNV(right) > (NV)UV_MAX)))))) 1995 #endif 1996 DIE(aTHX_ "Range iterator outside integer range"); 1997 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv); 1998 cx->blk_loop.state_u.lazyiv.end = SvIV(right); 1999 #ifdef DEBUGGING 2000 /* for correct -Dstv display */ 2001 cx->blk_oldsp = sp - PL_stack_base; 2002 #endif 2003 } 2004 else { 2005 cx->cx_type &= ~CXTYPEMASK; 2006 cx->cx_type |= CXt_LOOP_LAZYSV; 2007 /* Make sure that no-one re-orders cop.h and breaks our 2008 assumptions */ 2009 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV); 2010 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv); 2011 cx->blk_loop.state_u.lazysv.end = right; 2012 SvREFCNT_inc(right); 2013 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur); 2014 /* This will do the upgrade to SVt_PV, and warn if the value 2015 is uninitialised. */ 2016 (void) SvPV_nolen_const(right); 2017 /* Doing this avoids a check every time in pp_iter in pp_hot.c 2018 to replace !SvOK() with a pointer to "". */ 2019 if (!SvOK(right)) { 2020 SvREFCNT_dec(right); 2021 cx->blk_loop.state_u.lazysv.end = &PL_sv_no; 2022 } 2023 } 2024 } 2025 else /* SvTYPE(maybe_ary) == SVt_PVAV */ { 2026 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary); 2027 SvREFCNT_inc(maybe_ary); 2028 cx->blk_loop.state_u.ary.ix = 2029 (PL_op->op_private & OPpITER_REVERSED) ? 2030 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 : 2031 -1; 2032 } 2033 } 2034 else { /* iterating over items on the stack */ 2035 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */ 2036 if (PL_op->op_private & OPpITER_REVERSED) { 2037 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1; 2038 } 2039 else { 2040 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base; 2041 } 2042 } 2043 2044 RETURN; 2045 } 2046 2047 PP(pp_enterloop) 2048 { 2049 dVAR; dSP; 2050 register PERL_CONTEXT *cx; 2051 const I32 gimme = GIMME_V; 2052 2053 ENTER_with_name("loop1"); 2054 SAVETMPS; 2055 ENTER_with_name("loop2"); 2056 2057 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP); 2058 PUSHLOOP_PLAIN(cx, SP); 2059 2060 RETURN; 2061 } 2062 2063 PP(pp_leaveloop) 2064 { 2065 dVAR; dSP; 2066 register PERL_CONTEXT *cx; 2067 I32 gimme; 2068 SV **newsp; 2069 PMOP *newpm; 2070 SV **mark; 2071 2072 POPBLOCK(cx,newpm); 2073 assert(CxTYPE_is_LOOP(cx)); 2074 mark = newsp; 2075 newsp = PL_stack_base + cx->blk_loop.resetsp; 2076 2077 TAINT_NOT; 2078 if (gimme == G_VOID) 2079 NOOP; 2080 else if (gimme == G_SCALAR) { 2081 if (mark < SP) 2082 *++newsp = sv_mortalcopy(*SP); 2083 else 2084 *++newsp = &PL_sv_undef; 2085 } 2086 else { 2087 while (mark < SP) { 2088 *++newsp = sv_mortalcopy(*++mark); 2089 TAINT_NOT; /* Each item is independent */ 2090 } 2091 } 2092 SP = newsp; 2093 PUTBACK; 2094 2095 POPLOOP(cx); /* Stack values are safe: release loop vars ... */ 2096 PL_curpm = newpm; /* ... and pop $1 et al */ 2097 2098 LEAVE_with_name("loop2"); 2099 LEAVE_with_name("loop1"); 2100 2101 return NORMAL; 2102 } 2103 2104 PP(pp_return) 2105 { 2106 dVAR; dSP; dMARK; 2107 register PERL_CONTEXT *cx; 2108 bool popsub2 = FALSE; 2109 bool clear_errsv = FALSE; 2110 I32 gimme; 2111 SV **newsp; 2112 PMOP *newpm; 2113 I32 optype = 0; 2114 SV *namesv; 2115 SV *sv; 2116 OP *retop = NULL; 2117 2118 const I32 cxix = dopoptosub(cxstack_ix); 2119 2120 if (cxix < 0) { 2121 if (CxMULTICALL(cxstack)) { /* In this case we must be in a 2122 * sort block, which is a CXt_NULL 2123 * not a CXt_SUB */ 2124 dounwind(0); 2125 PL_stack_base[1] = *PL_stack_sp; 2126 PL_stack_sp = PL_stack_base + 1; 2127 return 0; 2128 } 2129 else 2130 DIE(aTHX_ "Can't return outside a subroutine"); 2131 } 2132 if (cxix < cxstack_ix) 2133 dounwind(cxix); 2134 2135 if (CxMULTICALL(&cxstack[cxix])) { 2136 gimme = cxstack[cxix].blk_gimme; 2137 if (gimme == G_VOID) 2138 PL_stack_sp = PL_stack_base; 2139 else if (gimme == G_SCALAR) { 2140 PL_stack_base[1] = *PL_stack_sp; 2141 PL_stack_sp = PL_stack_base + 1; 2142 } 2143 return 0; 2144 } 2145 2146 POPBLOCK(cx,newpm); 2147 switch (CxTYPE(cx)) { 2148 case CXt_SUB: 2149 popsub2 = TRUE; 2150 retop = cx->blk_sub.retop; 2151 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */ 2152 break; 2153 case CXt_EVAL: 2154 if (!(PL_in_eval & EVAL_KEEPERR)) 2155 clear_errsv = TRUE; 2156 POPEVAL(cx); 2157 namesv = cx->blk_eval.old_namesv; 2158 retop = cx->blk_eval.retop; 2159 if (CxTRYBLOCK(cx)) 2160 break; 2161 lex_end(); 2162 if (optype == OP_REQUIRE && 2163 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) 2164 { 2165 /* Unassume the success we assumed earlier. */ 2166 (void)hv_delete(GvHVn(PL_incgv), 2167 SvPVX_const(namesv), SvCUR(namesv), 2168 G_DISCARD); 2169 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv)); 2170 } 2171 break; 2172 case CXt_FORMAT: 2173 POPFORMAT(cx); 2174 retop = cx->blk_sub.retop; 2175 break; 2176 default: 2177 DIE(aTHX_ "panic: return"); 2178 } 2179 2180 TAINT_NOT; 2181 if (gimme == G_SCALAR) { 2182 if (MARK < SP) { 2183 if (popsub2) { 2184 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { 2185 if (SvTEMP(TOPs)) { 2186 *++newsp = SvREFCNT_inc(*SP); 2187 FREETMPS; 2188 sv_2mortal(*newsp); 2189 } 2190 else { 2191 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */ 2192 FREETMPS; 2193 *++newsp = sv_mortalcopy(sv); 2194 SvREFCNT_dec(sv); 2195 } 2196 } 2197 else 2198 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); 2199 } 2200 else 2201 *++newsp = sv_mortalcopy(*SP); 2202 } 2203 else 2204 *++newsp = &PL_sv_undef; 2205 } 2206 else if (gimme == G_ARRAY) { 2207 while (++MARK <= SP) { 2208 *++newsp = (popsub2 && SvTEMP(*MARK)) 2209 ? *MARK : sv_mortalcopy(*MARK); 2210 TAINT_NOT; /* Each item is independent */ 2211 } 2212 } 2213 PL_stack_sp = newsp; 2214 2215 LEAVE; 2216 /* Stack values are safe: */ 2217 if (popsub2) { 2218 cxstack_ix--; 2219 POPSUB(cx,sv); /* release CV and @_ ... */ 2220 } 2221 else 2222 sv = NULL; 2223 PL_curpm = newpm; /* ... and pop $1 et al */ 2224 2225 LEAVESUB(sv); 2226 if (clear_errsv) { 2227 CLEAR_ERRSV(); 2228 } 2229 return retop; 2230 } 2231 2232 PP(pp_last) 2233 { 2234 dVAR; dSP; 2235 I32 cxix; 2236 register PERL_CONTEXT *cx; 2237 I32 pop2 = 0; 2238 I32 gimme; 2239 I32 optype; 2240 OP *nextop = NULL; 2241 SV **newsp; 2242 PMOP *newpm; 2243 SV **mark; 2244 SV *sv = NULL; 2245 2246 2247 if (PL_op->op_flags & OPf_SPECIAL) { 2248 cxix = dopoptoloop(cxstack_ix); 2249 if (cxix < 0) 2250 DIE(aTHX_ "Can't \"last\" outside a loop block"); 2251 } 2252 else { 2253 cxix = dopoptolabel(cPVOP->op_pv); 2254 if (cxix < 0) 2255 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv); 2256 } 2257 if (cxix < cxstack_ix) 2258 dounwind(cxix); 2259 2260 POPBLOCK(cx,newpm); 2261 cxstack_ix++; /* temporarily protect top context */ 2262 mark = newsp; 2263 switch (CxTYPE(cx)) { 2264 case CXt_LOOP_LAZYIV: 2265 case CXt_LOOP_LAZYSV: 2266 case CXt_LOOP_FOR: 2267 case CXt_LOOP_PLAIN: 2268 pop2 = CxTYPE(cx); 2269 newsp = PL_stack_base + cx->blk_loop.resetsp; 2270 nextop = cx->blk_loop.my_op->op_lastop->op_next; 2271 break; 2272 case CXt_SUB: 2273 pop2 = CXt_SUB; 2274 nextop = cx->blk_sub.retop; 2275 break; 2276 case CXt_EVAL: 2277 POPEVAL(cx); 2278 nextop = cx->blk_eval.retop; 2279 break; 2280 case CXt_FORMAT: 2281 POPFORMAT(cx); 2282 nextop = cx->blk_sub.retop; 2283 break; 2284 default: 2285 DIE(aTHX_ "panic: last"); 2286 } 2287 2288 TAINT_NOT; 2289 if (gimme == G_SCALAR) { 2290 if (MARK < SP) 2291 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP)) 2292 ? *SP : sv_mortalcopy(*SP); 2293 else 2294 *++newsp = &PL_sv_undef; 2295 } 2296 else if (gimme == G_ARRAY) { 2297 while (++MARK <= SP) { 2298 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK)) 2299 ? *MARK : sv_mortalcopy(*MARK); 2300 TAINT_NOT; /* Each item is independent */ 2301 } 2302 } 2303 SP = newsp; 2304 PUTBACK; 2305 2306 LEAVE; 2307 cxstack_ix--; 2308 /* Stack values are safe: */ 2309 switch (pop2) { 2310 case CXt_LOOP_LAZYIV: 2311 case CXt_LOOP_PLAIN: 2312 case CXt_LOOP_LAZYSV: 2313 case CXt_LOOP_FOR: 2314 POPLOOP(cx); /* release loop vars ... */ 2315 LEAVE; 2316 break; 2317 case CXt_SUB: 2318 POPSUB(cx,sv); /* release CV and @_ ... */ 2319 break; 2320 } 2321 PL_curpm = newpm; /* ... and pop $1 et al */ 2322 2323 LEAVESUB(sv); 2324 PERL_UNUSED_VAR(optype); 2325 PERL_UNUSED_VAR(gimme); 2326 return nextop; 2327 } 2328 2329 PP(pp_next) 2330 { 2331 dVAR; 2332 I32 cxix; 2333 register PERL_CONTEXT *cx; 2334 I32 inner; 2335 2336 if (PL_op->op_flags & OPf_SPECIAL) { 2337 cxix = dopoptoloop(cxstack_ix); 2338 if (cxix < 0) 2339 DIE(aTHX_ "Can't \"next\" outside a loop block"); 2340 } 2341 else { 2342 cxix = dopoptolabel(cPVOP->op_pv); 2343 if (cxix < 0) 2344 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv); 2345 } 2346 if (cxix < cxstack_ix) 2347 dounwind(cxix); 2348 2349 /* clear off anything above the scope we're re-entering, but 2350 * save the rest until after a possible continue block */ 2351 inner = PL_scopestack_ix; 2352 TOPBLOCK(cx); 2353 if (PL_scopestack_ix < inner) 2354 leave_scope(PL_scopestack[PL_scopestack_ix]); 2355 PL_curcop = cx->blk_oldcop; 2356 return CX_LOOP_NEXTOP_GET(cx); 2357 } 2358 2359 PP(pp_redo) 2360 { 2361 dVAR; 2362 I32 cxix; 2363 register PERL_CONTEXT *cx; 2364 I32 oldsave; 2365 OP* redo_op; 2366 2367 if (PL_op->op_flags & OPf_SPECIAL) { 2368 cxix = dopoptoloop(cxstack_ix); 2369 if (cxix < 0) 2370 DIE(aTHX_ "Can't \"redo\" outside a loop block"); 2371 } 2372 else { 2373 cxix = dopoptolabel(cPVOP->op_pv); 2374 if (cxix < 0) 2375 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv); 2376 } 2377 if (cxix < cxstack_ix) 2378 dounwind(cxix); 2379 2380 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop; 2381 if (redo_op->op_type == OP_ENTER) { 2382 /* pop one less context to avoid $x being freed in while (my $x..) */ 2383 cxstack_ix++; 2384 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK); 2385 redo_op = redo_op->op_next; 2386 } 2387 2388 TOPBLOCK(cx); 2389 oldsave = PL_scopestack[PL_scopestack_ix - 1]; 2390 LEAVE_SCOPE(oldsave); 2391 FREETMPS; 2392 PL_curcop = cx->blk_oldcop; 2393 return redo_op; 2394 } 2395 2396 STATIC OP * 2397 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) 2398 { 2399 dVAR; 2400 OP **ops = opstack; 2401 static const char too_deep[] = "Target of goto is too deeply nested"; 2402 2403 PERL_ARGS_ASSERT_DOFINDLABEL; 2404 2405 if (ops >= oplimit) 2406 Perl_croak(aTHX_ too_deep); 2407 if (o->op_type == OP_LEAVE || 2408 o->op_type == OP_SCOPE || 2409 o->op_type == OP_LEAVELOOP || 2410 o->op_type == OP_LEAVESUB || 2411 o->op_type == OP_LEAVETRY) 2412 { 2413 *ops++ = cUNOPo->op_first; 2414 if (ops >= oplimit) 2415 Perl_croak(aTHX_ too_deep); 2416 } 2417 *ops = 0; 2418 if (o->op_flags & OPf_KIDS) { 2419 OP *kid; 2420 /* First try all the kids at this level, since that's likeliest. */ 2421 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 2422 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { 2423 const char *kid_label = CopLABEL(kCOP); 2424 if (kid_label && strEQ(kid_label, label)) 2425 return kid; 2426 } 2427 } 2428 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 2429 if (kid == PL_lastgotoprobe) 2430 continue; 2431 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { 2432 if (ops == opstack) 2433 *ops++ = kid; 2434 else if (ops[-1]->op_type == OP_NEXTSTATE || 2435 ops[-1]->op_type == OP_DBSTATE) 2436 ops[-1] = kid; 2437 else 2438 *ops++ = kid; 2439 } 2440 if ((o = dofindlabel(kid, label, ops, oplimit))) 2441 return o; 2442 } 2443 } 2444 *ops = 0; 2445 return 0; 2446 } 2447 2448 PP(pp_goto) 2449 { 2450 dVAR; dSP; 2451 OP *retop = NULL; 2452 I32 ix; 2453 register PERL_CONTEXT *cx; 2454 #define GOTO_DEPTH 64 2455 OP *enterops[GOTO_DEPTH]; 2456 const char *label = NULL; 2457 const bool do_dump = (PL_op->op_type == OP_DUMP); 2458 static const char must_have_label[] = "goto must have label"; 2459 2460 if (PL_op->op_flags & OPf_STACKED) { 2461 SV * const sv = POPs; 2462 2463 /* This egregious kludge implements goto &subroutine */ 2464 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { 2465 I32 cxix; 2466 register PERL_CONTEXT *cx; 2467 CV *cv = MUTABLE_CV(SvRV(sv)); 2468 SV** mark; 2469 I32 items = 0; 2470 I32 oldsave; 2471 bool reified = 0; 2472 2473 retry: 2474 if (!CvROOT(cv) && !CvXSUB(cv)) { 2475 const GV * const gv = CvGV(cv); 2476 if (gv) { 2477 GV *autogv; 2478 SV *tmpstr; 2479 /* autoloaded stub? */ 2480 if (cv != GvCV(gv) && (cv = GvCV(gv))) 2481 goto retry; 2482 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), 2483 GvNAMELEN(gv), FALSE); 2484 if (autogv && (cv = GvCV(autogv))) 2485 goto retry; 2486 tmpstr = sv_newmortal(); 2487 gv_efullname3(tmpstr, gv, NULL); 2488 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr)); 2489 } 2490 DIE(aTHX_ "Goto undefined subroutine"); 2491 } 2492 2493 /* First do some returnish stuff. */ 2494 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */ 2495 FREETMPS; 2496 cxix = dopoptosub(cxstack_ix); 2497 if (cxix < 0) 2498 DIE(aTHX_ "Can't goto subroutine outside a subroutine"); 2499 if (cxix < cxstack_ix) 2500 dounwind(cxix); 2501 TOPBLOCK(cx); 2502 SPAGAIN; 2503 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */ 2504 if (CxTYPE(cx) == CXt_EVAL) { 2505 if (CxREALEVAL(cx)) 2506 DIE(aTHX_ "Can't goto subroutine from an eval-string"); 2507 else 2508 DIE(aTHX_ "Can't goto subroutine from an eval-block"); 2509 } 2510 else if (CxMULTICALL(cx)) 2511 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)"); 2512 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { 2513 /* put @_ back onto stack */ 2514 AV* av = cx->blk_sub.argarray; 2515 2516 items = AvFILLp(av) + 1; 2517 EXTEND(SP, items+1); /* @_ could have been extended. */ 2518 Copy(AvARRAY(av), SP + 1, items, SV*); 2519 SvREFCNT_dec(GvAV(PL_defgv)); 2520 GvAV(PL_defgv) = cx->blk_sub.savearray; 2521 CLEAR_ARGARRAY(av); 2522 /* abandon @_ if it got reified */ 2523 if (AvREAL(av)) { 2524 reified = 1; 2525 SvREFCNT_dec(av); 2526 av = newAV(); 2527 av_extend(av, items-1); 2528 AvREIFY_only(av); 2529 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av); 2530 } 2531 } 2532 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */ 2533 AV* const av = GvAV(PL_defgv); 2534 items = AvFILLp(av) + 1; 2535 EXTEND(SP, items+1); /* @_ could have been extended. */ 2536 Copy(AvARRAY(av), SP + 1, items, SV*); 2537 } 2538 mark = SP; 2539 SP += items; 2540 if (CxTYPE(cx) == CXt_SUB && 2541 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) 2542 SvREFCNT_dec(cx->blk_sub.cv); 2543 oldsave = PL_scopestack[PL_scopestack_ix - 1]; 2544 LEAVE_SCOPE(oldsave); 2545 2546 /* Now do some callish stuff. */ 2547 SAVETMPS; 2548 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ 2549 if (CvISXSUB(cv)) { 2550 OP* const retop = cx->blk_sub.retop; 2551 SV **newsp; 2552 I32 gimme; 2553 if (reified) { 2554 I32 index; 2555 for (index=0; index<items; index++) 2556 sv_2mortal(SP[-index]); 2557 } 2558 2559 /* XS subs don't have a CxSUB, so pop it */ 2560 POPBLOCK(cx, PL_curpm); 2561 /* Push a mark for the start of arglist */ 2562 PUSHMARK(mark); 2563 PUTBACK; 2564 (void)(*CvXSUB(cv))(aTHX_ cv); 2565 LEAVE; 2566 return retop; 2567 } 2568 else { 2569 AV* const padlist = CvPADLIST(cv); 2570 if (CxTYPE(cx) == CXt_EVAL) { 2571 PL_in_eval = CxOLD_IN_EVAL(cx); 2572 PL_eval_root = cx->blk_eval.old_eval_root; 2573 cx->cx_type = CXt_SUB; 2574 } 2575 cx->blk_sub.cv = cv; 2576 cx->blk_sub.olddepth = CvDEPTH(cv); 2577 2578 CvDEPTH(cv)++; 2579 if (CvDEPTH(cv) < 2) 2580 SvREFCNT_inc_simple_void_NN(cv); 2581 else { 2582 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)) 2583 sub_crush_depth(cv); 2584 pad_push(padlist, CvDEPTH(cv)); 2585 } 2586 SAVECOMPPAD(); 2587 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); 2588 if (CxHASARGS(cx)) 2589 { 2590 AV *const av = MUTABLE_AV(PAD_SVl(0)); 2591 2592 cx->blk_sub.savearray = GvAV(PL_defgv); 2593 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av)); 2594 CX_CURPAD_SAVE(cx->blk_sub); 2595 cx->blk_sub.argarray = av; 2596 2597 if (items >= AvMAX(av) + 1) { 2598 SV **ary = AvALLOC(av); 2599 if (AvARRAY(av) != ary) { 2600 AvMAX(av) += AvARRAY(av) - AvALLOC(av); 2601 AvARRAY(av) = ary; 2602 } 2603 if (items >= AvMAX(av) + 1) { 2604 AvMAX(av) = items - 1; 2605 Renew(ary,items+1,SV*); 2606 AvALLOC(av) = ary; 2607 AvARRAY(av) = ary; 2608 } 2609 } 2610 ++mark; 2611 Copy(mark,AvARRAY(av),items,SV*); 2612 AvFILLp(av) = items - 1; 2613 assert(!AvREAL(av)); 2614 if (reified) { 2615 /* transfer 'ownership' of refcnts to new @_ */ 2616 AvREAL_on(av); 2617 AvREIFY_off(av); 2618 } 2619 while (items--) { 2620 if (*mark) 2621 SvTEMP_off(*mark); 2622 mark++; 2623 } 2624 } 2625 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ 2626 Perl_get_db_sub(aTHX_ NULL, cv); 2627 if (PERLDB_GOTO) { 2628 CV * const gotocv = get_cvs("DB::goto", 0); 2629 if (gotocv) { 2630 PUSHMARK( PL_stack_sp ); 2631 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG); 2632 PL_stack_sp--; 2633 } 2634 } 2635 } 2636 RETURNOP(CvSTART(cv)); 2637 } 2638 } 2639 else { 2640 label = SvPV_nolen_const(sv); 2641 if (!(do_dump || *label)) 2642 DIE(aTHX_ must_have_label); 2643 } 2644 } 2645 else if (PL_op->op_flags & OPf_SPECIAL) { 2646 if (! do_dump) 2647 DIE(aTHX_ must_have_label); 2648 } 2649 else 2650 label = cPVOP->op_pv; 2651 2652 if (label && *label) { 2653 OP *gotoprobe = NULL; 2654 bool leaving_eval = FALSE; 2655 bool in_block = FALSE; 2656 PERL_CONTEXT *last_eval_cx = NULL; 2657 2658 /* find label */ 2659 2660 PL_lastgotoprobe = NULL; 2661 *enterops = 0; 2662 for (ix = cxstack_ix; ix >= 0; ix--) { 2663 cx = &cxstack[ix]; 2664 switch (CxTYPE(cx)) { 2665 case CXt_EVAL: 2666 leaving_eval = TRUE; 2667 if (!CxTRYBLOCK(cx)) { 2668 gotoprobe = (last_eval_cx ? 2669 last_eval_cx->blk_eval.old_eval_root : 2670 PL_eval_root); 2671 last_eval_cx = cx; 2672 break; 2673 } 2674 /* else fall through */ 2675 case CXt_LOOP_LAZYIV: 2676 case CXt_LOOP_LAZYSV: 2677 case CXt_LOOP_FOR: 2678 case CXt_LOOP_PLAIN: 2679 case CXt_GIVEN: 2680 case CXt_WHEN: 2681 gotoprobe = cx->blk_oldcop->op_sibling; 2682 break; 2683 case CXt_SUBST: 2684 continue; 2685 case CXt_BLOCK: 2686 if (ix) { 2687 gotoprobe = cx->blk_oldcop->op_sibling; 2688 in_block = TRUE; 2689 } else 2690 gotoprobe = PL_main_root; 2691 break; 2692 case CXt_SUB: 2693 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) { 2694 gotoprobe = CvROOT(cx->blk_sub.cv); 2695 break; 2696 } 2697 /* FALL THROUGH */ 2698 case CXt_FORMAT: 2699 case CXt_NULL: 2700 DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); 2701 default: 2702 if (ix) 2703 DIE(aTHX_ "panic: goto"); 2704 gotoprobe = PL_main_root; 2705 break; 2706 } 2707 if (gotoprobe) { 2708 retop = dofindlabel(gotoprobe, label, 2709 enterops, enterops + GOTO_DEPTH); 2710 if (retop) 2711 break; 2712 } 2713 PL_lastgotoprobe = gotoprobe; 2714 } 2715 if (!retop) 2716 DIE(aTHX_ "Can't find label %s", label); 2717 2718 /* if we're leaving an eval, check before we pop any frames 2719 that we're not going to punt, otherwise the error 2720 won't be caught */ 2721 2722 if (leaving_eval && *enterops && enterops[1]) { 2723 I32 i; 2724 for (i = 1; enterops[i]; i++) 2725 if (enterops[i]->op_type == OP_ENTERITER) 2726 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); 2727 } 2728 2729 if (*enterops && enterops[1]) { 2730 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; 2731 if (enterops[i]) 2732 deprecate("\"goto\" to jump into a construct"); 2733 } 2734 2735 /* pop unwanted frames */ 2736 2737 if (ix < cxstack_ix) { 2738 I32 oldsave; 2739 2740 if (ix < 0) 2741 ix = 0; 2742 dounwind(ix); 2743 TOPBLOCK(cx); 2744 oldsave = PL_scopestack[PL_scopestack_ix]; 2745 LEAVE_SCOPE(oldsave); 2746 } 2747 2748 /* push wanted frames */ 2749 2750 if (*enterops && enterops[1]) { 2751 OP * const oldop = PL_op; 2752 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; 2753 for (; enterops[ix]; ix++) { 2754 PL_op = enterops[ix]; 2755 /* Eventually we may want to stack the needed arguments 2756 * for each op. For now, we punt on the hard ones. */ 2757 if (PL_op->op_type == OP_ENTERITER) 2758 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); 2759 CALL_FPTR(PL_op->op_ppaddr)(aTHX); 2760 } 2761 PL_op = oldop; 2762 } 2763 } 2764 2765 if (do_dump) { 2766 #ifdef VMS 2767 if (!retop) retop = PL_main_start; 2768 #endif 2769 PL_restartop = retop; 2770 PL_do_undump = TRUE; 2771 2772 my_unexec(); 2773 2774 PL_restartop = 0; /* hmm, must be GNU unexec().. */ 2775 PL_do_undump = FALSE; 2776 } 2777 2778 RETURNOP(retop); 2779 } 2780 2781 PP(pp_exit) 2782 { 2783 dVAR; 2784 dSP; 2785 I32 anum; 2786 2787 if (MAXARG < 1) 2788 anum = 0; 2789 else { 2790 anum = SvIVx(POPs); 2791 #ifdef VMS 2792 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH)) 2793 anum = 0; 2794 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); 2795 #endif 2796 } 2797 PL_exit_flags |= PERL_EXIT_EXPECTED; 2798 #ifdef PERL_MAD 2799 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */ 2800 if (anum || !(PL_minus_c && PL_madskills)) 2801 my_exit(anum); 2802 #else 2803 my_exit(anum); 2804 #endif 2805 PUSHs(&PL_sv_undef); 2806 RETURN; 2807 } 2808 2809 /* Eval. */ 2810 2811 STATIC void 2812 S_save_lines(pTHX_ AV *array, SV *sv) 2813 { 2814 const char *s = SvPVX_const(sv); 2815 const char * const send = SvPVX_const(sv) + SvCUR(sv); 2816 I32 line = 1; 2817 2818 PERL_ARGS_ASSERT_SAVE_LINES; 2819 2820 while (s && s < send) { 2821 const char *t; 2822 SV * const tmpstr = newSV_type(SVt_PVMG); 2823 2824 t = (const char *)memchr(s, '\n', send - s); 2825 if (t) 2826 t++; 2827 else 2828 t = send; 2829 2830 sv_setpvn(tmpstr, s, t - s); 2831 av_store(array, line++, tmpstr); 2832 s = t; 2833 } 2834 } 2835 2836 /* 2837 =for apidoc docatch 2838 2839 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context. 2840 2841 0 is used as continue inside eval, 2842 2843 3 is used for a die caught by an inner eval - continue inner loop 2844 2845 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must 2846 establish a local jmpenv to handle exception traps. 2847 2848 =cut 2849 */ 2850 STATIC OP * 2851 S_docatch(pTHX_ OP *o) 2852 { 2853 dVAR; 2854 int ret; 2855 OP * const oldop = PL_op; 2856 dJMPENV; 2857 2858 #ifdef DEBUGGING 2859 assert(CATCH_GET == TRUE); 2860 #endif 2861 PL_op = o; 2862 2863 JMPENV_PUSH(ret); 2864 switch (ret) { 2865 case 0: 2866 assert(cxstack_ix >= 0); 2867 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); 2868 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env; 2869 redo_body: 2870 CALLRUNOPS(aTHX); 2871 break; 2872 case 3: 2873 /* die caught by an inner eval - continue inner loop */ 2874 2875 /* NB XXX we rely on the old popped CxEVAL still being at the top 2876 * of the stack; the way die_where() currently works, this 2877 * assumption is valid. In theory The cur_top_env value should be 2878 * returned in another global, the way retop (aka PL_restartop) 2879 * is. */ 2880 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL); 2881 2882 if (PL_restartop 2883 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env) 2884 { 2885 PL_op = PL_restartop; 2886 PL_restartop = 0; 2887 goto redo_body; 2888 } 2889 /* FALL THROUGH */ 2890 default: 2891 JMPENV_POP; 2892 PL_op = oldop; 2893 JMPENV_JUMP(ret); 2894 /* NOTREACHED */ 2895 } 2896 JMPENV_POP; 2897 PL_op = oldop; 2898 return NULL; 2899 } 2900 2901 /* James Bond: Do you expect me to talk? 2902 Auric Goldfinger: No, Mr. Bond. I expect you to die. 2903 2904 This code is an ugly hack, doesn't work with lexicals in subroutines that are 2905 called more than once, and is only used by regcomp.c, for (?{}) blocks. 2906 2907 Currently it is not used outside the core code. Best if it stays that way. 2908 */ 2909 OP * 2910 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) 2911 /* sv Text to convert to OP tree. */ 2912 /* startop op_free() this to undo. */ 2913 /* code Short string id of the caller. */ 2914 { 2915 dVAR; dSP; /* Make POPBLOCK work. */ 2916 PERL_CONTEXT *cx; 2917 SV **newsp; 2918 I32 gimme = G_VOID; 2919 I32 optype; 2920 OP dummy; 2921 char tbuf[TYPE_DIGITS(long) + 12 + 10]; 2922 char *tmpbuf = tbuf; 2923 char *safestr; 2924 int runtime; 2925 CV* runcv = NULL; /* initialise to avoid compiler warnings */ 2926 STRLEN len; 2927 2928 PERL_ARGS_ASSERT_SV_COMPILE_2OP; 2929 2930 ENTER_with_name("eval"); 2931 lex_start(sv, NULL, FALSE); 2932 SAVETMPS; 2933 /* switch to eval mode */ 2934 2935 if (IN_PERL_COMPILETIME) { 2936 SAVECOPSTASH_FREE(&PL_compiling); 2937 CopSTASH_set(&PL_compiling, PL_curstash); 2938 } 2939 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { 2940 SV * const sv = sv_newmortal(); 2941 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]", 2942 code, (unsigned long)++PL_evalseq, 2943 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 2944 tmpbuf = SvPVX(sv); 2945 len = SvCUR(sv); 2946 } 2947 else 2948 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code, 2949 (unsigned long)++PL_evalseq); 2950 SAVECOPFILE_FREE(&PL_compiling); 2951 CopFILE_set(&PL_compiling, tmpbuf+2); 2952 SAVECOPLINE(&PL_compiling); 2953 CopLINE_set(&PL_compiling, 1); 2954 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up 2955 deleting the eval's FILEGV from the stash before gv_check() runs 2956 (i.e. before run-time proper). To work around the coredump that 2957 ensues, we always turn GvMULTI_on for any globals that were 2958 introduced within evals. See force_ident(). GSAR 96-10-12 */ 2959 safestr = savepvn(tmpbuf, len); 2960 SAVEDELETE(PL_defstash, safestr, len); 2961 SAVEHINTS(); 2962 #ifdef OP_IN_REGISTER 2963 PL_opsave = op; 2964 #else 2965 SAVEVPTR(PL_op); 2966 #endif 2967 2968 /* we get here either during compilation, or via pp_regcomp at runtime */ 2969 runtime = IN_PERL_RUNTIME; 2970 if (runtime) 2971 runcv = find_runcv(NULL); 2972 2973 PL_op = &dummy; 2974 PL_op->op_type = OP_ENTEREVAL; 2975 PL_op->op_flags = 0; /* Avoid uninit warning. */ 2976 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP); 2977 PUSHEVAL(cx, 0); 2978 2979 if (runtime) 2980 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); 2981 else 2982 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); 2983 POPBLOCK(cx,PL_curpm); 2984 POPEVAL(cx); 2985 2986 (*startop)->op_type = OP_NULL; 2987 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL]; 2988 lex_end(); 2989 /* XXX DAPM do this properly one year */ 2990 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad)); 2991 LEAVE_with_name("eval"); 2992 if (IN_PERL_COMPILETIME) 2993 CopHINTS_set(&PL_compiling, PL_hints); 2994 #ifdef OP_IN_REGISTER 2995 op = PL_opsave; 2996 #endif 2997 PERL_UNUSED_VAR(newsp); 2998 PERL_UNUSED_VAR(optype); 2999 3000 return PL_eval_start; 3001 } 3002 3003 3004 /* 3005 =for apidoc find_runcv 3006 3007 Locate the CV corresponding to the currently executing sub or eval. 3008 If db_seqp is non_null, skip CVs that are in the DB package and populate 3009 *db_seqp with the cop sequence number at the point that the DB:: code was 3010 entered. (allows debuggers to eval in the scope of the breakpoint rather 3011 than in the scope of the debugger itself). 3012 3013 =cut 3014 */ 3015 3016 CV* 3017 Perl_find_runcv(pTHX_ U32 *db_seqp) 3018 { 3019 dVAR; 3020 PERL_SI *si; 3021 3022 if (db_seqp) 3023 *db_seqp = PL_curcop->cop_seq; 3024 for (si = PL_curstackinfo; si; si = si->si_prev) { 3025 I32 ix; 3026 for (ix = si->si_cxix; ix >= 0; ix--) { 3027 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]); 3028 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 3029 CV * const cv = cx->blk_sub.cv; 3030 /* skip DB:: code */ 3031 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) { 3032 *db_seqp = cx->blk_oldcop->cop_seq; 3033 continue; 3034 } 3035 return cv; 3036 } 3037 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) 3038 return PL_compcv; 3039 } 3040 } 3041 return PL_main_cv; 3042 } 3043 3044 3045 /* Compile a require/do, an eval '', or a /(?{...})/. 3046 * In the last case, startop is non-null, and contains the address of 3047 * a pointer that should be set to the just-compiled code. 3048 * outside is the lexically enclosing CV (if any) that invoked us. 3049 * Returns a bool indicating whether the compile was successful; if so, 3050 * PL_eval_start contains the first op of the compiled ocde; otherwise, 3051 * pushes undef (also croaks if startop != NULL). 3052 */ 3053 3054 STATIC bool 3055 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) 3056 { 3057 dVAR; dSP; 3058 OP * const saveop = PL_op; 3059 3060 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) 3061 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) 3062 : EVAL_INEVAL); 3063 3064 PUSHMARK(SP); 3065 3066 SAVESPTR(PL_compcv); 3067 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV)); 3068 CvEVAL_on(PL_compcv); 3069 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); 3070 cxstack[cxstack_ix].blk_eval.cv = PL_compcv; 3071 3072 CvOUTSIDE_SEQ(PL_compcv) = seq; 3073 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); 3074 3075 /* set up a scratch pad */ 3076 3077 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE); 3078 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */ 3079 3080 3081 if (!PL_madskills) 3082 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ 3083 3084 /* make sure we compile in the right package */ 3085 3086 if (CopSTASH_ne(PL_curcop, PL_curstash)) { 3087 SAVESPTR(PL_curstash); 3088 PL_curstash = CopSTASH(PL_curcop); 3089 } 3090 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */ 3091 SAVESPTR(PL_beginav); 3092 PL_beginav = newAV(); 3093 SAVEFREESV(PL_beginav); 3094 SAVESPTR(PL_unitcheckav); 3095 PL_unitcheckav = newAV(); 3096 SAVEFREESV(PL_unitcheckav); 3097 3098 #ifdef PERL_MAD 3099 SAVEBOOL(PL_madskills); 3100 PL_madskills = 0; 3101 #endif 3102 3103 /* try to compile it */ 3104 3105 PL_eval_root = NULL; 3106 PL_curcop = &PL_compiling; 3107 CopARYBASE_set(PL_curcop, 0); 3108 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL)) 3109 PL_in_eval |= EVAL_KEEPERR; 3110 else 3111 CLEAR_ERRSV(); 3112 if (yyparse() || PL_parser->error_count || !PL_eval_root) { 3113 SV **newsp; /* Used by POPBLOCK. */ 3114 PERL_CONTEXT *cx = NULL; 3115 I32 optype = 0; /* Might be reset by POPEVAL. */ 3116 SV *namesv = NULL; 3117 const char *msg; 3118 3119 PL_op = saveop; 3120 if (PL_eval_root) { 3121 op_free(PL_eval_root); 3122 PL_eval_root = NULL; 3123 } 3124 SP = PL_stack_base + POPMARK; /* pop original mark */ 3125 if (!startop) { 3126 POPBLOCK(cx,PL_curpm); 3127 POPEVAL(cx); 3128 namesv = cx->blk_eval.old_namesv; 3129 } 3130 lex_end(); 3131 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */ 3132 3133 msg = SvPVx_nolen_const(ERRSV); 3134 if (optype == OP_REQUIRE) { 3135 if (!cx) { 3136 /* If cx is still NULL, it means that we didn't go in the 3137 * POPEVAL branch. */ 3138 cx = &cxstack[cxstack_ix]; 3139 assert(CxTYPE(cx) == CXt_EVAL); 3140 namesv = cx->blk_eval.old_namesv; 3141 } 3142 (void)hv_store(GvHVn(PL_incgv), 3143 SvPVX_const(namesv), SvCUR(namesv), 3144 &PL_sv_undef, 0); 3145 Perl_croak(aTHX_ "%sCompilation failed in require", 3146 *msg ? msg : "Unknown error\n"); 3147 } 3148 else if (startop) { 3149 POPBLOCK(cx,PL_curpm); 3150 POPEVAL(cx); 3151 Perl_croak(aTHX_ "%sCompilation failed in regexp", 3152 (*msg ? msg : "Unknown error\n")); 3153 } 3154 else { 3155 if (!*msg) { 3156 sv_setpvs(ERRSV, "Compilation error"); 3157 } 3158 } 3159 PERL_UNUSED_VAR(newsp); 3160 PUSHs(&PL_sv_undef); 3161 PUTBACK; 3162 return FALSE; 3163 } 3164 CopLINE_set(&PL_compiling, 0); 3165 if (startop) { 3166 *startop = PL_eval_root; 3167 } else 3168 SAVEFREEOP(PL_eval_root); 3169 3170 /* Set the context for this new optree. 3171 * Propagate the context from the eval(). */ 3172 if ((gimme & G_WANT) == G_VOID) 3173 scalarvoid(PL_eval_root); 3174 else if ((gimme & G_WANT) == G_ARRAY) 3175 list(PL_eval_root); 3176 else 3177 scalar(PL_eval_root); 3178 3179 DEBUG_x(dump_eval()); 3180 3181 /* Register with debugger: */ 3182 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) { 3183 CV * const cv = get_cvs("DB::postponed", 0); 3184 if (cv) { 3185 dSP; 3186 PUSHMARK(SP); 3187 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); 3188 PUTBACK; 3189 call_sv(MUTABLE_SV(cv), G_DISCARD); 3190 } 3191 } 3192 3193 if (PL_unitcheckav) 3194 call_list(PL_scopestack_ix, PL_unitcheckav); 3195 3196 /* compiled okay, so do it */ 3197 3198 CvDEPTH(PL_compcv) = 1; 3199 SP = PL_stack_base + POPMARK; /* pop original mark */ 3200 PL_op = saveop; /* The caller may need it. */ 3201 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */ 3202 3203 PUTBACK; 3204 return TRUE; 3205 } 3206 3207 STATIC PerlIO * 3208 S_check_type_and_open(pTHX_ const char *name) 3209 { 3210 Stat_t st; 3211 const int st_rc = PerlLIO_stat(name, &st); 3212 3213 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN; 3214 3215 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { 3216 return NULL; 3217 } 3218 3219 return PerlIO_open(name, PERL_SCRIPT_MODE); 3220 } 3221 3222 #ifndef PERL_DISABLE_PMC 3223 STATIC PerlIO * 3224 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen) 3225 { 3226 PerlIO *fp; 3227 3228 PERL_ARGS_ASSERT_DOOPEN_PM; 3229 3230 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) { 3231 SV *const pmcsv = newSV(namelen + 2); 3232 char *const pmc = SvPVX(pmcsv); 3233 Stat_t pmcstat; 3234 3235 memcpy(pmc, name, namelen); 3236 pmc[namelen] = 'c'; 3237 pmc[namelen + 1] = '\0'; 3238 3239 if (PerlLIO_stat(pmc, &pmcstat) < 0) { 3240 fp = check_type_and_open(name); 3241 } 3242 else { 3243 fp = check_type_and_open(pmc); 3244 } 3245 SvREFCNT_dec(pmcsv); 3246 } 3247 else { 3248 fp = check_type_and_open(name); 3249 } 3250 return fp; 3251 } 3252 #else 3253 # define doopen_pm(name, namelen) check_type_and_open(name) 3254 #endif /* !PERL_DISABLE_PMC */ 3255 3256 PP(pp_require) 3257 { 3258 dVAR; dSP; 3259 register PERL_CONTEXT *cx; 3260 SV *sv; 3261 const char *name; 3262 STRLEN len; 3263 char * unixname; 3264 STRLEN unixlen; 3265 #ifdef VMS 3266 int vms_unixname = 0; 3267 #endif 3268 const char *tryname = NULL; 3269 SV *namesv = NULL; 3270 const I32 gimme = GIMME_V; 3271 int filter_has_file = 0; 3272 PerlIO *tryrsfp = NULL; 3273 SV *filter_cache = NULL; 3274 SV *filter_state = NULL; 3275 SV *filter_sub = NULL; 3276 SV *hook_sv = NULL; 3277 SV *encoding; 3278 OP *op; 3279 3280 sv = POPs; 3281 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) { 3282 sv = new_version(sv); 3283 if (!sv_derived_from(PL_patchlevel, "version")) 3284 upg_version(PL_patchlevel, TRUE); 3285 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { 3286 if ( vcmp(sv,PL_patchlevel) <= 0 ) 3287 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped", 3288 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel))); 3289 } 3290 else { 3291 if ( vcmp(sv,PL_patchlevel) > 0 ) { 3292 I32 first = 0; 3293 AV *lav; 3294 SV * const req = SvRV(sv); 3295 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE); 3296 3297 /* get the left hand term */ 3298 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE))); 3299 3300 first = SvIV(*av_fetch(lav,0,0)); 3301 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */ 3302 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */ 3303 || av_len(lav) > 1 /* FP with > 3 digits */ 3304 || strstr(SvPVX(pv),".0") /* FP with leading 0 */ 3305 ) { 3306 DIE(aTHX_ "Perl %"SVf" required--this is only " 3307 "%"SVf", stopped", SVfARG(vnormal(req)), 3308 SVfARG(vnormal(PL_patchlevel))); 3309 } 3310 else { /* probably 'use 5.10' or 'use 5.8' */ 3311 SV *hintsv; 3312 I32 second = 0; 3313 3314 if (av_len(lav)>=1) 3315 second = SvIV(*av_fetch(lav,1,0)); 3316 3317 second /= second >= 600 ? 100 : 10; 3318 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0", 3319 (int)first, (int)second); 3320 upg_version(hintsv, TRUE); 3321 3322 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)" 3323 "--this is only %"SVf", stopped", 3324 SVfARG(vnormal(req)), 3325 SVfARG(vnormal(sv_2mortal(hintsv))), 3326 SVfARG(vnormal(PL_patchlevel))); 3327 } 3328 } 3329 } 3330 3331 /* We do this only with "use", not "require" or "no". */ 3332 if (PL_compcv && !(cUNOP->op_first->op_private & OPpCONST_NOVER)) { 3333 /* If we request a version >= 5.9.5, load feature.pm with the 3334 * feature bundle that corresponds to the required version. */ 3335 if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) { 3336 SV *const importsv = vnormal(sv); 3337 *SvPVX_mutable(importsv) = ':'; 3338 ENTER_with_name("load_feature"); 3339 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL); 3340 LEAVE_with_name("load_feature"); 3341 } 3342 /* If a version >= 5.11.0 is requested, strictures are on by default! */ 3343 if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) { 3344 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS); 3345 } 3346 } 3347 3348 RETPUSHYES; 3349 } 3350 name = SvPV_const(sv, len); 3351 if (!(name && len > 0 && *name)) 3352 DIE(aTHX_ "Null filename used"); 3353 TAINT_PROPER("require"); 3354 3355 3356 #ifdef VMS 3357 /* The key in the %ENV hash is in the syntax of file passed as the argument 3358 * usually this is in UNIX format, but sometimes in VMS format, which 3359 * can result in a module being pulled in more than once. 3360 * To prevent this, the key must be stored in UNIX format if the VMS 3361 * name can be translated to UNIX. 3362 */ 3363 if ((unixname = tounixspec(name, NULL)) != NULL) { 3364 unixlen = strlen(unixname); 3365 vms_unixname = 1; 3366 } 3367 else 3368 #endif 3369 { 3370 /* if not VMS or VMS name can not be translated to UNIX, pass it 3371 * through. 3372 */ 3373 unixname = (char *) name; 3374 unixlen = len; 3375 } 3376 if (PL_op->op_type == OP_REQUIRE) { 3377 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), 3378 unixname, unixlen, 0); 3379 if ( svp ) { 3380 if (*svp != &PL_sv_undef) 3381 RETPUSHYES; 3382 else 3383 DIE(aTHX_ "Attempt to reload %s aborted.\n" 3384 "Compilation failed in require", unixname); 3385 } 3386 } 3387 3388 /* prepare to compile file */ 3389 3390 if (path_is_absolute(name)) { 3391 tryname = name; 3392 tryrsfp = doopen_pm(name, len); 3393 } 3394 if (!tryrsfp) { 3395 AV * const ar = GvAVn(PL_incgv); 3396 I32 i; 3397 #ifdef VMS 3398 if (vms_unixname) 3399 #endif 3400 { 3401 namesv = newSV_type(SVt_PV); 3402 for (i = 0; i <= AvFILL(ar); i++) { 3403 SV * const dirsv = *av_fetch(ar, i, TRUE); 3404 3405 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied)) 3406 mg_get(dirsv); 3407 if (SvROK(dirsv)) { 3408 int count; 3409 SV **svp; 3410 SV *loader = dirsv; 3411 3412 if (SvTYPE(SvRV(loader)) == SVt_PVAV 3413 && !sv_isobject(loader)) 3414 { 3415 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE); 3416 } 3417 3418 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", 3419 PTR2UV(SvRV(dirsv)), name); 3420 tryname = SvPVX_const(namesv); 3421 tryrsfp = NULL; 3422 3423 ENTER_with_name("call_INC"); 3424 SAVETMPS; 3425 EXTEND(SP, 2); 3426 3427 PUSHMARK(SP); 3428 PUSHs(dirsv); 3429 PUSHs(sv); 3430 PUTBACK; 3431 if (sv_isobject(loader)) 3432 count = call_method("INC", G_ARRAY); 3433 else 3434 count = call_sv(loader, G_ARRAY); 3435 SPAGAIN; 3436 3437 if (count > 0) { 3438 int i = 0; 3439 SV *arg; 3440 3441 SP -= count - 1; 3442 arg = SP[i++]; 3443 3444 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV) 3445 && !isGV_with_GP(SvRV(arg))) { 3446 filter_cache = SvRV(arg); 3447 SvREFCNT_inc_simple_void_NN(filter_cache); 3448 3449 if (i < count) { 3450 arg = SP[i++]; 3451 } 3452 } 3453 3454 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) { 3455 arg = SvRV(arg); 3456 } 3457 3458 if (isGV_with_GP(arg)) { 3459 IO * const io = GvIO((const GV *)arg); 3460 3461 ++filter_has_file; 3462 3463 if (io) { 3464 tryrsfp = IoIFP(io); 3465 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { 3466 PerlIO_close(IoOFP(io)); 3467 } 3468 IoIFP(io) = NULL; 3469 IoOFP(io) = NULL; 3470 } 3471 3472 if (i < count) { 3473 arg = SP[i++]; 3474 } 3475 } 3476 3477 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) { 3478 filter_sub = arg; 3479 SvREFCNT_inc_simple_void_NN(filter_sub); 3480 3481 if (i < count) { 3482 filter_state = SP[i]; 3483 SvREFCNT_inc_simple_void(filter_state); 3484 } 3485 } 3486 3487 if (!tryrsfp && (filter_cache || filter_sub)) { 3488 tryrsfp = PerlIO_open(BIT_BUCKET, 3489 PERL_SCRIPT_MODE); 3490 } 3491 SP--; 3492 } 3493 3494 PUTBACK; 3495 FREETMPS; 3496 LEAVE_with_name("call_INC"); 3497 3498 /* Adjust file name if the hook has set an %INC entry. 3499 This needs to happen after the FREETMPS above. */ 3500 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); 3501 if (svp) 3502 tryname = SvPV_nolen_const(*svp); 3503 3504 if (tryrsfp) { 3505 hook_sv = dirsv; 3506 break; 3507 } 3508 3509 filter_has_file = 0; 3510 if (filter_cache) { 3511 SvREFCNT_dec(filter_cache); 3512 filter_cache = NULL; 3513 } 3514 if (filter_state) { 3515 SvREFCNT_dec(filter_state); 3516 filter_state = NULL; 3517 } 3518 if (filter_sub) { 3519 SvREFCNT_dec(filter_sub); 3520 filter_sub = NULL; 3521 } 3522 } 3523 else { 3524 if (!path_is_absolute(name) 3525 ) { 3526 const char *dir; 3527 STRLEN dirlen; 3528 3529 if (SvOK(dirsv)) { 3530 dir = SvPV_const(dirsv, dirlen); 3531 } else { 3532 dir = ""; 3533 dirlen = 0; 3534 } 3535 3536 #ifdef VMS 3537 char *unixdir; 3538 if ((unixdir = tounixpath(dir, NULL)) == NULL) 3539 continue; 3540 sv_setpv(namesv, unixdir); 3541 sv_catpv(namesv, unixname); 3542 #else 3543 # ifdef __SYMBIAN32__ 3544 if (PL_origfilename[0] && 3545 PL_origfilename[1] == ':' && 3546 !(dir[0] && dir[1] == ':')) 3547 Perl_sv_setpvf(aTHX_ namesv, 3548 "%c:%s\\%s", 3549 PL_origfilename[0], 3550 dir, name); 3551 else 3552 Perl_sv_setpvf(aTHX_ namesv, 3553 "%s\\%s", 3554 dir, name); 3555 # else 3556 /* The equivalent of 3557 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); 3558 but without the need to parse the format string, or 3559 call strlen on either pointer, and with the correct 3560 allocation up front. */ 3561 { 3562 char *tmp = SvGROW(namesv, dirlen + len + 2); 3563 3564 memcpy(tmp, dir, dirlen); 3565 tmp +=dirlen; 3566 *tmp++ = '/'; 3567 /* name came from an SV, so it will have a '\0' at the 3568 end that we can copy as part of this memcpy(). */ 3569 memcpy(tmp, name, len + 1); 3570 3571 SvCUR_set(namesv, dirlen + len + 1); 3572 3573 /* Don't even actually have to turn SvPOK_on() as we 3574 access it directly with SvPVX() below. */ 3575 } 3576 # endif 3577 #endif 3578 TAINT_PROPER("require"); 3579 tryname = SvPVX_const(namesv); 3580 tryrsfp = doopen_pm(tryname, SvCUR(namesv)); 3581 if (tryrsfp) { 3582 if (tryname[0] == '.' && tryname[1] == '/') { 3583 ++tryname; 3584 while (*++tryname == '/'); 3585 } 3586 break; 3587 } 3588 else if (errno == EMFILE) 3589 /* no point in trying other paths if out of handles */ 3590 break; 3591 } 3592 } 3593 } 3594 } 3595 } 3596 SAVECOPFILE_FREE(&PL_compiling); 3597 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name); 3598 SvREFCNT_dec(namesv); 3599 if (!tryrsfp) { 3600 if (PL_op->op_type == OP_REQUIRE) { 3601 const char *msgstr = name; 3602 if(errno == EMFILE) { 3603 SV * const msg 3604 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr, 3605 Strerror(errno))); 3606 msgstr = SvPV_nolen_const(msg); 3607 } else { 3608 if (namesv) { /* did we lookup @INC? */ 3609 AV * const ar = GvAVn(PL_incgv); 3610 I32 i; 3611 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_ 3612 "%s in @INC%s%s (@INC contains:", 3613 msgstr, 3614 (instr(msgstr, ".h ") 3615 ? " (change .h to .ph maybe?)" : ""), 3616 (instr(msgstr, ".ph ") 3617 ? " (did you run h2ph?)" : "") 3618 )); 3619 3620 for (i = 0; i <= AvFILL(ar); i++) { 3621 sv_catpvs(msg, " "); 3622 sv_catsv(msg, *av_fetch(ar, i, TRUE)); 3623 } 3624 sv_catpvs(msg, ")"); 3625 msgstr = SvPV_nolen_const(msg); 3626 } 3627 } 3628 DIE(aTHX_ "Can't locate %s", msgstr); 3629 } 3630 3631 RETPUSHUNDEF; 3632 } 3633 else 3634 SETERRNO(0, SS_NORMAL); 3635 3636 /* Assume success here to prevent recursive requirement. */ 3637 /* name is never assigned to again, so len is still strlen(name) */ 3638 /* Check whether a hook in @INC has already filled %INC */ 3639 if (!hook_sv) { 3640 (void)hv_store(GvHVn(PL_incgv), 3641 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0); 3642 } else { 3643 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); 3644 if (!svp) 3645 (void)hv_store(GvHVn(PL_incgv), 3646 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 ); 3647 } 3648 3649 ENTER_with_name("eval"); 3650 SAVETMPS; 3651 lex_start(NULL, tryrsfp, TRUE); 3652 3653 SAVEHINTS(); 3654 PL_hints = 0; 3655 hv_clear(GvHV(PL_hintgv)); 3656 3657 SAVECOMPILEWARNINGS(); 3658 if (PL_dowarn & G_WARN_ALL_ON) 3659 PL_compiling.cop_warnings = pWARN_ALL ; 3660 else if (PL_dowarn & G_WARN_ALL_OFF) 3661 PL_compiling.cop_warnings = pWARN_NONE ; 3662 else 3663 PL_compiling.cop_warnings = pWARN_STD ; 3664 3665 if (filter_sub || filter_cache) { 3666 /* We can use the SvPV of the filter PVIO itself as our cache, rather 3667 than hanging another SV from it. In turn, filter_add() optionally 3668 takes the SV to use as the filter (or creates a new SV if passed 3669 NULL), so simply pass in whatever value filter_cache has. */ 3670 SV * const datasv = filter_add(S_run_user_filter, filter_cache); 3671 IoLINES(datasv) = filter_has_file; 3672 IoTOP_GV(datasv) = MUTABLE_GV(filter_state); 3673 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub); 3674 } 3675 3676 /* switch to eval mode */ 3677 PUSHBLOCK(cx, CXt_EVAL, SP); 3678 PUSHEVAL(cx, name); 3679 cx->blk_eval.retop = PL_op->op_next; 3680 3681 SAVECOPLINE(&PL_compiling); 3682 CopLINE_set(&PL_compiling, 0); 3683 3684 PUTBACK; 3685 3686 /* Store and reset encoding. */ 3687 encoding = PL_encoding; 3688 PL_encoding = NULL; 3689 3690 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq)) 3691 op = DOCATCH(PL_eval_start); 3692 else 3693 op = PL_op->op_next; 3694 3695 /* Restore encoding. */ 3696 PL_encoding = encoding; 3697 3698 return op; 3699 } 3700 3701 /* This is a op added to hold the hints hash for 3702 pp_entereval. The hash can be modified by the code 3703 being eval'ed, so we return a copy instead. */ 3704 3705 PP(pp_hintseval) 3706 { 3707 dVAR; 3708 dSP; 3709 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv)))); 3710 RETURN; 3711 } 3712 3713 3714 PP(pp_entereval) 3715 { 3716 dVAR; dSP; 3717 register PERL_CONTEXT *cx; 3718 SV *sv; 3719 const I32 gimme = GIMME_V; 3720 const U32 was = PL_breakable_sub_gen; 3721 char tbuf[TYPE_DIGITS(long) + 12]; 3722 char *tmpbuf = tbuf; 3723 STRLEN len; 3724 CV* runcv; 3725 U32 seq; 3726 HV *saved_hh = NULL; 3727 3728 if (PL_op->op_private & OPpEVAL_HAS_HH) { 3729 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs)); 3730 } 3731 sv = POPs; 3732 3733 TAINT_IF(SvTAINTED(sv)); 3734 TAINT_PROPER("eval"); 3735 3736 ENTER_with_name("eval"); 3737 lex_start(sv, NULL, FALSE); 3738 SAVETMPS; 3739 3740 /* switch to eval mode */ 3741 3742 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { 3743 SV * const temp_sv = sv_newmortal(); 3744 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]", 3745 (unsigned long)++PL_evalseq, 3746 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 3747 tmpbuf = SvPVX(temp_sv); 3748 len = SvCUR(temp_sv); 3749 } 3750 else 3751 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq); 3752 SAVECOPFILE_FREE(&PL_compiling); 3753 CopFILE_set(&PL_compiling, tmpbuf+2); 3754 SAVECOPLINE(&PL_compiling); 3755 CopLINE_set(&PL_compiling, 1); 3756 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up 3757 deleting the eval's FILEGV from the stash before gv_check() runs 3758 (i.e. before run-time proper). To work around the coredump that 3759 ensues, we always turn GvMULTI_on for any globals that were 3760 introduced within evals. See force_ident(). GSAR 96-10-12 */ 3761 SAVEHINTS(); 3762 PL_hints = PL_op->op_targ; 3763 if (saved_hh) { 3764 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ 3765 SvREFCNT_dec(GvHV(PL_hintgv)); 3766 GvHV(PL_hintgv) = saved_hh; 3767 } 3768 SAVECOMPILEWARNINGS(); 3769 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); 3770 if (PL_compiling.cop_hints_hash) { 3771 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); 3772 } 3773 if (Perl_fetch_cop_label(aTHX_ PL_curcop->cop_hints_hash, NULL, NULL)) { 3774 /* The label, if present, is the first entry on the chain. So rather 3775 than writing a blank label in front of it (which involves an 3776 allocation), just use the next entry in the chain. */ 3777 PL_compiling.cop_hints_hash 3778 = PL_curcop->cop_hints_hash->refcounted_he_next; 3779 /* Check the assumption that this removed the label. */ 3780 assert(Perl_fetch_cop_label(aTHX_ PL_compiling.cop_hints_hash, NULL, 3781 NULL) == NULL); 3782 } 3783 else 3784 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash; 3785 if (PL_compiling.cop_hints_hash) { 3786 HINTS_REFCNT_LOCK; 3787 PL_compiling.cop_hints_hash->refcounted_he_refcnt++; 3788 HINTS_REFCNT_UNLOCK; 3789 } 3790 /* special case: an eval '' executed within the DB package gets lexically 3791 * placed in the first non-DB CV rather than the current CV - this 3792 * allows the debugger to execute code, find lexicals etc, in the 3793 * scope of the code being debugged. Passing &seq gets find_runcv 3794 * to do the dirty work for us */ 3795 runcv = find_runcv(&seq); 3796 3797 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); 3798 PUSHEVAL(cx, 0); 3799 cx->blk_eval.retop = PL_op->op_next; 3800 3801 /* prepare to compile string */ 3802 3803 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) 3804 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr); 3805 PUTBACK; 3806 3807 if (doeval(gimme, NULL, runcv, seq)) { 3808 if (was != PL_breakable_sub_gen /* Some subs defined here. */ 3809 ? (PERLDB_LINE || PERLDB_SAVESRC) 3810 : PERLDB_SAVESRC_NOSUBS) { 3811 /* Retain the filegv we created. */ 3812 } else { 3813 char *const safestr = savepvn(tmpbuf, len); 3814 SAVEDELETE(PL_defstash, safestr, len); 3815 } 3816 return DOCATCH(PL_eval_start); 3817 } else { 3818 /* We have already left the scope set up earler thanks to the LEAVE 3819 in doeval(). */ 3820 if (was != PL_breakable_sub_gen /* Some subs defined here. */ 3821 ? (PERLDB_LINE || PERLDB_SAVESRC) 3822 : PERLDB_SAVESRC_INVALID) { 3823 /* Retain the filegv we created. */ 3824 } else { 3825 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD); 3826 } 3827 return PL_op->op_next; 3828 } 3829 } 3830 3831 PP(pp_leaveeval) 3832 { 3833 dVAR; dSP; 3834 register SV **mark; 3835 SV **newsp; 3836 PMOP *newpm; 3837 I32 gimme; 3838 register PERL_CONTEXT *cx; 3839 OP *retop; 3840 const U8 save_flags = PL_op -> op_flags; 3841 I32 optype; 3842 SV *namesv; 3843 3844 POPBLOCK(cx,newpm); 3845 POPEVAL(cx); 3846 namesv = cx->blk_eval.old_namesv; 3847 retop = cx->blk_eval.retop; 3848 3849 TAINT_NOT; 3850 if (gimme == G_VOID) 3851 MARK = newsp; 3852 else if (gimme == G_SCALAR) { 3853 MARK = newsp + 1; 3854 if (MARK <= SP) { 3855 if (SvFLAGS(TOPs) & SVs_TEMP) 3856 *MARK = TOPs; 3857 else 3858 *MARK = sv_mortalcopy(TOPs); 3859 } 3860 else { 3861 MEXTEND(mark,0); 3862 *MARK = &PL_sv_undef; 3863 } 3864 SP = MARK; 3865 } 3866 else { 3867 /* in case LEAVE wipes old return values */ 3868 for (mark = newsp + 1; mark <= SP; mark++) { 3869 if (!(SvFLAGS(*mark) & SVs_TEMP)) { 3870 *mark = sv_mortalcopy(*mark); 3871 TAINT_NOT; /* Each item is independent */ 3872 } 3873 } 3874 } 3875 PL_curpm = newpm; /* Don't pop $1 et al till now */ 3876 3877 #ifdef DEBUGGING 3878 assert(CvDEPTH(PL_compcv) == 1); 3879 #endif 3880 CvDEPTH(PL_compcv) = 0; 3881 lex_end(); 3882 3883 if (optype == OP_REQUIRE && 3884 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) 3885 { 3886 /* Unassume the success we assumed earlier. */ 3887 (void)hv_delete(GvHVn(PL_incgv), 3888 SvPVX_const(namesv), SvCUR(namesv), 3889 G_DISCARD); 3890 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", 3891 SVfARG(namesv)); 3892 /* die_where() did LEAVE, or we won't be here */ 3893 } 3894 else { 3895 LEAVE_with_name("eval"); 3896 if (!(save_flags & OPf_SPECIAL)) { 3897 CLEAR_ERRSV(); 3898 } 3899 } 3900 3901 RETURNOP(retop); 3902 } 3903 3904 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it 3905 close to the related Perl_create_eval_scope. */ 3906 void 3907 Perl_delete_eval_scope(pTHX) 3908 { 3909 SV **newsp; 3910 PMOP *newpm; 3911 I32 gimme; 3912 register PERL_CONTEXT *cx; 3913 I32 optype; 3914 3915 POPBLOCK(cx,newpm); 3916 POPEVAL(cx); 3917 PL_curpm = newpm; 3918 LEAVE_with_name("eval_scope"); 3919 PERL_UNUSED_VAR(newsp); 3920 PERL_UNUSED_VAR(gimme); 3921 PERL_UNUSED_VAR(optype); 3922 } 3923 3924 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was 3925 also needed by Perl_fold_constants. */ 3926 PERL_CONTEXT * 3927 Perl_create_eval_scope(pTHX_ U32 flags) 3928 { 3929 PERL_CONTEXT *cx; 3930 const I32 gimme = GIMME_V; 3931 3932 ENTER_with_name("eval_scope"); 3933 SAVETMPS; 3934 3935 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); 3936 PUSHEVAL(cx, 0); 3937 3938 PL_in_eval = EVAL_INEVAL; 3939 if (flags & G_KEEPERR) 3940 PL_in_eval |= EVAL_KEEPERR; 3941 else 3942 CLEAR_ERRSV(); 3943 if (flags & G_FAKINGEVAL) { 3944 PL_eval_root = PL_op; /* Only needed so that goto works right. */ 3945 } 3946 return cx; 3947 } 3948 3949 PP(pp_entertry) 3950 { 3951 dVAR; 3952 PERL_CONTEXT * const cx = create_eval_scope(0); 3953 cx->blk_eval.retop = cLOGOP->op_other->op_next; 3954 return DOCATCH(PL_op->op_next); 3955 } 3956 3957 PP(pp_leavetry) 3958 { 3959 dVAR; dSP; 3960 SV **newsp; 3961 PMOP *newpm; 3962 I32 gimme; 3963 register PERL_CONTEXT *cx; 3964 I32 optype; 3965 3966 POPBLOCK(cx,newpm); 3967 POPEVAL(cx); 3968 PERL_UNUSED_VAR(optype); 3969 3970 TAINT_NOT; 3971 if (gimme == G_VOID) 3972 SP = newsp; 3973 else if (gimme == G_SCALAR) { 3974 register SV **mark; 3975 MARK = newsp + 1; 3976 if (MARK <= SP) { 3977 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) 3978 *MARK = TOPs; 3979 else 3980 *MARK = sv_mortalcopy(TOPs); 3981 } 3982 else { 3983 MEXTEND(mark,0); 3984 *MARK = &PL_sv_undef; 3985 } 3986 SP = MARK; 3987 } 3988 else { 3989 /* in case LEAVE wipes old return values */ 3990 register SV **mark; 3991 for (mark = newsp + 1; mark <= SP; mark++) { 3992 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { 3993 *mark = sv_mortalcopy(*mark); 3994 TAINT_NOT; /* Each item is independent */ 3995 } 3996 } 3997 } 3998 PL_curpm = newpm; /* Don't pop $1 et al till now */ 3999 4000 LEAVE_with_name("eval_scope"); 4001 CLEAR_ERRSV(); 4002 RETURN; 4003 } 4004 4005 PP(pp_entergiven) 4006 { 4007 dVAR; dSP; 4008 register PERL_CONTEXT *cx; 4009 const I32 gimme = GIMME_V; 4010 4011 ENTER_with_name("given"); 4012 SAVETMPS; 4013 4014 sv_setsv(PAD_SV(PL_op->op_targ), POPs); 4015 4016 PUSHBLOCK(cx, CXt_GIVEN, SP); 4017 PUSHGIVEN(cx); 4018 4019 RETURN; 4020 } 4021 4022 PP(pp_leavegiven) 4023 { 4024 dVAR; dSP; 4025 register PERL_CONTEXT *cx; 4026 I32 gimme; 4027 SV **newsp; 4028 PMOP *newpm; 4029 PERL_UNUSED_CONTEXT; 4030 4031 POPBLOCK(cx,newpm); 4032 assert(CxTYPE(cx) == CXt_GIVEN); 4033 4034 SP = newsp; 4035 PUTBACK; 4036 4037 PL_curpm = newpm; /* pop $1 et al */ 4038 4039 LEAVE_with_name("given"); 4040 4041 return NORMAL; 4042 } 4043 4044 /* Helper routines used by pp_smartmatch */ 4045 STATIC PMOP * 4046 S_make_matcher(pTHX_ REGEXP *re) 4047 { 4048 dVAR; 4049 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED); 4050 4051 PERL_ARGS_ASSERT_MAKE_MATCHER; 4052 4053 PM_SETRE(matcher, ReREFCNT_inc(re)); 4054 4055 SAVEFREEOP((OP *) matcher); 4056 ENTER_with_name("matcher"); SAVETMPS; 4057 SAVEOP(); 4058 return matcher; 4059 } 4060 4061 STATIC bool 4062 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) 4063 { 4064 dVAR; 4065 dSP; 4066 4067 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV; 4068 4069 PL_op = (OP *) matcher; 4070 XPUSHs(sv); 4071 PUTBACK; 4072 (void) pp_match(); 4073 SPAGAIN; 4074 return (SvTRUEx(POPs)); 4075 } 4076 4077 STATIC void 4078 S_destroy_matcher(pTHX_ PMOP *matcher) 4079 { 4080 dVAR; 4081 4082 PERL_ARGS_ASSERT_DESTROY_MATCHER; 4083 PERL_UNUSED_ARG(matcher); 4084 4085 FREETMPS; 4086 LEAVE_with_name("matcher"); 4087 } 4088 4089 /* Do a smart match */ 4090 PP(pp_smartmatch) 4091 { 4092 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n")); 4093 return do_smartmatch(NULL, NULL); 4094 } 4095 4096 /* This version of do_smartmatch() implements the 4097 * table of smart matches that is found in perlsyn. 4098 */ 4099 STATIC OP * 4100 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) 4101 { 4102 dVAR; 4103 dSP; 4104 4105 bool object_on_left = FALSE; 4106 SV *e = TOPs; /* e is for 'expression' */ 4107 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */ 4108 4109 /* First of all, handle overload magic of the rightmost argument */ 4110 if (SvAMAGIC(e)) { 4111 SV * tmpsv; 4112 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); 4113 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); 4114 4115 tmpsv = amagic_call(d, e, smart_amg, 0); 4116 if (tmpsv) { 4117 SPAGAIN; 4118 (void)POPs; 4119 SETs(tmpsv); 4120 RETURN; 4121 } 4122 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n")); 4123 } 4124 4125 SP -= 2; /* Pop the values */ 4126 4127 /* Take care only to invoke mg_get() once for each argument. 4128 * Currently we do this by copying the SV if it's magical. */ 4129 if (d) { 4130 if (SvGMAGICAL(d)) 4131 d = sv_mortalcopy(d); 4132 } 4133 else 4134 d = &PL_sv_undef; 4135 4136 assert(e); 4137 if (SvGMAGICAL(e)) 4138 e = sv_mortalcopy(e); 4139 4140 /* ~~ undef */ 4141 if (!SvOK(e)) { 4142 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n")); 4143 if (SvOK(d)) 4144 RETPUSHNO; 4145 else 4146 RETPUSHYES; 4147 } 4148 4149 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) { 4150 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); 4151 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation"); 4152 } 4153 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) 4154 object_on_left = TRUE; 4155 4156 /* ~~ sub */ 4157 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) { 4158 I32 c; 4159 if (object_on_left) { 4160 goto sm_any_sub; /* Treat objects like scalars */ 4161 } 4162 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { 4163 /* Test sub truth for each key */ 4164 HE *he; 4165 bool andedresults = TRUE; 4166 HV *hv = (HV*) SvRV(d); 4167 I32 numkeys = hv_iterinit(hv); 4168 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n")); 4169 if (numkeys == 0) 4170 RETPUSHYES; 4171 while ( (he = hv_iternext(hv)) ) { 4172 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n")); 4173 ENTER_with_name("smartmatch_hash_key_test"); 4174 SAVETMPS; 4175 PUSHMARK(SP); 4176 PUSHs(hv_iterkeysv(he)); 4177 PUTBACK; 4178 c = call_sv(e, G_SCALAR); 4179 SPAGAIN; 4180 if (c == 0) 4181 andedresults = FALSE; 4182 else 4183 andedresults = SvTRUEx(POPs) && andedresults; 4184 FREETMPS; 4185 LEAVE_with_name("smartmatch_hash_key_test"); 4186 } 4187 if (andedresults) 4188 RETPUSHYES; 4189 else 4190 RETPUSHNO; 4191 } 4192 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { 4193 /* Test sub truth for each element */ 4194 I32 i; 4195 bool andedresults = TRUE; 4196 AV *av = (AV*) SvRV(d); 4197 const I32 len = av_len(av); 4198 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n")); 4199 if (len == -1) 4200 RETPUSHYES; 4201 for (i = 0; i <= len; ++i) { 4202 SV * const * const svp = av_fetch(av, i, FALSE); 4203 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n")); 4204 ENTER_with_name("smartmatch_array_elem_test"); 4205 SAVETMPS; 4206 PUSHMARK(SP); 4207 if (svp) 4208 PUSHs(*svp); 4209 PUTBACK; 4210 c = call_sv(e, G_SCALAR); 4211 SPAGAIN; 4212 if (c == 0) 4213 andedresults = FALSE; 4214 else 4215 andedresults = SvTRUEx(POPs) && andedresults; 4216 FREETMPS; 4217 LEAVE_with_name("smartmatch_array_elem_test"); 4218 } 4219 if (andedresults) 4220 RETPUSHYES; 4221 else 4222 RETPUSHNO; 4223 } 4224 else { 4225 sm_any_sub: 4226 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n")); 4227 ENTER_with_name("smartmatch_coderef"); 4228 SAVETMPS; 4229 PUSHMARK(SP); 4230 PUSHs(d); 4231 PUTBACK; 4232 c = call_sv(e, G_SCALAR); 4233 SPAGAIN; 4234 if (c == 0) 4235 PUSHs(&PL_sv_no); 4236 else if (SvTEMP(TOPs)) 4237 SvREFCNT_inc_void(TOPs); 4238 FREETMPS; 4239 LEAVE_with_name("smartmatch_coderef"); 4240 RETURN; 4241 } 4242 } 4243 /* ~~ %hash */ 4244 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) { 4245 if (object_on_left) { 4246 goto sm_any_hash; /* Treat objects like scalars */ 4247 } 4248 else if (!SvOK(d)) { 4249 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n")); 4250 RETPUSHNO; 4251 } 4252 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { 4253 /* Check that the key-sets are identical */ 4254 HE *he; 4255 HV *other_hv = MUTABLE_HV(SvRV(d)); 4256 bool tied = FALSE; 4257 bool other_tied = FALSE; 4258 U32 this_key_count = 0, 4259 other_key_count = 0; 4260 HV *hv = MUTABLE_HV(SvRV(e)); 4261 4262 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n")); 4263 /* Tied hashes don't know how many keys they have. */ 4264 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) { 4265 tied = TRUE; 4266 } 4267 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) { 4268 HV * const temp = other_hv; 4269 other_hv = hv; 4270 hv = temp; 4271 tied = TRUE; 4272 } 4273 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) 4274 other_tied = TRUE; 4275 4276 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv)) 4277 RETPUSHNO; 4278 4279 /* The hashes have the same number of keys, so it suffices 4280 to check that one is a subset of the other. */ 4281 (void) hv_iterinit(hv); 4282 while ( (he = hv_iternext(hv)) ) { 4283 SV *key = hv_iterkeysv(he); 4284 4285 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n")); 4286 ++ this_key_count; 4287 4288 if(!hv_exists_ent(other_hv, key, 0)) { 4289 (void) hv_iterinit(hv); /* reset iterator */ 4290 RETPUSHNO; 4291 } 4292 } 4293 4294 if (other_tied) { 4295 (void) hv_iterinit(other_hv); 4296 while ( hv_iternext(other_hv) ) 4297 ++other_key_count; 4298 } 4299 else 4300 other_key_count = HvUSEDKEYS(other_hv); 4301 4302 if (this_key_count != other_key_count) 4303 RETPUSHNO; 4304 else 4305 RETPUSHYES; 4306 } 4307 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { 4308 AV * const other_av = MUTABLE_AV(SvRV(d)); 4309 const I32 other_len = av_len(other_av) + 1; 4310 I32 i; 4311 HV *hv = MUTABLE_HV(SvRV(e)); 4312 4313 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n")); 4314 for (i = 0; i < other_len; ++i) { 4315 SV ** const svp = av_fetch(other_av, i, FALSE); 4316 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n")); 4317 if (svp) { /* ??? When can this not happen? */ 4318 if (hv_exists_ent(hv, *svp, 0)) 4319 RETPUSHYES; 4320 } 4321 } 4322 RETPUSHNO; 4323 } 4324 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { 4325 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n")); 4326 sm_regex_hash: 4327 { 4328 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); 4329 HE *he; 4330 HV *hv = MUTABLE_HV(SvRV(e)); 4331 4332 (void) hv_iterinit(hv); 4333 while ( (he = hv_iternext(hv)) ) { 4334 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n")); 4335 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) { 4336 (void) hv_iterinit(hv); 4337 destroy_matcher(matcher); 4338 RETPUSHYES; 4339 } 4340 } 4341 destroy_matcher(matcher); 4342 RETPUSHNO; 4343 } 4344 } 4345 else { 4346 sm_any_hash: 4347 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n")); 4348 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0)) 4349 RETPUSHYES; 4350 else 4351 RETPUSHNO; 4352 } 4353 } 4354 /* ~~ @array */ 4355 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) { 4356 if (object_on_left) { 4357 goto sm_any_array; /* Treat objects like scalars */ 4358 } 4359 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { 4360 AV * const other_av = MUTABLE_AV(SvRV(e)); 4361 const I32 other_len = av_len(other_av) + 1; 4362 I32 i; 4363 4364 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n")); 4365 for (i = 0; i < other_len; ++i) { 4366 SV ** const svp = av_fetch(other_av, i, FALSE); 4367 4368 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n")); 4369 if (svp) { /* ??? When can this not happen? */ 4370 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0)) 4371 RETPUSHYES; 4372 } 4373 } 4374 RETPUSHNO; 4375 } 4376 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { 4377 AV *other_av = MUTABLE_AV(SvRV(d)); 4378 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n")); 4379 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av)) 4380 RETPUSHNO; 4381 else { 4382 I32 i; 4383 const I32 other_len = av_len(other_av); 4384 4385 if (NULL == seen_this) { 4386 seen_this = newHV(); 4387 (void) sv_2mortal(MUTABLE_SV(seen_this)); 4388 } 4389 if (NULL == seen_other) { 4390 seen_other = newHV(); 4391 (void) sv_2mortal(MUTABLE_SV(seen_other)); 4392 } 4393 for(i = 0; i <= other_len; ++i) { 4394 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); 4395 SV * const * const other_elem = av_fetch(other_av, i, FALSE); 4396 4397 if (!this_elem || !other_elem) { 4398 if ((this_elem && SvOK(*this_elem)) 4399 || (other_elem && SvOK(*other_elem))) 4400 RETPUSHNO; 4401 } 4402 else if (hv_exists_ent(seen_this, 4403 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) || 4404 hv_exists_ent(seen_other, 4405 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0)) 4406 { 4407 if (*this_elem != *other_elem) 4408 RETPUSHNO; 4409 } 4410 else { 4411 (void)hv_store_ent(seen_this, 4412 sv_2mortal(newSViv(PTR2IV(*this_elem))), 4413 &PL_sv_undef, 0); 4414 (void)hv_store_ent(seen_other, 4415 sv_2mortal(newSViv(PTR2IV(*other_elem))), 4416 &PL_sv_undef, 0); 4417 PUSHs(*other_elem); 4418 PUSHs(*this_elem); 4419 4420 PUTBACK; 4421 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n")); 4422 (void) do_smartmatch(seen_this, seen_other); 4423 SPAGAIN; 4424 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); 4425 4426 if (!SvTRUEx(POPs)) 4427 RETPUSHNO; 4428 } 4429 } 4430 RETPUSHYES; 4431 } 4432 } 4433 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { 4434 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n")); 4435 sm_regex_array: 4436 { 4437 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); 4438 const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); 4439 I32 i; 4440 4441 for(i = 0; i <= this_len; ++i) { 4442 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); 4443 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n")); 4444 if (svp && matcher_matches_sv(matcher, *svp)) { 4445 destroy_matcher(matcher); 4446 RETPUSHYES; 4447 } 4448 } 4449 destroy_matcher(matcher); 4450 RETPUSHNO; 4451 } 4452 } 4453 else if (!SvOK(d)) { 4454 /* undef ~~ array */ 4455 const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); 4456 I32 i; 4457 4458 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n")); 4459 for (i = 0; i <= this_len; ++i) { 4460 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); 4461 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n")); 4462 if (!svp || !SvOK(*svp)) 4463 RETPUSHYES; 4464 } 4465 RETPUSHNO; 4466 } 4467 else { 4468 sm_any_array: 4469 { 4470 I32 i; 4471 const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); 4472 4473 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n")); 4474 for (i = 0; i <= this_len; ++i) { 4475 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); 4476 if (!svp) 4477 continue; 4478 4479 PUSHs(d); 4480 PUSHs(*svp); 4481 PUTBACK; 4482 /* infinite recursion isn't supposed to happen here */ 4483 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n")); 4484 (void) do_smartmatch(NULL, NULL); 4485 SPAGAIN; 4486 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); 4487 if (SvTRUEx(POPs)) 4488 RETPUSHYES; 4489 } 4490 RETPUSHNO; 4491 } 4492 } 4493 } 4494 /* ~~ qr// */ 4495 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) { 4496 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { 4497 SV *t = d; d = e; e = t; 4498 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n")); 4499 goto sm_regex_hash; 4500 } 4501 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { 4502 SV *t = d; d = e; e = t; 4503 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n")); 4504 goto sm_regex_array; 4505 } 4506 else { 4507 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e)); 4508 4509 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n")); 4510 PUTBACK; 4511 PUSHs(matcher_matches_sv(matcher, d) 4512 ? &PL_sv_yes 4513 : &PL_sv_no); 4514 destroy_matcher(matcher); 4515 RETURN; 4516 } 4517 } 4518 /* ~~ scalar */ 4519 /* See if there is overload magic on left */ 4520 else if (object_on_left && SvAMAGIC(d)) { 4521 SV *tmpsv; 4522 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n")); 4523 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); 4524 PUSHs(d); PUSHs(e); 4525 PUTBACK; 4526 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright); 4527 if (tmpsv) { 4528 SPAGAIN; 4529 (void)POPs; 4530 SETs(tmpsv); 4531 RETURN; 4532 } 4533 SP -= 2; 4534 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n")); 4535 goto sm_any_scalar; 4536 } 4537 else if (!SvOK(d)) { 4538 /* undef ~~ scalar ; we already know that the scalar is SvOK */ 4539 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n")); 4540 RETPUSHNO; 4541 } 4542 else 4543 sm_any_scalar: 4544 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) { 4545 DEBUG_M(if (SvNIOK(e)) 4546 Perl_deb(aTHX_ " applying rule Any-Num\n"); 4547 else 4548 Perl_deb(aTHX_ " applying rule Num-numish\n"); 4549 ); 4550 /* numeric comparison */ 4551 PUSHs(d); PUSHs(e); 4552 PUTBACK; 4553 if (CopHINTS_get(PL_curcop) & HINT_INTEGER) 4554 (void) pp_i_eq(); 4555 else 4556 (void) pp_eq(); 4557 SPAGAIN; 4558 if (SvTRUEx(POPs)) 4559 RETPUSHYES; 4560 else 4561 RETPUSHNO; 4562 } 4563 4564 /* As a last resort, use string comparison */ 4565 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n")); 4566 PUSHs(d); PUSHs(e); 4567 PUTBACK; 4568 return pp_seq(); 4569 } 4570 4571 PP(pp_enterwhen) 4572 { 4573 dVAR; dSP; 4574 register PERL_CONTEXT *cx; 4575 const I32 gimme = GIMME_V; 4576 4577 /* This is essentially an optimization: if the match 4578 fails, we don't want to push a context and then 4579 pop it again right away, so we skip straight 4580 to the op that follows the leavewhen. 4581 */ 4582 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs)) 4583 return cLOGOP->op_other->op_next; 4584 4585 ENTER_with_name("eval"); 4586 SAVETMPS; 4587 4588 PUSHBLOCK(cx, CXt_WHEN, SP); 4589 PUSHWHEN(cx); 4590 4591 RETURN; 4592 } 4593 4594 PP(pp_leavewhen) 4595 { 4596 dVAR; dSP; 4597 register PERL_CONTEXT *cx; 4598 I32 gimme; 4599 SV **newsp; 4600 PMOP *newpm; 4601 4602 POPBLOCK(cx,newpm); 4603 assert(CxTYPE(cx) == CXt_WHEN); 4604 4605 SP = newsp; 4606 PUTBACK; 4607 4608 PL_curpm = newpm; /* pop $1 et al */ 4609 4610 LEAVE_with_name("eval"); 4611 return NORMAL; 4612 } 4613 4614 PP(pp_continue) 4615 { 4616 dVAR; 4617 I32 cxix; 4618 register PERL_CONTEXT *cx; 4619 I32 inner; 4620 4621 cxix = dopoptowhen(cxstack_ix); 4622 if (cxix < 0) 4623 DIE(aTHX_ "Can't \"continue\" outside a when block"); 4624 if (cxix < cxstack_ix) 4625 dounwind(cxix); 4626 4627 /* clear off anything above the scope we're re-entering */ 4628 inner = PL_scopestack_ix; 4629 TOPBLOCK(cx); 4630 if (PL_scopestack_ix < inner) 4631 leave_scope(PL_scopestack[PL_scopestack_ix]); 4632 PL_curcop = cx->blk_oldcop; 4633 return cx->blk_givwhen.leave_op; 4634 } 4635 4636 PP(pp_break) 4637 { 4638 dVAR; 4639 I32 cxix; 4640 register PERL_CONTEXT *cx; 4641 I32 inner; 4642 4643 cxix = dopoptogiven(cxstack_ix); 4644 if (cxix < 0) { 4645 if (PL_op->op_flags & OPf_SPECIAL) 4646 DIE(aTHX_ "Can't use when() outside a topicalizer"); 4647 else 4648 DIE(aTHX_ "Can't \"break\" outside a given block"); 4649 } 4650 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL))) 4651 DIE(aTHX_ "Can't \"break\" in a loop topicalizer"); 4652 4653 if (cxix < cxstack_ix) 4654 dounwind(cxix); 4655 4656 /* clear off anything above the scope we're re-entering */ 4657 inner = PL_scopestack_ix; 4658 TOPBLOCK(cx); 4659 if (PL_scopestack_ix < inner) 4660 leave_scope(PL_scopestack[PL_scopestack_ix]); 4661 PL_curcop = cx->blk_oldcop; 4662 4663 if (CxFOREACH(cx)) 4664 return CX_LOOP_NEXTOP_GET(cx); 4665 else 4666 return cx->blk_givwhen.leave_op; 4667 } 4668 4669 STATIC OP * 4670 S_doparseform(pTHX_ SV *sv) 4671 { 4672 STRLEN len; 4673 register char *s = SvPV_force(sv, len); 4674 register char * const send = s + len; 4675 register char *base = NULL; 4676 register I32 skipspaces = 0; 4677 bool noblank = FALSE; 4678 bool repeat = FALSE; 4679 bool postspace = FALSE; 4680 U32 *fops; 4681 register U32 *fpc; 4682 U32 *linepc = NULL; 4683 register I32 arg; 4684 bool ischop; 4685 bool unchopnum = FALSE; 4686 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */ 4687 4688 PERL_ARGS_ASSERT_DOPARSEFORM; 4689 4690 if (len == 0) 4691 Perl_croak(aTHX_ "Null picture in formline"); 4692 4693 /* estimate the buffer size needed */ 4694 for (base = s; s <= send; s++) { 4695 if (*s == '\n' || *s == '@' || *s == '^') 4696 maxops += 10; 4697 } 4698 s = base; 4699 base = NULL; 4700 4701 Newx(fops, maxops, U32); 4702 fpc = fops; 4703 4704 if (s < send) { 4705 linepc = fpc; 4706 *fpc++ = FF_LINEMARK; 4707 noblank = repeat = FALSE; 4708 base = s; 4709 } 4710 4711 while (s <= send) { 4712 switch (*s++) { 4713 default: 4714 skipspaces = 0; 4715 continue; 4716 4717 case '~': 4718 if (*s == '~') { 4719 repeat = TRUE; 4720 *s = ' '; 4721 } 4722 noblank = TRUE; 4723 s[-1] = ' '; 4724 /* FALL THROUGH */ 4725 case ' ': case '\t': 4726 skipspaces++; 4727 continue; 4728 case 0: 4729 if (s < send) { 4730 skipspaces = 0; 4731 continue; 4732 } /* else FALL THROUGH */ 4733 case '\n': 4734 arg = s - base; 4735 skipspaces++; 4736 arg -= skipspaces; 4737 if (arg) { 4738 if (postspace) 4739 *fpc++ = FF_SPACE; 4740 *fpc++ = FF_LITERAL; 4741 *fpc++ = (U16)arg; 4742 } 4743 postspace = FALSE; 4744 if (s <= send) 4745 skipspaces--; 4746 if (skipspaces) { 4747 *fpc++ = FF_SKIP; 4748 *fpc++ = (U16)skipspaces; 4749 } 4750 skipspaces = 0; 4751 if (s <= send) 4752 *fpc++ = FF_NEWLINE; 4753 if (noblank) { 4754 *fpc++ = FF_BLANK; 4755 if (repeat) 4756 arg = fpc - linepc + 1; 4757 else 4758 arg = 0; 4759 *fpc++ = (U16)arg; 4760 } 4761 if (s < send) { 4762 linepc = fpc; 4763 *fpc++ = FF_LINEMARK; 4764 noblank = repeat = FALSE; 4765 base = s; 4766 } 4767 else 4768 s++; 4769 continue; 4770 4771 case '@': 4772 case '^': 4773 ischop = s[-1] == '^'; 4774 4775 if (postspace) { 4776 *fpc++ = FF_SPACE; 4777 postspace = FALSE; 4778 } 4779 arg = (s - base) - 1; 4780 if (arg) { 4781 *fpc++ = FF_LITERAL; 4782 *fpc++ = (U16)arg; 4783 } 4784 4785 base = s - 1; 4786 *fpc++ = FF_FETCH; 4787 if (*s == '*') { 4788 s++; 4789 *fpc++ = 2; /* skip the @* or ^* */ 4790 if (ischop) { 4791 *fpc++ = FF_LINESNGL; 4792 *fpc++ = FF_CHOP; 4793 } else 4794 *fpc++ = FF_LINEGLOB; 4795 } 4796 else if (*s == '#' || (*s == '.' && s[1] == '#')) { 4797 arg = ischop ? 512 : 0; 4798 base = s - 1; 4799 while (*s == '#') 4800 s++; 4801 if (*s == '.') { 4802 const char * const f = ++s; 4803 while (*s == '#') 4804 s++; 4805 arg |= 256 + (s - f); 4806 } 4807 *fpc++ = s - base; /* fieldsize for FETCH */ 4808 *fpc++ = FF_DECIMAL; 4809 *fpc++ = (U16)arg; 4810 unchopnum |= ! ischop; 4811 } 4812 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */ 4813 arg = ischop ? 512 : 0; 4814 base = s - 1; 4815 s++; /* skip the '0' first */ 4816 while (*s == '#') 4817 s++; 4818 if (*s == '.') { 4819 const char * const f = ++s; 4820 while (*s == '#') 4821 s++; 4822 arg |= 256 + (s - f); 4823 } 4824 *fpc++ = s - base; /* fieldsize for FETCH */ 4825 *fpc++ = FF_0DECIMAL; 4826 *fpc++ = (U16)arg; 4827 unchopnum |= ! ischop; 4828 } 4829 else { 4830 I32 prespace = 0; 4831 bool ismore = FALSE; 4832 4833 if (*s == '>') { 4834 while (*++s == '>') ; 4835 prespace = FF_SPACE; 4836 } 4837 else if (*s == '|') { 4838 while (*++s == '|') ; 4839 prespace = FF_HALFSPACE; 4840 postspace = TRUE; 4841 } 4842 else { 4843 if (*s == '<') 4844 while (*++s == '<') ; 4845 postspace = TRUE; 4846 } 4847 if (*s == '.' && s[1] == '.' && s[2] == '.') { 4848 s += 3; 4849 ismore = TRUE; 4850 } 4851 *fpc++ = s - base; /* fieldsize for FETCH */ 4852 4853 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL; 4854 4855 if (prespace) 4856 *fpc++ = (U16)prespace; 4857 *fpc++ = FF_ITEM; 4858 if (ismore) 4859 *fpc++ = FF_MORE; 4860 if (ischop) 4861 *fpc++ = FF_CHOP; 4862 } 4863 base = s; 4864 skipspaces = 0; 4865 continue; 4866 } 4867 } 4868 *fpc++ = FF_END; 4869 4870 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */ 4871 arg = fpc - fops; 4872 { /* need to jump to the next word */ 4873 int z; 4874 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN; 4875 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4); 4876 s = SvPVX(sv) + SvCUR(sv) + z; 4877 } 4878 Copy(fops, s, arg, U32); 4879 Safefree(fops); 4880 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0); 4881 SvCOMPILED_on(sv); 4882 4883 if (unchopnum && repeat) 4884 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)"); 4885 return 0; 4886 } 4887 4888 4889 STATIC bool 4890 S_num_overflow(NV value, I32 fldsize, I32 frcsize) 4891 { 4892 /* Can value be printed in fldsize chars, using %*.*f ? */ 4893 NV pwr = 1; 4894 NV eps = 0.5; 4895 bool res = FALSE; 4896 int intsize = fldsize - (value < 0 ? 1 : 0); 4897 4898 if (frcsize & 256) 4899 intsize--; 4900 frcsize &= 255; 4901 intsize -= frcsize; 4902 4903 while (intsize--) pwr *= 10.0; 4904 while (frcsize--) eps /= 10.0; 4905 4906 if( value >= 0 ){ 4907 if (value + eps >= pwr) 4908 res = TRUE; 4909 } else { 4910 if (value - eps <= -pwr) 4911 res = TRUE; 4912 } 4913 return res; 4914 } 4915 4916 static I32 4917 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) 4918 { 4919 dVAR; 4920 SV * const datasv = FILTER_DATA(idx); 4921 const int filter_has_file = IoLINES(datasv); 4922 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv)); 4923 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv)); 4924 int status = 0; 4925 SV *upstream; 4926 STRLEN got_len; 4927 char *got_p = NULL; 4928 char *prune_from = NULL; 4929 bool read_from_cache = FALSE; 4930 STRLEN umaxlen; 4931 4932 PERL_ARGS_ASSERT_RUN_USER_FILTER; 4933 4934 assert(maxlen >= 0); 4935 umaxlen = maxlen; 4936 4937 /* I was having segfault trouble under Linux 2.2.5 after a 4938 parse error occured. (Had to hack around it with a test 4939 for PL_parser->error_count == 0.) Solaris doesn't segfault -- 4940 not sure where the trouble is yet. XXX */ 4941 4942 { 4943 SV *const cache = datasv; 4944 if (SvOK(cache)) { 4945 STRLEN cache_len; 4946 const char *cache_p = SvPV(cache, cache_len); 4947 STRLEN take = 0; 4948 4949 if (umaxlen) { 4950 /* Running in block mode and we have some cached data already. 4951 */ 4952 if (cache_len >= umaxlen) { 4953 /* In fact, so much data we don't even need to call 4954 filter_read. */ 4955 take = umaxlen; 4956 } 4957 } else { 4958 const char *const first_nl = 4959 (const char *)memchr(cache_p, '\n', cache_len); 4960 if (first_nl) { 4961 take = first_nl + 1 - cache_p; 4962 } 4963 } 4964 if (take) { 4965 sv_catpvn(buf_sv, cache_p, take); 4966 sv_chop(cache, cache_p + take); 4967 /* Definately not EOF */ 4968 return 1; 4969 } 4970 4971 sv_catsv(buf_sv, cache); 4972 if (umaxlen) { 4973 umaxlen -= cache_len; 4974 } 4975 SvOK_off(cache); 4976 read_from_cache = TRUE; 4977 } 4978 } 4979 4980 /* Filter API says that the filter appends to the contents of the buffer. 4981 Usually the buffer is "", so the details don't matter. But if it's not, 4982 then clearly what it contains is already filtered by this filter, so we 4983 don't want to pass it in a second time. 4984 I'm going to use a mortal in case the upstream filter croaks. */ 4985 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv)) 4986 ? sv_newmortal() : buf_sv; 4987 SvUPGRADE(upstream, SVt_PV); 4988 4989 if (filter_has_file) { 4990 status = FILTER_READ(idx+1, upstream, 0); 4991 } 4992 4993 if (filter_sub && status >= 0) { 4994 dSP; 4995 int count; 4996 4997 ENTER_with_name("call_filter_sub"); 4998 SAVE_DEFSV; 4999 SAVETMPS; 5000 EXTEND(SP, 2); 5001 5002 DEFSV_set(upstream); 5003 PUSHMARK(SP); 5004 mPUSHi(0); 5005 if (filter_state) { 5006 PUSHs(filter_state); 5007 } 5008 PUTBACK; 5009 count = call_sv(filter_sub, G_SCALAR); 5010 SPAGAIN; 5011 5012 if (count > 0) { 5013 SV *out = POPs; 5014 if (SvOK(out)) { 5015 status = SvIV(out); 5016 } 5017 } 5018 5019 PUTBACK; 5020 FREETMPS; 5021 LEAVE_with_name("call_filter_sub"); 5022 } 5023 5024 if(SvOK(upstream)) { 5025 got_p = SvPV(upstream, got_len); 5026 if (umaxlen) { 5027 if (got_len > umaxlen) { 5028 prune_from = got_p + umaxlen; 5029 } 5030 } else { 5031 char *const first_nl = (char *)memchr(got_p, '\n', got_len); 5032 if (first_nl && first_nl + 1 < got_p + got_len) { 5033 /* There's a second line here... */ 5034 prune_from = first_nl + 1; 5035 } 5036 } 5037 } 5038 if (prune_from) { 5039 /* Oh. Too long. Stuff some in our cache. */ 5040 STRLEN cached_len = got_p + got_len - prune_from; 5041 SV *const cache = datasv; 5042 5043 if (SvOK(cache)) { 5044 /* Cache should be empty. */ 5045 assert(!SvCUR(cache)); 5046 } 5047 5048 sv_setpvn(cache, prune_from, cached_len); 5049 /* If you ask for block mode, you may well split UTF-8 characters. 5050 "If it breaks, you get to keep both parts" 5051 (Your code is broken if you don't put them back together again 5052 before something notices.) */ 5053 if (SvUTF8(upstream)) { 5054 SvUTF8_on(cache); 5055 } 5056 SvCUR_set(upstream, got_len - cached_len); 5057 *prune_from = 0; 5058 /* Can't yet be EOF */ 5059 if (status == 0) 5060 status = 1; 5061 } 5062 5063 /* If they are at EOF but buf_sv has something in it, then they may never 5064 have touched the SV upstream, so it may be undefined. If we naively 5065 concatenate it then we get a warning about use of uninitialised value. 5066 */ 5067 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) { 5068 sv_catsv(buf_sv, upstream); 5069 } 5070 5071 if (status <= 0) { 5072 IoLINES(datasv) = 0; 5073 if (filter_state) { 5074 SvREFCNT_dec(filter_state); 5075 IoTOP_GV(datasv) = NULL; 5076 } 5077 if (filter_sub) { 5078 SvREFCNT_dec(filter_sub); 5079 IoBOTTOM_GV(datasv) = NULL; 5080 } 5081 filter_del(S_run_user_filter); 5082 } 5083 if (status == 0 && read_from_cache) { 5084 /* If we read some data from the cache (and by getting here it implies 5085 that we emptied the cache) then we aren't yet at EOF, and mustn't 5086 report that to our caller. */ 5087 return 1; 5088 } 5089 return status; 5090 } 5091 5092 /* perhaps someone can come up with a better name for 5093 this? it is not really "absolute", per se ... */ 5094 static bool 5095 S_path_is_absolute(const char *name) 5096 { 5097 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE; 5098 5099 if (PERL_FILE_IS_ABSOLUTE(name) 5100 #ifdef WIN32 5101 || (*name == '.' && ((name[1] == '/' || 5102 (name[1] == '.' && name[2] == '/')) 5103 || (name[1] == '\\' || 5104 ( name[1] == '.' && name[2] == '\\'))) 5105 ) 5106 #else 5107 || (*name == '.' && (name[1] == '/' || 5108 (name[1] == '.' && name[2] == '/'))) 5109 #endif 5110 ) 5111 { 5112 return TRUE; 5113 } 5114 else 5115 return FALSE; 5116 } 5117 5118 /* 5119 * Local variables: 5120 * c-indentation-style: bsd 5121 * c-basic-offset: 4 5122 * indent-tabs-mode: t 5123 * End: 5124 * 5125 * ex: set ts=8 sts=4 sw=4 noet: 5126 */ 5127