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