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