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, 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 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen); 42 43 PP(pp_wantarray) 44 { 45 dSP; 46 I32 cxix; 47 EXTEND(SP, 1); 48 49 cxix = dopoptosub(cxstack_ix); 50 if (cxix < 0) 51 RETPUSHUNDEF; 52 53 switch (cxstack[cxix].blk_gimme) { 54 case G_ARRAY: 55 RETPUSHYES; 56 case G_SCALAR: 57 RETPUSHNO; 58 default: 59 RETPUSHUNDEF; 60 } 61 } 62 63 PP(pp_regcmaybe) 64 { 65 return NORMAL; 66 } 67 68 PP(pp_regcreset) 69 { 70 /* XXXX Should store the old value to allow for tie/overload - and 71 restore in regcomp, where marked with XXXX. */ 72 PL_reginterp_cnt = 0; 73 TAINT_NOT; 74 return NORMAL; 75 } 76 77 PP(pp_regcomp) 78 { 79 dSP; 80 register PMOP *pm = (PMOP*)cLOGOP->op_other; 81 SV *tmpstr; 82 MAGIC *mg = Null(MAGIC*); 83 84 tmpstr = POPs; 85 86 /* prevent recompiling under /o and ithreads. */ 87 #if defined(USE_ITHREADS) || defined(USE_5005THREADS) 88 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) 89 RETURN; 90 #endif 91 92 if (SvROK(tmpstr)) { 93 SV *sv = SvRV(tmpstr); 94 if(SvMAGICAL(sv)) 95 mg = mg_find(sv, PERL_MAGIC_qr); 96 } 97 if (mg) { 98 regexp * const re = (regexp *)mg->mg_obj; 99 ReREFCNT_dec(PM_GETRE(pm)); 100 PM_SETRE(pm, ReREFCNT_inc(re)); 101 } 102 else { 103 STRLEN len; 104 const char *t = SvPV_const(tmpstr, len); 105 106 /* Check against the last compiled regexp. */ 107 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp || 108 PM_GETRE(pm)->prelen != (I32)len || 109 memNE(PM_GETRE(pm)->precomp, t, len)) 110 { 111 if (PM_GETRE(pm)) { 112 ReREFCNT_dec(PM_GETRE(pm)); 113 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */ 114 } 115 if (PL_op->op_flags & OPf_SPECIAL) 116 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ 117 118 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ 119 if (DO_UTF8(tmpstr)) 120 pm->op_pmdynflags |= PMdf_DYN_UTF8; 121 else { 122 pm->op_pmdynflags &= ~PMdf_DYN_UTF8; 123 if (pm->op_pmdynflags & PMdf_UTF8) 124 t = (char*)bytes_to_utf8((U8*)t, &len); 125 } 126 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm)); 127 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8)) 128 Safefree(t); 129 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed 130 inside tie/overload accessors. */ 131 } 132 } 133 134 #ifndef INCOMPLETE_TAINTS 135 if (PL_tainting) { 136 if (PL_tainted) 137 pm->op_pmdynflags |= PMdf_TAINTED; 138 else 139 pm->op_pmdynflags &= ~PMdf_TAINTED; 140 } 141 #endif 142 143 if (!PM_GETRE(pm)->prelen && PL_curpm) 144 pm = PL_curpm; 145 else if (strEQ("\\s+", PM_GETRE(pm)->precomp)) 146 pm->op_pmflags |= PMf_WHITE; 147 else 148 pm->op_pmflags &= ~PMf_WHITE; 149 150 /* XXX runtime compiled output needs to move to the pad */ 151 if (pm->op_pmflags & PMf_KEEP) { 152 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ 153 #if !defined(USE_ITHREADS) && !defined(USE_5005THREADS) 154 /* XXX can't change the optree at runtime either */ 155 cLOGOP->op_first->op_next = PL_op->op_next; 156 #endif 157 } 158 RETURN; 159 } 160 161 PP(pp_substcont) 162 { 163 dSP; 164 register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; 165 register PMOP * const pm = (PMOP*) cLOGOP->op_other; 166 register SV * const dstr = cx->sb_dstr; 167 register char *s = cx->sb_s; 168 register char *m = cx->sb_m; 169 char *orig = cx->sb_orig; 170 register REGEXP * const rx = cx->sb_rx; 171 SV *nsv = Nullsv; 172 REGEXP *old = PM_GETRE(pm); 173 if(old != rx) { 174 if(old) 175 ReREFCNT_dec(old); 176 PM_SETRE(pm,rx); 177 } 178 179 rxres_restore(&cx->sb_rxres, rx); 180 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ)); 181 182 if (cx->sb_iters++) { 183 const I32 saviters = cx->sb_iters; 184 if (cx->sb_iters > cx->sb_maxiters) 185 DIE(aTHX_ "Substitution loop"); 186 187 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) 188 cx->sb_rxtainted |= 2; 189 sv_catsv(dstr, POPs); 190 191 /* Are we done */ 192 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig, 193 s == m, cx->sb_targ, NULL, 194 ((cx->sb_rflags & REXEC_COPY_STR) 195 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) 196 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST)))) 197 { 198 SV * const targ = cx->sb_targ; 199 200 assert(cx->sb_strend >= s); 201 if(cx->sb_strend > s) { 202 if (DO_UTF8(dstr) && !SvUTF8(targ)) 203 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); 204 else 205 sv_catpvn(dstr, s, cx->sb_strend - s); 206 } 207 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); 208 209 SvPV_free(targ); 210 SvPV_set(targ, SvPVX(dstr)); 211 SvCUR_set(targ, SvCUR(dstr)); 212 SvLEN_set(targ, SvLEN(dstr)); 213 if (DO_UTF8(dstr)) 214 SvUTF8_on(targ); 215 SvPV_set(dstr, (char*)0); 216 sv_free(dstr); 217 218 TAINT_IF(cx->sb_rxtainted & 1); 219 PUSHs(sv_2mortal(newSViv(saviters - 1))); 220 221 (void)SvPOK_only_UTF8(targ); 222 TAINT_IF(cx->sb_rxtainted); 223 SvSETMAGIC(targ); 224 SvTAINT(targ); 225 226 LEAVE_SCOPE(cx->sb_oldsave); 227 ReREFCNT_dec(rx); 228 POPSUBST(cx); 229 RETURNOP(pm->op_next); 230 } 231 cx->sb_iters = saviters; 232 } 233 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { 234 m = s; 235 s = orig; 236 cx->sb_orig = orig = rx->subbeg; 237 s = orig + (m - s); 238 cx->sb_strend = s + (cx->sb_strend - m); 239 } 240 cx->sb_m = m = rx->startp[0] + orig; 241 if (m > s) { 242 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) 243 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv); 244 else 245 sv_catpvn(dstr, s, m-s); 246 } 247 cx->sb_s = rx->endp[0] + orig; 248 { /* Update the pos() information. */ 249 SV * const sv = cx->sb_targ; 250 MAGIC *mg; 251 I32 i; 252 if (SvTYPE(sv) < SVt_PVMG) 253 (void)SvUPGRADE(sv, SVt_PVMG); 254 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { 255 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0); 256 mg = mg_find(sv, PERL_MAGIC_regex_global); 257 } 258 i = m - orig; 259 if (DO_UTF8(sv)) 260 sv_pos_b2u(sv, &i); 261 mg->mg_len = i; 262 } 263 if (old != rx) 264 (void)ReREFCNT_inc(rx); 265 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); 266 rxres_save(&cx->sb_rxres, rx); 267 RETURNOP(pm->op_pmreplstart); 268 } 269 270 void 271 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) 272 { 273 UV *p = (UV*)*rsp; 274 U32 i; 275 276 if (!p || p[1] < rx->nparens) { 277 i = 6 + rx->nparens * 2; 278 if (!p) 279 Newx(p, i, UV); 280 else 281 Renew(p, i, UV); 282 *rsp = (void*)p; 283 } 284 285 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch); 286 RX_MATCH_COPIED_off(rx); 287 288 *p++ = rx->nparens; 289 290 *p++ = PTR2UV(rx->subbeg); 291 *p++ = (UV)rx->sublen; 292 for (i = 0; i <= rx->nparens; ++i) { 293 *p++ = (UV)rx->startp[i]; 294 *p++ = (UV)rx->endp[i]; 295 } 296 } 297 298 void 299 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) 300 { 301 UV *p = (UV*)*rsp; 302 U32 i; 303 304 if (RX_MATCH_COPIED(rx)) 305 Safefree(rx->subbeg); 306 RX_MATCH_COPIED_set(rx, *p); 307 *p++ = 0; 308 309 rx->nparens = *p++; 310 311 rx->subbeg = INT2PTR(char*,*p++); 312 rx->sublen = (I32)(*p++); 313 for (i = 0; i <= rx->nparens; ++i) { 314 rx->startp[i] = (I32)(*p++); 315 rx->endp[i] = (I32)(*p++); 316 } 317 } 318 319 void 320 Perl_rxres_free(pTHX_ void **rsp) 321 { 322 UV * const p = (UV*)*rsp; 323 324 if (p) { 325 #ifdef PERL_POISON 326 void *tmp = INT2PTR(char*,*p); 327 Safefree(tmp); 328 if (*p) 329 Poison(*p, 1, sizeof(*p)); 330 #else 331 Safefree(INT2PTR(char*,*p)); 332 #endif 333 Safefree(p); 334 *rsp = Null(void*); 335 } 336 } 337 338 PP(pp_formline) 339 { 340 dSP; dMARK; dORIGMARK; 341 register SV * const tmpForm = *++MARK; 342 register U32 *fpc; 343 register char *t; 344 const char *f; 345 register I32 arg; 346 register SV *sv = Nullsv; 347 const char *item = Nullch; 348 I32 itemsize = 0; 349 I32 fieldsize = 0; 350 I32 lines = 0; 351 bool chopspace = (strchr(PL_chopset, ' ') != Nullch); 352 const char *chophere = Nullch; 353 char *linemark = Nullch; 354 NV value; 355 bool gotsome = FALSE; 356 STRLEN len; 357 const STRLEN fudge = SvPOK(tmpForm) 358 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0; 359 bool item_is_utf8 = FALSE; 360 bool targ_is_utf8 = FALSE; 361 SV * nsv = Nullsv; 362 OP * parseres = 0; 363 const char *fmt; 364 bool oneline; 365 366 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { 367 if (SvREADONLY(tmpForm)) { 368 SvREADONLY_off(tmpForm); 369 parseres = doparseform(tmpForm); 370 SvREADONLY_on(tmpForm); 371 } 372 else 373 parseres = doparseform(tmpForm); 374 if (parseres) 375 return parseres; 376 } 377 SvPV_force(PL_formtarget, len); 378 if (DO_UTF8(PL_formtarget)) 379 targ_is_utf8 = TRUE; 380 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */ 381 t += len; 382 f = SvPV_const(tmpForm, len); 383 /* need to jump to the next word */ 384 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN); 385 386 for (;;) { 387 DEBUG_f( { 388 const char *name = "???"; 389 arg = -1; 390 switch (*fpc) { 391 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break; 392 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break; 393 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break; 394 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break; 395 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break; 396 397 case FF_CHECKNL: name = "CHECKNL"; break; 398 case FF_CHECKCHOP: name = "CHECKCHOP"; break; 399 case FF_SPACE: name = "SPACE"; break; 400 case FF_HALFSPACE: name = "HALFSPACE"; break; 401 case FF_ITEM: name = "ITEM"; break; 402 case FF_CHOP: name = "CHOP"; break; 403 case FF_LINEGLOB: name = "LINEGLOB"; break; 404 case FF_NEWLINE: name = "NEWLINE"; break; 405 case FF_MORE: name = "MORE"; break; 406 case FF_LINEMARK: name = "LINEMARK"; break; 407 case FF_END: name = "END"; break; 408 case FF_0DECIMAL: name = "0DECIMAL"; break; 409 case FF_LINESNGL: name = "LINESNGL"; break; 410 } 411 if (arg >= 0) 412 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg); 413 else 414 PerlIO_printf(Perl_debug_log, "%-16s\n", name); 415 } ); 416 switch (*fpc++) { 417 case FF_LINEMARK: 418 linemark = t; 419 lines++; 420 gotsome = FALSE; 421 break; 422 423 case FF_LITERAL: 424 arg = *fpc++; 425 if (targ_is_utf8 && !SvUTF8(tmpForm)) { 426 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 427 *t = '\0'; 428 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv); 429 t = SvEND(PL_formtarget); 430 break; 431 } 432 if (!targ_is_utf8 && DO_UTF8(tmpForm)) { 433 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 434 *t = '\0'; 435 sv_utf8_upgrade(PL_formtarget); 436 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); 437 t = SvEND(PL_formtarget); 438 targ_is_utf8 = TRUE; 439 } 440 while (arg--) 441 *t++ = *f++; 442 break; 443 444 case FF_SKIP: 445 f += *fpc++; 446 break; 447 448 case FF_FETCH: 449 arg = *fpc++; 450 f += arg; 451 fieldsize = arg; 452 453 if (MARK < SP) 454 sv = *++MARK; 455 else { 456 sv = &PL_sv_no; 457 if (ckWARN(WARN_SYNTAX)) 458 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments"); 459 } 460 break; 461 462 case FF_CHECKNL: 463 { 464 const char *send; 465 const char *s = item = SvPV_const(sv, len); 466 itemsize = len; 467 if (DO_UTF8(sv)) { 468 itemsize = sv_len_utf8(sv); 469 if (itemsize != (I32)len) { 470 I32 itembytes; 471 if (itemsize > fieldsize) { 472 itemsize = fieldsize; 473 itembytes = itemsize; 474 sv_pos_u2b(sv, &itembytes, 0); 475 } 476 else 477 itembytes = len; 478 send = chophere = s + itembytes; 479 while (s < send) { 480 if (*s & ~31) 481 gotsome = TRUE; 482 else if (*s == '\n') 483 break; 484 s++; 485 } 486 item_is_utf8 = TRUE; 487 itemsize = s - item; 488 sv_pos_b2u(sv, &itemsize); 489 break; 490 } 491 } 492 item_is_utf8 = FALSE; 493 if (itemsize > fieldsize) 494 itemsize = fieldsize; 495 send = chophere = s + itemsize; 496 while (s < send) { 497 if (*s & ~31) 498 gotsome = TRUE; 499 else if (*s == '\n') 500 break; 501 s++; 502 } 503 itemsize = s - item; 504 break; 505 } 506 507 case FF_CHECKCHOP: 508 { 509 const char *s = item = SvPV_const(sv, len); 510 itemsize = len; 511 if (DO_UTF8(sv)) { 512 itemsize = sv_len_utf8(sv); 513 if (itemsize != (I32)len) { 514 I32 itembytes; 515 if (itemsize <= fieldsize) { 516 const char *send = chophere = s + itemsize; 517 while (s < send) { 518 if (*s == '\r') { 519 itemsize = s - item; 520 chophere = s; 521 break; 522 } 523 if (*s++ & ~31) 524 gotsome = TRUE; 525 } 526 } 527 else { 528 const char *send; 529 itemsize = fieldsize; 530 itembytes = itemsize; 531 sv_pos_u2b(sv, &itembytes, 0); 532 send = chophere = s + itembytes; 533 while (s < send || (s == send && isSPACE(*s))) { 534 if (isSPACE(*s)) { 535 if (chopspace) 536 chophere = s; 537 if (*s == '\r') 538 break; 539 } 540 else { 541 if (*s & ~31) 542 gotsome = TRUE; 543 if (strchr(PL_chopset, *s)) 544 chophere = s + 1; 545 } 546 s++; 547 } 548 itemsize = chophere - item; 549 sv_pos_b2u(sv, &itemsize); 550 } 551 item_is_utf8 = TRUE; 552 break; 553 } 554 } 555 item_is_utf8 = FALSE; 556 if (itemsize <= fieldsize) { 557 const char *const send = chophere = s + itemsize; 558 while (s < send) { 559 if (*s == '\r') { 560 itemsize = s - item; 561 chophere = s; 562 break; 563 } 564 if (*s++ & ~31) 565 gotsome = TRUE; 566 } 567 } 568 else { 569 const char *send; 570 itemsize = fieldsize; 571 send = chophere = s + itemsize; 572 while (s < send || (s == send && isSPACE(*s))) { 573 if (isSPACE(*s)) { 574 if (chopspace) 575 chophere = s; 576 if (*s == '\r') 577 break; 578 } 579 else { 580 if (*s & ~31) 581 gotsome = TRUE; 582 if (strchr(PL_chopset, *s)) 583 chophere = s + 1; 584 } 585 s++; 586 } 587 itemsize = chophere - item; 588 } 589 break; 590 } 591 592 case FF_SPACE: 593 arg = fieldsize - itemsize; 594 if (arg) { 595 fieldsize -= arg; 596 while (arg-- > 0) 597 *t++ = ' '; 598 } 599 break; 600 601 case FF_HALFSPACE: 602 arg = fieldsize - itemsize; 603 if (arg) { 604 arg /= 2; 605 fieldsize -= arg; 606 while (arg-- > 0) 607 *t++ = ' '; 608 } 609 break; 610 611 case FF_ITEM: 612 { 613 const char *s = item; 614 arg = itemsize; 615 if (item_is_utf8) { 616 if (!targ_is_utf8) { 617 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 618 *t = '\0'; 619 sv_utf8_upgrade(PL_formtarget); 620 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); 621 t = SvEND(PL_formtarget); 622 targ_is_utf8 = TRUE; 623 } 624 while (arg--) { 625 if (UTF8_IS_CONTINUED(*s)) { 626 STRLEN skip = UTF8SKIP(s); 627 switch (skip) { 628 default: 629 Move(s,t,skip,char); 630 s += skip; 631 t += skip; 632 break; 633 case 7: *t++ = *s++; 634 case 6: *t++ = *s++; 635 case 5: *t++ = *s++; 636 case 4: *t++ = *s++; 637 case 3: *t++ = *s++; 638 case 2: *t++ = *s++; 639 case 1: *t++ = *s++; 640 } 641 } 642 else { 643 if ( !((*t++ = *s++) & ~31) ) 644 t[-1] = ' '; 645 } 646 } 647 break; 648 } 649 if (targ_is_utf8 && !item_is_utf8) { 650 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 651 *t = '\0'; 652 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv); 653 for (; t < SvEND(PL_formtarget); t++) { 654 #ifdef EBCDIC 655 const int ch = *t; 656 if (iscntrl(ch)) 657 #else 658 if (!(*t & ~31)) 659 #endif 660 *t = ' '; 661 } 662 break; 663 } 664 while (arg--) { 665 #ifdef EBCDIC 666 const int ch = *t++ = *s++; 667 if (iscntrl(ch)) 668 #else 669 if ( !((*t++ = *s++) & ~31) ) 670 #endif 671 t[-1] = ' '; 672 } 673 break; 674 } 675 676 case FF_CHOP: 677 { 678 const char *s = chophere; 679 if (chopspace) { 680 while (*s && isSPACE(*s)) 681 s++; 682 } 683 sv_chop(sv,(char *)s); 684 SvSETMAGIC(sv); 685 break; 686 } 687 688 case FF_LINESNGL: 689 chopspace = 0; 690 oneline = TRUE; 691 goto ff_line; 692 case FF_LINEGLOB: 693 oneline = FALSE; 694 ff_line: 695 { 696 const char *s = item = SvPV_const(sv, len); 697 itemsize = len; 698 if ((item_is_utf8 = DO_UTF8(sv))) 699 itemsize = sv_len_utf8(sv); 700 if (itemsize) { 701 bool chopped = FALSE; 702 const char *const send = s + len; 703 gotsome = TRUE; 704 chophere = s + itemsize; 705 while (s < send) { 706 if (*s++ == '\n') { 707 if (oneline) { 708 chopped = TRUE; 709 chophere = s; 710 break; 711 } else { 712 if (s == send) { 713 itemsize--; 714 chopped = TRUE; 715 } else 716 lines++; 717 } 718 } 719 } 720 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 721 if (targ_is_utf8) 722 SvUTF8_on(PL_formtarget); 723 if (oneline) { 724 SvCUR_set(sv, chophere - item); 725 sv_catsv(PL_formtarget, sv); 726 SvCUR_set(sv, itemsize); 727 } else 728 sv_catsv(PL_formtarget, sv); 729 if (chopped) 730 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1); 731 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); 732 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); 733 if (item_is_utf8) 734 targ_is_utf8 = TRUE; 735 } 736 break; 737 } 738 739 case FF_0DECIMAL: 740 arg = *fpc++; 741 #if defined(USE_LONG_DOUBLE) 742 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl; 743 #else 744 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f"; 745 #endif 746 goto ff_dec; 747 case FF_DECIMAL: 748 arg = *fpc++; 749 #if defined(USE_LONG_DOUBLE) 750 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl; 751 #else 752 fmt = (arg & 256) ? "%#*.*f" : "%*.*f"; 753 #endif 754 ff_dec: 755 /* If the field is marked with ^ and the value is undefined, 756 blank it out. */ 757 if ((arg & 512) && !SvOK(sv)) { 758 arg = fieldsize; 759 while (arg--) 760 *t++ = ' '; 761 break; 762 } 763 gotsome = TRUE; 764 value = SvNV(sv); 765 /* overflow evidence */ 766 if (num_overflow(value, fieldsize, arg)) { 767 arg = fieldsize; 768 while (arg--) 769 *t++ = '#'; 770 break; 771 } 772 /* Formats aren't yet marked for locales, so assume "yes". */ 773 { 774 STORE_NUMERIC_STANDARD_SET_LOCAL(); 775 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value); 776 RESTORE_NUMERIC_STANDARD(); 777 } 778 t += fieldsize; 779 break; 780 781 case FF_NEWLINE: 782 f++; 783 while (t-- > linemark && *t == ' ') ; 784 t++; 785 *t++ = '\n'; 786 break; 787 788 case FF_BLANK: 789 arg = *fpc++; 790 if (gotsome) { 791 if (arg) { /* repeat until fields exhausted? */ 792 *t = '\0'; 793 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 794 lines += FmLINES(PL_formtarget); 795 if (lines == 200) { 796 arg = t - linemark; 797 if (strnEQ(linemark, linemark - arg, arg)) 798 DIE(aTHX_ "Runaway format"); 799 } 800 if (targ_is_utf8) 801 SvUTF8_on(PL_formtarget); 802 FmLINES(PL_formtarget) = lines; 803 SP = ORIGMARK; 804 RETURNOP(cLISTOP->op_first); 805 } 806 } 807 else { 808 t = linemark; 809 lines--; 810 } 811 break; 812 813 case FF_MORE: 814 { 815 const char *s = chophere; 816 const char *send = item + len; 817 if (chopspace) { 818 while (*s && isSPACE(*s) && s < send) 819 s++; 820 } 821 if (s < send) { 822 char *s1; 823 arg = fieldsize - itemsize; 824 if (arg) { 825 fieldsize -= arg; 826 while (arg-- > 0) 827 *t++ = ' '; 828 } 829 s1 = t - 3; 830 if (strnEQ(s1," ",3)) { 831 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1])) 832 s1--; 833 } 834 *s1++ = '.'; 835 *s1++ = '.'; 836 *s1++ = '.'; 837 } 838 break; 839 } 840 case FF_END: 841 *t = '\0'; 842 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); 843 if (targ_is_utf8) 844 SvUTF8_on(PL_formtarget); 845 FmLINES(PL_formtarget) += lines; 846 SP = ORIGMARK; 847 RETPUSHYES; 848 } 849 } 850 } 851 852 PP(pp_grepstart) 853 { 854 dSP; 855 SV *src; 856 857 if (PL_stack_base + *PL_markstack_ptr == SP) { 858 (void)POPMARK; 859 if (GIMME_V == G_SCALAR) 860 XPUSHs(sv_2mortal(newSViv(0))); 861 RETURNOP(PL_op->op_next->op_next); 862 } 863 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; 864 pp_pushmark(); /* push dst */ 865 pp_pushmark(); /* push src */ 866 ENTER; /* enter outer scope */ 867 868 SAVETMPS; 869 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */ 870 SAVESPTR(DEFSV); 871 ENTER; /* enter inner scope */ 872 SAVEVPTR(PL_curpm); 873 874 src = PL_stack_base[*PL_markstack_ptr]; 875 SvTEMP_off(src); 876 DEFSV = src; 877 878 PUTBACK; 879 if (PL_op->op_type == OP_MAPSTART) 880 pp_pushmark(); /* push top */ 881 return ((LOGOP*)PL_op->op_next)->op_other; 882 } 883 884 PP(pp_mapstart) 885 { 886 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */ 887 } 888 889 PP(pp_mapwhile) 890 { 891 dSP; 892 const I32 gimme = GIMME_V; 893 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ 894 I32 count; 895 I32 shift; 896 SV** src; 897 SV** dst; 898 899 /* first, move source pointer to the next item in the source list */ 900 ++PL_markstack_ptr[-1]; 901 902 /* if there are new items, push them into the destination list */ 903 if (items && gimme != G_VOID) { 904 /* might need to make room back there first */ 905 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) { 906 /* XXX this implementation is very pessimal because the stack 907 * is repeatedly extended for every set of items. Is possible 908 * to do this without any stack extension or copying at all 909 * by maintaining a separate list over which the map iterates 910 * (like foreach does). --gsar */ 911 912 /* everything in the stack after the destination list moves 913 * towards the end the stack by the amount of room needed */ 914 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]); 915 916 /* items to shift up (accounting for the moved source pointer) */ 917 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1); 918 919 /* This optimization is by Ben Tilly and it does 920 * things differently from what Sarathy (gsar) 921 * is describing. The downside of this optimization is 922 * that leaves "holes" (uninitialized and hopefully unused areas) 923 * to the Perl stack, but on the other hand this 924 * shouldn't be a problem. If Sarathy's idea gets 925 * implemented, this optimization should become 926 * irrelevant. --jhi */ 927 if (shift < count) 928 shift = count; /* Avoid shifting too often --Ben Tilly */ 929 930 EXTEND(SP,shift); 931 src = SP; 932 dst = (SP += shift); 933 PL_markstack_ptr[-1] += shift; 934 *PL_markstack_ptr += shift; 935 while (count--) 936 *dst-- = *src--; 937 } 938 /* copy the new items down to the destination list */ 939 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; 940 if (gimme == G_ARRAY) { 941 while (items-- > 0) 942 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); 943 } 944 else { 945 /* scalar context: we don't care about which values map returns 946 * (we use undef here). And so we certainly don't want to do mortal 947 * copies of meaningless values. */ 948 while (items-- > 0) { 949 (void)POPs; 950 *dst-- = &PL_sv_undef; 951 } 952 } 953 } 954 LEAVE; /* exit inner scope */ 955 956 /* All done yet? */ 957 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { 958 959 (void)POPMARK; /* pop top */ 960 LEAVE; /* exit outer scope */ 961 (void)POPMARK; /* pop src */ 962 items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; 963 (void)POPMARK; /* pop dst */ 964 SP = PL_stack_base + POPMARK; /* pop original mark */ 965 if (gimme == G_SCALAR) { 966 dTARGET; 967 XPUSHi(items); 968 } 969 else if (gimme == G_ARRAY) 970 SP += items; 971 RETURN; 972 } 973 else { 974 SV *src; 975 976 ENTER; /* enter inner scope */ 977 SAVEVPTR(PL_curpm); 978 979 /* set $_ to the new source item */ 980 src = PL_stack_base[PL_markstack_ptr[-1]]; 981 SvTEMP_off(src); 982 DEFSV = src; 983 984 RETURNOP(cLOGOP->op_other); 985 } 986 } 987 988 /* Range stuff. */ 989 990 PP(pp_range) 991 { 992 if (GIMME == G_ARRAY) 993 return NORMAL; 994 if (SvTRUEx(PAD_SV(PL_op->op_targ))) 995 return cLOGOP->op_other; 996 else 997 return NORMAL; 998 } 999 1000 PP(pp_flip) 1001 { 1002 dSP; 1003 1004 if (GIMME == G_ARRAY) { 1005 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); 1006 } 1007 else { 1008 dTOPss; 1009 SV * const targ = PAD_SV(PL_op->op_targ); 1010 int flip = 0; 1011 1012 if (PL_op->op_private & OPpFLIP_LINENUM) { 1013 if (GvIO(PL_last_in_gv)) { 1014 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); 1015 } 1016 else { 1017 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV); 1018 if (gv && GvSV(gv)) 1019 flip = SvIV(sv) == SvIV(GvSV(gv)); 1020 } 1021 } else { 1022 flip = SvTRUE(sv); 1023 } 1024 if (flip) { 1025 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); 1026 if (PL_op->op_flags & OPf_SPECIAL) { 1027 sv_setiv(targ, 1); 1028 SETs(targ); 1029 RETURN; 1030 } 1031 else { 1032 sv_setiv(targ, 0); 1033 SP--; 1034 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); 1035 } 1036 } 1037 sv_setpvn(TARG, "", 0); 1038 SETs(targ); 1039 RETURN; 1040 } 1041 } 1042 1043 /* This code tries to decide if "$left .. $right" should use the 1044 magical string increment, or if the range is numeric (we make 1045 an exception for .."0" [#18165]). AMS 20021031. */ 1046 1047 #define RANGE_IS_NUMERIC(left,right) ( \ 1048 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \ 1049 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \ 1050 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \ 1051 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \ 1052 && (!SvOK(right) || looks_like_number(right)))) 1053 1054 PP(pp_flop) 1055 { 1056 dSP; 1057 1058 if (GIMME == G_ARRAY) { 1059 dPOPPOPssrl; 1060 1061 if (SvGMAGICAL(left)) 1062 mg_get(left); 1063 if (SvGMAGICAL(right)) 1064 mg_get(right); 1065 1066 if (RANGE_IS_NUMERIC(left,right)) { 1067 register IV i, j; 1068 IV max; 1069 if ((SvOK(left) && SvNV(left) < IV_MIN) || 1070 (SvOK(right) && SvNV(right) > IV_MAX)) 1071 DIE(aTHX_ "Range iterator outside integer range"); 1072 i = SvIV(left); 1073 max = SvIV(right); 1074 if (max >= i) { 1075 j = max - i + 1; 1076 EXTEND_MORTAL(j); 1077 EXTEND(SP, j); 1078 } 1079 else 1080 j = 0; 1081 while (j--) { 1082 SV * const sv = sv_2mortal(newSViv(i++)); 1083 PUSHs(sv); 1084 } 1085 } 1086 else { 1087 SV * const final = sv_mortalcopy(right); 1088 STRLEN len; 1089 const char * const tmps = SvPV_const(final, len); 1090 1091 SV *sv = sv_mortalcopy(left); 1092 SvPV_force_nolen(sv); 1093 while (!SvNIOKp(sv) && SvCUR(sv) <= len) { 1094 XPUSHs(sv); 1095 if (strEQ(SvPVX_const(sv),tmps)) 1096 break; 1097 sv = sv_2mortal(newSVsv(sv)); 1098 sv_inc(sv); 1099 } 1100 } 1101 } 1102 else { 1103 dTOPss; 1104 SV * const targ = PAD_SV(cUNOP->op_first->op_targ); 1105 int flop = 0; 1106 sv_inc(targ); 1107 1108 if (PL_op->op_private & OPpFLIP_LINENUM) { 1109 if (GvIO(PL_last_in_gv)) { 1110 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); 1111 } 1112 else { 1113 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV); 1114 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv)); 1115 } 1116 } 1117 else { 1118 flop = SvTRUE(sv); 1119 } 1120 1121 if (flop) { 1122 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); 1123 sv_catpvn(targ, "E0", 2); 1124 } 1125 SETs(targ); 1126 } 1127 1128 RETURN; 1129 } 1130 1131 /* Control. */ 1132 1133 static const char * const context_name[] = { 1134 "pseudo-block", 1135 "subroutine", 1136 "eval", 1137 "loop", 1138 "substitution", 1139 "block", 1140 "format" 1141 }; 1142 1143 STATIC I32 1144 S_dopoptolabel(pTHX_ const char *label) 1145 { 1146 register I32 i; 1147 1148 for (i = cxstack_ix; i >= 0; i--) { 1149 register const PERL_CONTEXT * const cx = &cxstack[i]; 1150 switch (CxTYPE(cx)) { 1151 case CXt_SUBST: 1152 case CXt_SUB: 1153 case CXt_FORMAT: 1154 case CXt_EVAL: 1155 case CXt_NULL: 1156 if (ckWARN(WARN_EXITING)) 1157 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", 1158 context_name[CxTYPE(cx)], OP_NAME(PL_op)); 1159 if (CxTYPE(cx) == CXt_NULL) 1160 return -1; 1161 break; 1162 case CXt_LOOP: 1163 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) { 1164 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n", 1165 (long)i, cx->blk_loop.label)); 1166 continue; 1167 } 1168 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label)); 1169 return i; 1170 } 1171 } 1172 return i; 1173 } 1174 1175 I32 1176 Perl_dowantarray(pTHX) 1177 { 1178 const I32 gimme = block_gimme(); 1179 return (gimme == G_VOID) ? G_SCALAR : gimme; 1180 } 1181 1182 I32 1183 Perl_block_gimme(pTHX) 1184 { 1185 const I32 cxix = dopoptosub(cxstack_ix); 1186 if (cxix < 0) 1187 return G_VOID; 1188 1189 switch (cxstack[cxix].blk_gimme) { 1190 case G_VOID: 1191 return G_VOID; 1192 case G_SCALAR: 1193 return G_SCALAR; 1194 case G_ARRAY: 1195 return G_ARRAY; 1196 default: 1197 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme); 1198 /* NOTREACHED */ 1199 return 0; 1200 } 1201 } 1202 1203 I32 1204 Perl_is_lvalue_sub(pTHX) 1205 { 1206 const I32 cxix = dopoptosub(cxstack_ix); 1207 assert(cxix >= 0); /* We should only be called from inside subs */ 1208 1209 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv)) 1210 return cxstack[cxix].blk_sub.lval; 1211 else 1212 return 0; 1213 } 1214 1215 STATIC I32 1216 S_dopoptosub(pTHX_ I32 startingblock) 1217 { 1218 return dopoptosub_at(cxstack, startingblock); 1219 } 1220 1221 STATIC I32 1222 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) 1223 { 1224 I32 i; 1225 for (i = startingblock; i >= 0; i--) { 1226 register const PERL_CONTEXT * const cx = &cxstk[i]; 1227 switch (CxTYPE(cx)) { 1228 default: 1229 continue; 1230 case CXt_EVAL: 1231 case CXt_SUB: 1232 case CXt_FORMAT: 1233 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i)); 1234 return i; 1235 } 1236 } 1237 return i; 1238 } 1239 1240 STATIC I32 1241 S_dopoptoeval(pTHX_ I32 startingblock) 1242 { 1243 I32 i; 1244 for (i = startingblock; i >= 0; i--) { 1245 register const PERL_CONTEXT *cx = &cxstack[i]; 1246 switch (CxTYPE(cx)) { 1247 default: 1248 continue; 1249 case CXt_EVAL: 1250 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i)); 1251 return i; 1252 } 1253 } 1254 return i; 1255 } 1256 1257 STATIC I32 1258 S_dopoptoloop(pTHX_ I32 startingblock) 1259 { 1260 I32 i; 1261 for (i = startingblock; i >= 0; i--) { 1262 register const PERL_CONTEXT * const cx = &cxstack[i]; 1263 switch (CxTYPE(cx)) { 1264 case CXt_SUBST: 1265 case CXt_SUB: 1266 case CXt_FORMAT: 1267 case CXt_EVAL: 1268 case CXt_NULL: 1269 if (ckWARN(WARN_EXITING)) 1270 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", 1271 context_name[CxTYPE(cx)], OP_NAME(PL_op)); 1272 if ((CxTYPE(cx)) == CXt_NULL) 1273 return -1; 1274 break; 1275 case CXt_LOOP: 1276 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); 1277 return i; 1278 } 1279 } 1280 return i; 1281 } 1282 1283 void 1284 Perl_dounwind(pTHX_ I32 cxix) 1285 { 1286 I32 optype; 1287 1288 while (cxstack_ix > cxix) { 1289 SV *sv; 1290 register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; 1291 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", 1292 (long) cxstack_ix, PL_block_type[CxTYPE(cx)])); 1293 /* Note: we don't need to restore the base context info till the end. */ 1294 switch (CxTYPE(cx)) { 1295 case CXt_SUBST: 1296 POPSUBST(cx); 1297 continue; /* not break */ 1298 case CXt_SUB: 1299 POPSUB(cx,sv); 1300 LEAVESUB(sv); 1301 break; 1302 case CXt_EVAL: 1303 POPEVAL(cx); 1304 break; 1305 case CXt_LOOP: 1306 POPLOOP(cx); 1307 break; 1308 case CXt_NULL: 1309 break; 1310 case CXt_FORMAT: 1311 POPFORMAT(cx); 1312 break; 1313 } 1314 cxstack_ix--; 1315 } 1316 PERL_UNUSED_VAR(optype); 1317 } 1318 1319 void 1320 Perl_qerror(pTHX_ SV *err) 1321 { 1322 if (PL_in_eval) 1323 sv_catsv(ERRSV, err); 1324 else if (PL_errors) 1325 sv_catsv(PL_errors, err); 1326 else 1327 Perl_warn(aTHX_ "%"SVf, err); 1328 ++PL_error_count; 1329 } 1330 1331 OP * 1332 Perl_die_where(pTHX_ char *message, STRLEN msglen) 1333 { 1334 if (PL_in_eval) { 1335 I32 cxix; 1336 I32 gimme; 1337 1338 if (message) { 1339 if (PL_in_eval & EVAL_KEEPERR) { 1340 static const char prefix[] = "\t(in cleanup) "; 1341 SV * const err = ERRSV; 1342 const char *e = Nullch; 1343 if (!SvPOK(err)) 1344 sv_setpvn(err,"",0); 1345 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) { 1346 STRLEN len; 1347 e = SvPV_const(err, len); 1348 e += len - msglen; 1349 if (*e != *message || strNE(e,message)) 1350 e = Nullch; 1351 } 1352 if (!e) { 1353 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen); 1354 sv_catpvn(err, prefix, sizeof(prefix)-1); 1355 sv_catpvn(err, message, msglen); 1356 if (ckWARN(WARN_MISC)) { 1357 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1; 1358 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start); 1359 } 1360 } 1361 } 1362 else { 1363 sv_setpvn(ERRSV, message, msglen); 1364 } 1365 } 1366 1367 while ((cxix = dopoptoeval(cxstack_ix)) < 0 1368 && PL_curstackinfo->si_prev) 1369 { 1370 dounwind(-1); 1371 POPSTACK; 1372 } 1373 1374 if (cxix >= 0) { 1375 I32 optype; 1376 register PERL_CONTEXT *cx; 1377 SV **newsp; 1378 1379 if (cxix < cxstack_ix) 1380 dounwind(cxix); 1381 1382 POPBLOCK(cx,PL_curpm); 1383 if (CxTYPE(cx) != CXt_EVAL) { 1384 if (!message) 1385 message = (char *)SvPVx_const(ERRSV, msglen); 1386 PerlIO_write(Perl_error_log, "panic: die ", 11); 1387 PerlIO_write(Perl_error_log, message, msglen); 1388 my_exit(1); 1389 } 1390 POPEVAL(cx); 1391 1392 if (gimme == G_SCALAR) 1393 *++newsp = &PL_sv_undef; 1394 PL_stack_sp = newsp; 1395 1396 LEAVE; 1397 1398 /* LEAVE could clobber PL_curcop (see save_re_context()) 1399 * XXX it might be better to find a way to avoid messing with 1400 * PL_curcop in save_re_context() instead, but this is a more 1401 * minimal fix --GSAR */ 1402 PL_curcop = cx->blk_oldcop; 1403 1404 if (optype == OP_REQUIRE) { 1405 const char* msg = SvPVx_nolen_const(ERRSV); 1406 DIE(aTHX_ "%sCompilation failed in require", 1407 *msg ? msg : "Unknown error\n"); 1408 } 1409 return pop_return(); 1410 } 1411 } 1412 if (!message) 1413 message = (char *)SvPVx_const(ERRSV, msglen); 1414 1415 write_to_stderr(message, msglen); 1416 my_failure_exit(); 1417 /* NOTREACHED */ 1418 return 0; 1419 } 1420 1421 PP(pp_xor) 1422 { 1423 dSP; dPOPTOPssrl; 1424 if (SvTRUE(left) != SvTRUE(right)) 1425 RETSETYES; 1426 else 1427 RETSETNO; 1428 } 1429 1430 PP(pp_andassign) 1431 { 1432 dSP; 1433 if (!SvTRUE(TOPs)) 1434 RETURN; 1435 else 1436 RETURNOP(cLOGOP->op_other); 1437 } 1438 1439 PP(pp_orassign) 1440 { 1441 dSP; 1442 if (SvTRUE(TOPs)) 1443 RETURN; 1444 else 1445 RETURNOP(cLOGOP->op_other); 1446 } 1447 1448 PP(pp_caller) 1449 { 1450 dSP; 1451 register I32 cxix = dopoptosub(cxstack_ix); 1452 register const PERL_CONTEXT *cx; 1453 register const PERL_CONTEXT *ccstack = cxstack; 1454 const PERL_SI *top_si = PL_curstackinfo; 1455 I32 gimme; 1456 const char *stashname; 1457 I32 count = 0; 1458 1459 if (MAXARG) 1460 count = POPi; 1461 1462 for (;;) { 1463 /* we may be in a higher stacklevel, so dig down deeper */ 1464 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { 1465 top_si = top_si->si_prev; 1466 ccstack = top_si->si_cxstack; 1467 cxix = dopoptosub_at(ccstack, top_si->si_cxix); 1468 } 1469 if (cxix < 0) { 1470 if (GIMME != G_ARRAY) { 1471 EXTEND(SP, 1); 1472 RETPUSHUNDEF; 1473 } 1474 RETURN; 1475 } 1476 /* caller() should not report the automatic calls to &DB::sub */ 1477 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && 1478 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) 1479 count++; 1480 if (!count--) 1481 break; 1482 cxix = dopoptosub_at(ccstack, cxix - 1); 1483 } 1484 1485 cx = &ccstack[cxix]; 1486 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 1487 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1); 1488 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the 1489 field below is defined for any cx. */ 1490 /* caller() should not report the automatic calls to &DB::sub */ 1491 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) 1492 cx = &ccstack[dbcxix]; 1493 } 1494 1495 stashname = CopSTASHPV(cx->blk_oldcop); 1496 if (GIMME != G_ARRAY) { 1497 EXTEND(SP, 1); 1498 if (!stashname) 1499 PUSHs(&PL_sv_undef); 1500 else { 1501 dTARGET; 1502 sv_setpv(TARG, stashname); 1503 PUSHs(TARG); 1504 } 1505 RETURN; 1506 } 1507 1508 EXTEND(SP, 10); 1509 1510 if (!stashname) 1511 PUSHs(&PL_sv_undef); 1512 else 1513 PUSHs(sv_2mortal(newSVpv(stashname, 0))); 1514 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0))); 1515 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop)))); 1516 if (!MAXARG) 1517 RETURN; 1518 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 1519 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv); 1520 /* So is ccstack[dbcxix]. */ 1521 if (isGV(cvgv)) { 1522 SV * const sv = NEWSV(49, 0); 1523 gv_efullname3(sv, cvgv, Nullch); 1524 PUSHs(sv_2mortal(sv)); 1525 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); 1526 } 1527 else { 1528 PUSHs(sv_2mortal(newSVpvn("(unknown)",9))); 1529 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); 1530 } 1531 } 1532 else { 1533 PUSHs(sv_2mortal(newSVpvn("(eval)",6))); 1534 PUSHs(sv_2mortal(newSViv(0))); 1535 } 1536 gimme = (I32)cx->blk_gimme; 1537 if (gimme == G_VOID) 1538 PUSHs(&PL_sv_undef); 1539 else 1540 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY))); 1541 if (CxTYPE(cx) == CXt_EVAL) { 1542 /* eval STRING */ 1543 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { 1544 PUSHs(cx->blk_eval.cur_text); 1545 PUSHs(&PL_sv_no); 1546 } 1547 /* require */ 1548 else if (cx->blk_eval.old_namesv) { 1549 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv))); 1550 PUSHs(&PL_sv_yes); 1551 } 1552 /* eval BLOCK (try blocks have old_namesv == 0) */ 1553 else { 1554 PUSHs(&PL_sv_undef); 1555 PUSHs(&PL_sv_undef); 1556 } 1557 } 1558 else { 1559 PUSHs(&PL_sv_undef); 1560 PUSHs(&PL_sv_undef); 1561 } 1562 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs 1563 && CopSTASH_eq(PL_curcop, PL_debstash)) 1564 { 1565 AV * const ary = cx->blk_sub.argarray; 1566 const int off = AvARRAY(ary) - AvALLOC(ary); 1567 1568 if (!PL_dbargs) { 1569 GV* tmpgv; 1570 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE, 1571 SVt_PVAV))); 1572 GvMULTI_on(tmpgv); 1573 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ 1574 } 1575 1576 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) 1577 av_extend(PL_dbargs, AvFILLp(ary) + off); 1578 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*); 1579 AvFILLp(PL_dbargs) = AvFILLp(ary) + off; 1580 } 1581 /* XXX only hints propagated via op_private are currently 1582 * visible (others are not easily accessible, since they 1583 * use the global PL_hints) */ 1584 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private & 1585 HINT_PRIVATE_MASK))); 1586 { 1587 SV * mask ; 1588 SV * old_warnings = cx->blk_oldcop->cop_warnings ; 1589 1590 if (old_warnings == pWARN_NONE || 1591 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) 1592 mask = newSVpvn(WARN_NONEstring, WARNsize) ; 1593 else if (old_warnings == pWARN_ALL || 1594 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { 1595 /* Get the bit mask for $warnings::Bits{all}, because 1596 * it could have been extended by warnings::register */ 1597 SV **bits_all; 1598 HV *bits = get_hv("warnings::Bits", FALSE); 1599 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) { 1600 mask = newSVsv(*bits_all); 1601 } 1602 else { 1603 mask = newSVpvn(WARN_ALLstring, WARNsize) ; 1604 } 1605 } 1606 else 1607 mask = newSVsv(old_warnings); 1608 PUSHs(sv_2mortal(mask)); 1609 } 1610 RETURN; 1611 } 1612 1613 PP(pp_reset) 1614 { 1615 dSP; 1616 const char *tmps; 1617 1618 if (MAXARG < 1) 1619 tmps = ""; 1620 else 1621 tmps = POPpconstx; 1622 sv_reset((char *)tmps, CopSTASH(PL_curcop)); 1623 PUSHs(&PL_sv_yes); 1624 RETURN; 1625 } 1626 1627 PP(pp_lineseq) 1628 { 1629 return NORMAL; 1630 } 1631 1632 /* like pp_nextstate, but used instead when the debugger is active */ 1633 1634 PP(pp_dbstate) 1635 { 1636 PL_curcop = (COP*)PL_op; 1637 TAINT_NOT; /* Each statement is presumed innocent */ 1638 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; 1639 FREETMPS; 1640 1641 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */ 1642 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) 1643 { 1644 dSP; 1645 register CV *cv; 1646 register PERL_CONTEXT *cx; 1647 const I32 gimme = G_ARRAY; 1648 U8 hasargs; 1649 GV *gv; 1650 1651 gv = PL_DBgv; 1652 cv = GvCV(gv); 1653 if (!cv) 1654 DIE(aTHX_ "No DB::DB routine defined"); 1655 1656 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG)) 1657 /* don't do recursive DB::DB call */ 1658 return NORMAL; 1659 1660 ENTER; 1661 SAVETMPS; 1662 1663 SAVEI32(PL_debug); 1664 SAVESTACK_POS(); 1665 PL_debug = 0; 1666 hasargs = 0; 1667 SPAGAIN; 1668 1669 if (CvXSUB(cv)) { 1670 CvDEPTH(cv)++; 1671 PUSHMARK(SP); 1672 (void)(*CvXSUB(cv))(aTHX_ cv); 1673 1674 CvDEPTH(cv)--; 1675 FREETMPS; 1676 LEAVE; 1677 return NORMAL; 1678 } else { 1679 push_return(PL_op->op_next); 1680 PUSHBLOCK(cx, CXt_SUB, SP); 1681 PUSHSUB_DB(cx); 1682 CvDEPTH(cv)++; 1683 SAVECOMPPAD(); 1684 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); 1685 RETURNOP(CvSTART(cv)); 1686 } 1687 } 1688 else 1689 return NORMAL; 1690 } 1691 1692 PP(pp_scope) 1693 { 1694 return NORMAL; 1695 } 1696 1697 PP(pp_enteriter) 1698 { 1699 dSP; dMARK; 1700 register PERL_CONTEXT *cx; 1701 const I32 gimme = GIMME_V; 1702 SV **svp; 1703 U32 cxtype = CXt_LOOP; 1704 #ifdef USE_ITHREADS 1705 void *iterdata; 1706 #endif 1707 1708 ENTER; 1709 SAVETMPS; 1710 1711 #ifdef USE_5005THREADS 1712 if (PL_op->op_flags & OPf_SPECIAL) { 1713 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */ 1714 SAVEGENERICSV(*svp); 1715 *svp = NEWSV(0,0); 1716 } 1717 else 1718 #endif /* USE_5005THREADS */ 1719 if (PL_op->op_targ) { 1720 #ifndef USE_ITHREADS 1721 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */ 1722 SAVESPTR(*svp); 1723 #else 1724 SAVEPADSV(PL_op->op_targ); 1725 iterdata = INT2PTR(void*, PL_op->op_targ); 1726 cxtype |= CXp_PADVAR; 1727 #endif 1728 } 1729 else { 1730 GV *gv = (GV*)POPs; 1731 svp = &GvSV(gv); /* symbol table variable */ 1732 SAVEGENERICSV(*svp); 1733 *svp = NEWSV(0,0); 1734 #ifdef USE_ITHREADS 1735 iterdata = (void*)gv; 1736 #endif 1737 } 1738 1739 ENTER; 1740 1741 PUSHBLOCK(cx, cxtype, SP); 1742 #ifdef USE_ITHREADS 1743 PUSHLOOP(cx, iterdata, MARK); 1744 #else 1745 PUSHLOOP(cx, svp, MARK); 1746 #endif 1747 if (PL_op->op_flags & OPf_STACKED) { 1748 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); 1749 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) { 1750 dPOPss; 1751 SV *right = (SV*)cx->blk_loop.iterary; 1752 SvGETMAGIC(sv); 1753 SvGETMAGIC(right); 1754 if (RANGE_IS_NUMERIC(sv,right)) { 1755 if ((SvOK(sv) && SvNV(sv) < IV_MIN) || 1756 (SvOK(right) && SvNV(right) >= IV_MAX)) 1757 DIE(aTHX_ "Range iterator outside integer range"); 1758 cx->blk_loop.iterix = SvIV(sv); 1759 cx->blk_loop.itermax = SvIV(right); 1760 #ifdef DEBUGGING 1761 /* for correct -Dstv display */ 1762 cx->blk_oldsp = sp - PL_stack_base; 1763 #endif 1764 } 1765 else { 1766 cx->blk_loop.iterlval = newSVsv(sv); 1767 (void) SvPV_force_nolen(cx->blk_loop.iterlval); 1768 (void) SvPV_nolen_const(right); 1769 } 1770 } 1771 else if (PL_op->op_private & OPpITER_REVERSED) { 1772 cx->blk_loop.itermax = 0; 1773 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1; 1774 1775 } 1776 } 1777 else { 1778 cx->blk_loop.iterary = PL_curstack; 1779 AvFILLp(PL_curstack) = SP - PL_stack_base; 1780 if (PL_op->op_private & OPpITER_REVERSED) { 1781 cx->blk_loop.itermax = MARK - PL_stack_base + 1; 1782 cx->blk_loop.iterix = cx->blk_oldsp + 1; 1783 } 1784 else { 1785 cx->blk_loop.iterix = MARK - PL_stack_base; 1786 } 1787 } 1788 1789 RETURN; 1790 } 1791 1792 PP(pp_enterloop) 1793 { 1794 dSP; 1795 register PERL_CONTEXT *cx; 1796 const I32 gimme = GIMME_V; 1797 1798 ENTER; 1799 SAVETMPS; 1800 ENTER; 1801 1802 PUSHBLOCK(cx, CXt_LOOP, SP); 1803 PUSHLOOP(cx, 0, SP); 1804 1805 RETURN; 1806 } 1807 1808 PP(pp_leaveloop) 1809 { 1810 dSP; 1811 register PERL_CONTEXT *cx; 1812 I32 gimme; 1813 SV **newsp; 1814 PMOP *newpm; 1815 SV **mark; 1816 1817 POPBLOCK(cx,newpm); 1818 assert(CxTYPE(cx) == CXt_LOOP); 1819 mark = newsp; 1820 newsp = PL_stack_base + cx->blk_loop.resetsp; 1821 1822 TAINT_NOT; 1823 if (gimme == G_VOID) 1824 ; /* do nothing */ 1825 else if (gimme == G_SCALAR) { 1826 if (mark < SP) 1827 *++newsp = sv_mortalcopy(*SP); 1828 else 1829 *++newsp = &PL_sv_undef; 1830 } 1831 else { 1832 while (mark < SP) { 1833 *++newsp = sv_mortalcopy(*++mark); 1834 TAINT_NOT; /* Each item is independent */ 1835 } 1836 } 1837 SP = newsp; 1838 PUTBACK; 1839 1840 POPLOOP(cx); /* Stack values are safe: release loop vars ... */ 1841 PL_curpm = newpm; /* ... and pop $1 et al */ 1842 1843 LEAVE; 1844 LEAVE; 1845 1846 return NORMAL; 1847 } 1848 1849 PP(pp_return) 1850 { 1851 dSP; dMARK; 1852 I32 cxix; 1853 register PERL_CONTEXT *cx; 1854 bool popsub2 = FALSE; 1855 bool clear_errsv = FALSE; 1856 I32 gimme; 1857 SV **newsp; 1858 PMOP *newpm; 1859 I32 optype = 0; 1860 SV *sv; 1861 1862 if (PL_curstackinfo->si_type == PERLSI_SORT) { 1863 if (cxstack_ix == PL_sortcxix 1864 || dopoptosub(cxstack_ix) <= PL_sortcxix) 1865 { 1866 if (cxstack_ix > PL_sortcxix) 1867 dounwind(PL_sortcxix); 1868 AvARRAY(PL_curstack)[1] = *SP; 1869 PL_stack_sp = PL_stack_base + 1; 1870 return 0; 1871 } 1872 } 1873 1874 cxix = dopoptosub(cxstack_ix); 1875 if (cxix < 0) 1876 DIE(aTHX_ "Can't return outside a subroutine"); 1877 if (cxix < cxstack_ix) 1878 dounwind(cxix); 1879 1880 POPBLOCK(cx,newpm); 1881 switch (CxTYPE(cx)) { 1882 case CXt_SUB: 1883 popsub2 = TRUE; 1884 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */ 1885 break; 1886 case CXt_EVAL: 1887 if (!(PL_in_eval & EVAL_KEEPERR)) 1888 clear_errsv = TRUE; 1889 POPEVAL(cx); 1890 if (CxTRYBLOCK(cx)) 1891 break; 1892 lex_end(); 1893 if (optype == OP_REQUIRE && 1894 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) 1895 { 1896 /* Unassume the success we assumed earlier. */ 1897 SV * const nsv = cx->blk_eval.old_namesv; 1898 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); 1899 DIE(aTHX_ "%"SVf" did not return a true value", nsv); 1900 } 1901 break; 1902 case CXt_FORMAT: 1903 POPFORMAT(cx); 1904 break; 1905 default: 1906 DIE(aTHX_ "panic: return"); 1907 } 1908 1909 TAINT_NOT; 1910 if (gimme == G_SCALAR) { 1911 if (MARK < SP) { 1912 if (popsub2) { 1913 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { 1914 if (SvTEMP(TOPs)) { 1915 *++newsp = SvREFCNT_inc(*SP); 1916 FREETMPS; 1917 sv_2mortal(*newsp); 1918 } 1919 else { 1920 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */ 1921 FREETMPS; 1922 *++newsp = sv_mortalcopy(sv); 1923 SvREFCNT_dec(sv); 1924 } 1925 } 1926 else 1927 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); 1928 } 1929 else 1930 *++newsp = sv_mortalcopy(*SP); 1931 } 1932 else 1933 *++newsp = &PL_sv_undef; 1934 } 1935 else if (gimme == G_ARRAY) { 1936 while (++MARK <= SP) { 1937 *++newsp = (popsub2 && SvTEMP(*MARK)) 1938 ? *MARK : sv_mortalcopy(*MARK); 1939 TAINT_NOT; /* Each item is independent */ 1940 } 1941 } 1942 PL_stack_sp = newsp; 1943 1944 LEAVE; 1945 /* Stack values are safe: */ 1946 if (popsub2) { 1947 cxstack_ix--; 1948 POPSUB(cx,sv); /* release CV and @_ ... */ 1949 } 1950 else 1951 sv = Nullsv; 1952 PL_curpm = newpm; /* ... and pop $1 et al */ 1953 1954 LEAVESUB(sv); 1955 if (clear_errsv) 1956 sv_setpvn(ERRSV,"",0); 1957 return pop_return(); 1958 } 1959 1960 PP(pp_last) 1961 { 1962 dSP; 1963 I32 cxix; 1964 register PERL_CONTEXT *cx; 1965 I32 pop2 = 0; 1966 I32 gimme; 1967 I32 optype; 1968 OP *nextop; 1969 SV **newsp; 1970 PMOP *newpm; 1971 SV **mark; 1972 SV *sv = Nullsv; 1973 1974 1975 if (PL_op->op_flags & OPf_SPECIAL) { 1976 cxix = dopoptoloop(cxstack_ix); 1977 if (cxix < 0) 1978 DIE(aTHX_ "Can't \"last\" outside a loop block"); 1979 } 1980 else { 1981 cxix = dopoptolabel(cPVOP->op_pv); 1982 if (cxix < 0) 1983 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv); 1984 } 1985 if (cxix < cxstack_ix) 1986 dounwind(cxix); 1987 1988 POPBLOCK(cx,newpm); 1989 cxstack_ix++; /* temporarily protect top context */ 1990 mark = newsp; 1991 switch (CxTYPE(cx)) { 1992 case CXt_LOOP: 1993 pop2 = CXt_LOOP; 1994 newsp = PL_stack_base + cx->blk_loop.resetsp; 1995 nextop = cx->blk_loop.last_op->op_next; 1996 break; 1997 case CXt_SUB: 1998 pop2 = CXt_SUB; 1999 nextop = pop_return(); 2000 break; 2001 case CXt_EVAL: 2002 POPEVAL(cx); 2003 nextop = pop_return(); 2004 break; 2005 case CXt_FORMAT: 2006 POPFORMAT(cx); 2007 nextop = pop_return(); 2008 break; 2009 default: 2010 DIE(aTHX_ "panic: last"); 2011 } 2012 2013 TAINT_NOT; 2014 if (gimme == G_SCALAR) { 2015 if (MARK < SP) 2016 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP)) 2017 ? *SP : sv_mortalcopy(*SP); 2018 else 2019 *++newsp = &PL_sv_undef; 2020 } 2021 else if (gimme == G_ARRAY) { 2022 while (++MARK <= SP) { 2023 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK)) 2024 ? *MARK : sv_mortalcopy(*MARK); 2025 TAINT_NOT; /* Each item is independent */ 2026 } 2027 } 2028 SP = newsp; 2029 PUTBACK; 2030 2031 LEAVE; 2032 cxstack_ix--; 2033 /* Stack values are safe: */ 2034 switch (pop2) { 2035 case CXt_LOOP: 2036 POPLOOP(cx); /* release loop vars ... */ 2037 LEAVE; 2038 break; 2039 case CXt_SUB: 2040 POPSUB(cx,sv); /* release CV and @_ ... */ 2041 break; 2042 } 2043 PL_curpm = newpm; /* ... and pop $1 et al */ 2044 2045 LEAVESUB(sv); 2046 PERL_UNUSED_VAR(optype); 2047 PERL_UNUSED_VAR(gimme); 2048 return nextop; 2049 } 2050 2051 PP(pp_next) 2052 { 2053 I32 cxix; 2054 register PERL_CONTEXT *cx; 2055 I32 inner; 2056 2057 if (PL_op->op_flags & OPf_SPECIAL) { 2058 cxix = dopoptoloop(cxstack_ix); 2059 if (cxix < 0) 2060 DIE(aTHX_ "Can't \"next\" outside a loop block"); 2061 } 2062 else { 2063 cxix = dopoptolabel(cPVOP->op_pv); 2064 if (cxix < 0) 2065 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv); 2066 } 2067 if (cxix < cxstack_ix) 2068 dounwind(cxix); 2069 2070 /* clear off anything above the scope we're re-entering, but 2071 * save the rest until after a possible continue block */ 2072 inner = PL_scopestack_ix; 2073 TOPBLOCK(cx); 2074 if (PL_scopestack_ix < inner) 2075 leave_scope(PL_scopestack[PL_scopestack_ix]); 2076 PL_curcop = cx->blk_oldcop; 2077 return cx->blk_loop.next_op; 2078 } 2079 2080 PP(pp_redo) 2081 { 2082 I32 cxix; 2083 register PERL_CONTEXT *cx; 2084 I32 oldsave; 2085 2086 if (PL_op->op_flags & OPf_SPECIAL) { 2087 cxix = dopoptoloop(cxstack_ix); 2088 if (cxix < 0) 2089 DIE(aTHX_ "Can't \"redo\" outside a loop block"); 2090 } 2091 else { 2092 cxix = dopoptolabel(cPVOP->op_pv); 2093 if (cxix < 0) 2094 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv); 2095 } 2096 if (cxix < cxstack_ix) 2097 dounwind(cxix); 2098 2099 TOPBLOCK(cx); 2100 oldsave = PL_scopestack[PL_scopestack_ix - 1]; 2101 LEAVE_SCOPE(oldsave); 2102 FREETMPS; 2103 PL_curcop = cx->blk_oldcop; 2104 return cx->blk_loop.redo_op; 2105 } 2106 2107 STATIC OP * 2108 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) 2109 { 2110 OP **ops = opstack; 2111 static const char too_deep[] = "Target of goto is too deeply nested"; 2112 2113 if (ops >= oplimit) 2114 Perl_croak(aTHX_ too_deep); 2115 if (o->op_type == OP_LEAVE || 2116 o->op_type == OP_SCOPE || 2117 o->op_type == OP_LEAVELOOP || 2118 o->op_type == OP_LEAVESUB || 2119 o->op_type == OP_LEAVETRY) 2120 { 2121 *ops++ = cUNOPo->op_first; 2122 if (ops >= oplimit) 2123 Perl_croak(aTHX_ too_deep); 2124 } 2125 *ops = 0; 2126 if (o->op_flags & OPf_KIDS) { 2127 OP *kid; 2128 /* First try all the kids at this level, since that's likeliest. */ 2129 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 2130 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && 2131 kCOP->cop_label && strEQ(kCOP->cop_label, label)) 2132 return kid; 2133 } 2134 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 2135 if (kid == PL_lastgotoprobe) 2136 continue; 2137 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { 2138 if (ops == opstack) 2139 *ops++ = kid; 2140 else if (ops[-1]->op_type == OP_NEXTSTATE || 2141 ops[-1]->op_type == OP_DBSTATE) 2142 ops[-1] = kid; 2143 else 2144 *ops++ = kid; 2145 } 2146 if ((o = dofindlabel(kid, label, ops, oplimit))) 2147 return o; 2148 } 2149 } 2150 *ops = 0; 2151 return 0; 2152 } 2153 2154 PP(pp_dump) 2155 { 2156 return pp_goto(); 2157 /*NOTREACHED*/ 2158 } 2159 2160 PP(pp_goto) 2161 { 2162 dSP; 2163 OP *retop = 0; 2164 I32 ix; 2165 register PERL_CONTEXT *cx; 2166 #define GOTO_DEPTH 64 2167 OP *enterops[GOTO_DEPTH]; 2168 const char *label = 0; 2169 const bool do_dump = (PL_op->op_type == OP_DUMP); 2170 static const char must_have_label[] = "goto must have label"; 2171 2172 if (PL_op->op_flags & OPf_STACKED) { 2173 SV * const sv = POPs; 2174 2175 /* This egregious kludge implements goto &subroutine */ 2176 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { 2177 I32 cxix; 2178 register PERL_CONTEXT *cx; 2179 CV* cv = (CV*)SvRV(sv); 2180 SV** mark; 2181 I32 items = 0; 2182 I32 oldsave; 2183 bool reified = 0; 2184 2185 retry: 2186 if (!CvROOT(cv) && !CvXSUB(cv)) { 2187 const GV * const gv = CvGV(cv); 2188 if (gv) { 2189 GV *autogv; 2190 SV *tmpstr; 2191 /* autoloaded stub? */ 2192 if (cv != GvCV(gv) && (cv = GvCV(gv))) 2193 goto retry; 2194 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), 2195 GvNAMELEN(gv), FALSE); 2196 if (autogv && (cv = GvCV(autogv))) 2197 goto retry; 2198 tmpstr = sv_newmortal(); 2199 gv_efullname3(tmpstr, (GV *) gv, Nullch); 2200 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr); 2201 } 2202 DIE(aTHX_ "Goto undefined subroutine"); 2203 } 2204 2205 /* First do some returnish stuff. */ 2206 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */ 2207 FREETMPS; 2208 cxix = dopoptosub(cxstack_ix); 2209 if (cxix < 0) 2210 DIE(aTHX_ "Can't goto subroutine outside a subroutine"); 2211 if (cxix < cxstack_ix) 2212 dounwind(cxix); 2213 TOPBLOCK(cx); 2214 SPAGAIN; 2215 if (CxTYPE(cx) == CXt_EVAL) { 2216 if (CxREALEVAL(cx)) 2217 DIE(aTHX_ "Can't goto subroutine from an eval-string"); 2218 else 2219 DIE(aTHX_ "Can't goto subroutine from an eval-block"); 2220 } 2221 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { 2222 /* put @_ back onto stack */ 2223 AV* av = cx->blk_sub.argarray; 2224 2225 items = AvFILLp(av) + 1; 2226 EXTEND(SP, items+1); /* @_ could have been extended. */ 2227 Copy(AvARRAY(av), SP + 1, items, SV*); 2228 #ifndef USE_5005THREADS 2229 SvREFCNT_dec(GvAV(PL_defgv)); 2230 GvAV(PL_defgv) = cx->blk_sub.savearray; 2231 #endif /* USE_5005THREADS */ 2232 CLEAR_ARGARRAY(av); 2233 /* abandon @_ if it got reified */ 2234 if (AvREAL(av)) { 2235 reified = 1; 2236 SvREFCNT_dec(av); 2237 av = newAV(); 2238 av_extend(av, items-1); 2239 AvFLAGS(av) = AVf_REIFY; 2240 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av); 2241 } 2242 } 2243 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ 2244 #ifdef USE_5005THREADS 2245 AV* const av = (AV*)PAD_SVl(0); 2246 #else 2247 AV* const av = GvAV(PL_defgv); 2248 #endif 2249 items = AvFILLp(av) + 1; 2250 EXTEND(SP, items+1); /* @_ could have been extended. */ 2251 Copy(AvARRAY(av), SP + 1, items, SV*); 2252 } 2253 mark = SP; 2254 SP += items; 2255 if (CxTYPE(cx) == CXt_SUB && 2256 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) 2257 SvREFCNT_dec(cx->blk_sub.cv); 2258 oldsave = PL_scopestack[PL_scopestack_ix - 1]; 2259 LEAVE_SCOPE(oldsave); 2260 2261 /* Now do some callish stuff. */ 2262 SAVETMPS; 2263 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ 2264 if (CvXSUB(cv)) { 2265 if (reified) { 2266 I32 index; 2267 for (index=0; index<items; index++) 2268 sv_2mortal(SP[-index]); 2269 } 2270 #ifdef PERL_XSUB_OLDSTYLE 2271 if (CvOLDSTYLE(cv)) { 2272 I32 (*fp3)(int,int,int); 2273 while (SP > mark) { 2274 SP[1] = SP[0]; 2275 SP--; 2276 } 2277 fp3 = (I32(*)(int,int,int))CvXSUB(cv); 2278 items = (*fp3)(CvXSUBANY(cv).any_i32, 2279 mark - PL_stack_base + 1, 2280 items); 2281 SP = PL_stack_base + items; 2282 } 2283 else 2284 #endif /* PERL_XSUB_OLDSTYLE */ 2285 { 2286 SV **newsp; 2287 I32 gimme; 2288 2289 /* Push a mark for the start of arglist */ 2290 PUSHMARK(mark); 2291 PUTBACK; 2292 (void)(*CvXSUB(cv))(aTHX_ cv); 2293 2294 /* Pop the current context like a decent sub should */ 2295 POPBLOCK(cx, PL_curpm); 2296 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */ 2297 2298 /* Put these at the bottom since the vars are set but not used */ 2299 PERL_UNUSED_VAR(newsp); 2300 PERL_UNUSED_VAR(gimme); 2301 } 2302 LEAVE; 2303 return pop_return(); 2304 } 2305 else { 2306 AV* padlist = CvPADLIST(cv); 2307 if (CxTYPE(cx) == CXt_EVAL) { 2308 PL_in_eval = cx->blk_eval.old_in_eval; 2309 PL_eval_root = cx->blk_eval.old_eval_root; 2310 cx->cx_type = CXt_SUB; 2311 cx->blk_sub.hasargs = 0; 2312 } 2313 cx->blk_sub.cv = cv; 2314 cx->blk_sub.olddepth = (U16)CvDEPTH(cv); 2315 2316 CvDEPTH(cv)++; 2317 if (CvDEPTH(cv) < 2) 2318 (void)SvREFCNT_inc(cv); 2319 else { 2320 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) 2321 sub_crush_depth(cv); 2322 pad_push(padlist, CvDEPTH(cv), 1); 2323 } 2324 #ifdef USE_5005THREADS 2325 if (!cx->blk_sub.hasargs) { 2326 AV* av = (AV*)PAD_SVl(0); 2327 2328 items = AvFILLp(av) + 1; 2329 if (items) { 2330 /* Mark is at the end of the stack. */ 2331 EXTEND(SP, items); 2332 Copy(AvARRAY(av), SP + 1, items, SV*); 2333 SP += items; 2334 PUTBACK ; 2335 } 2336 } 2337 #endif /* USE_5005THREADS */ 2338 SAVECOMPPAD(); 2339 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); 2340 #ifndef USE_5005THREADS 2341 if (cx->blk_sub.hasargs) 2342 #endif /* USE_5005THREADS */ 2343 { 2344 AV* av = (AV*)PAD_SVl(0); 2345 SV** ary; 2346 2347 #ifndef USE_5005THREADS 2348 cx->blk_sub.savearray = GvAV(PL_defgv); 2349 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); 2350 #endif /* USE_5005THREADS */ 2351 CX_CURPAD_SAVE(cx->blk_sub); 2352 cx->blk_sub.argarray = av; 2353 2354 if (items >= AvMAX(av) + 1) { 2355 ary = AvALLOC(av); 2356 if (AvARRAY(av) != ary) { 2357 AvMAX(av) += AvARRAY(av) - AvALLOC(av); 2358 SvPV_set(av, (char*)ary); 2359 } 2360 if (items >= AvMAX(av) + 1) { 2361 AvMAX(av) = items - 1; 2362 Renew(ary,items+1,SV*); 2363 AvALLOC(av) = ary; 2364 SvPV_set(av, (char*)ary); 2365 } 2366 } 2367 ++mark; 2368 Copy(mark,AvARRAY(av),items,SV*); 2369 AvFILLp(av) = items - 1; 2370 assert(!AvREAL(av)); 2371 if (reified) { 2372 /* transfer 'ownership' of refcnts to new @_ */ 2373 AvREAL_on(av); 2374 AvREIFY_off(av); 2375 } 2376 while (items--) { 2377 if (*mark) 2378 SvTEMP_off(*mark); 2379 mark++; 2380 } 2381 } 2382 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ 2383 /* 2384 * We do not care about using sv to call CV; 2385 * it's for informational purposes only. 2386 */ 2387 SV * const sv = GvSV(PL_DBsub); 2388 CV *gotocv; 2389 2390 save_item(sv); 2391 if (PERLDB_SUB_NN) { 2392 const int type = SvTYPE(sv); 2393 if (type < SVt_PVIV && type != SVt_IV) 2394 sv_upgrade(sv, SVt_PVIV); 2395 (void)SvIOK_on(sv); 2396 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */ 2397 } else { 2398 gv_efullname3(sv, CvGV(cv), Nullch); 2399 } 2400 if ( PERLDB_GOTO 2401 && (gotocv = get_cv("DB::goto", FALSE)) ) { 2402 PUSHMARK( PL_stack_sp ); 2403 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); 2404 PL_stack_sp--; 2405 } 2406 } 2407 RETURNOP(CvSTART(cv)); 2408 } 2409 } 2410 else { 2411 label = SvPV_nolen_const(sv); 2412 if (!(do_dump || *label)) 2413 DIE(aTHX_ must_have_label); 2414 } 2415 } 2416 else if (PL_op->op_flags & OPf_SPECIAL) { 2417 if (! do_dump) 2418 DIE(aTHX_ must_have_label); 2419 } 2420 else 2421 label = cPVOP->op_pv; 2422 2423 if (label && *label) { 2424 OP *gotoprobe = 0; 2425 bool leaving_eval = FALSE; 2426 bool in_block = FALSE; 2427 PERL_CONTEXT *last_eval_cx = 0; 2428 2429 /* find label */ 2430 2431 PL_lastgotoprobe = 0; 2432 *enterops = 0; 2433 for (ix = cxstack_ix; ix >= 0; ix--) { 2434 cx = &cxstack[ix]; 2435 switch (CxTYPE(cx)) { 2436 case CXt_EVAL: 2437 leaving_eval = TRUE; 2438 if (!CxTRYBLOCK(cx)) { 2439 gotoprobe = (last_eval_cx ? 2440 last_eval_cx->blk_eval.old_eval_root : 2441 PL_eval_root); 2442 last_eval_cx = cx; 2443 break; 2444 } 2445 /* else fall through */ 2446 case CXt_LOOP: 2447 gotoprobe = cx->blk_oldcop->op_sibling; 2448 break; 2449 case CXt_SUBST: 2450 continue; 2451 case CXt_BLOCK: 2452 if (ix) { 2453 gotoprobe = cx->blk_oldcop->op_sibling; 2454 in_block = TRUE; 2455 } else 2456 gotoprobe = PL_main_root; 2457 break; 2458 case CXt_SUB: 2459 if (CvDEPTH(cx->blk_sub.cv)) { 2460 gotoprobe = CvROOT(cx->blk_sub.cv); 2461 break; 2462 } 2463 /* FALL THROUGH */ 2464 case CXt_FORMAT: 2465 case CXt_NULL: 2466 DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); 2467 default: 2468 if (ix) 2469 DIE(aTHX_ "panic: goto"); 2470 gotoprobe = PL_main_root; 2471 break; 2472 } 2473 if (gotoprobe) { 2474 retop = dofindlabel(gotoprobe, label, 2475 enterops, enterops + GOTO_DEPTH); 2476 if (retop) 2477 break; 2478 } 2479 PL_lastgotoprobe = gotoprobe; 2480 } 2481 if (!retop) 2482 DIE(aTHX_ "Can't find label %s", label); 2483 2484 /* if we're leaving an eval, check before we pop any frames 2485 that we're not going to punt, otherwise the error 2486 won't be caught */ 2487 2488 if (leaving_eval && *enterops && enterops[1]) { 2489 I32 i; 2490 for (i = 1; enterops[i]; i++) 2491 if (enterops[i]->op_type == OP_ENTERITER) 2492 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); 2493 } 2494 2495 /* pop unwanted frames */ 2496 2497 if (ix < cxstack_ix) { 2498 I32 oldsave; 2499 2500 if (ix < 0) 2501 ix = 0; 2502 dounwind(ix); 2503 TOPBLOCK(cx); 2504 oldsave = PL_scopestack[PL_scopestack_ix]; 2505 LEAVE_SCOPE(oldsave); 2506 } 2507 2508 /* push wanted frames */ 2509 2510 if (*enterops && enterops[1]) { 2511 OP *oldop = PL_op; 2512 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; 2513 for (; enterops[ix]; ix++) { 2514 PL_op = enterops[ix]; 2515 /* Eventually we may want to stack the needed arguments 2516 * for each op. For now, we punt on the hard ones. */ 2517 if (PL_op->op_type == OP_ENTERITER) 2518 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop"); 2519 CALL_FPTR(PL_op->op_ppaddr)(aTHX); 2520 } 2521 PL_op = oldop; 2522 } 2523 } 2524 2525 if (do_dump) { 2526 #ifdef VMS 2527 if (!retop) retop = PL_main_start; 2528 #endif 2529 PL_restartop = retop; 2530 PL_do_undump = TRUE; 2531 2532 my_unexec(); 2533 2534 PL_restartop = 0; /* hmm, must be GNU unexec().. */ 2535 PL_do_undump = FALSE; 2536 } 2537 2538 RETURNOP(retop); 2539 } 2540 2541 PP(pp_exit) 2542 { 2543 dSP; 2544 I32 anum; 2545 2546 if (MAXARG < 1) 2547 anum = 0; 2548 else { 2549 anum = SvIVx(POPs); 2550 #ifdef VMS 2551 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH)) 2552 anum = 0; 2553 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); 2554 #endif 2555 } 2556 PL_exit_flags |= PERL_EXIT_EXPECTED; 2557 my_exit(anum); 2558 PUSHs(&PL_sv_undef); 2559 RETURN; 2560 } 2561 2562 #ifdef NOTYET 2563 PP(pp_nswitch) 2564 { 2565 dSP; 2566 const NV value = SvNVx(GvSV(cCOP->cop_gv)); 2567 register I32 match = I_32(value); 2568 2569 if (value < 0.0) { 2570 if (((NV)match) > value) 2571 --match; /* was fractional--truncate other way */ 2572 } 2573 match -= cCOP->uop.scop.scop_offset; 2574 if (match < 0) 2575 match = 0; 2576 else if (match > cCOP->uop.scop.scop_max) 2577 match = cCOP->uop.scop.scop_max; 2578 PL_op = cCOP->uop.scop.scop_next[match]; 2579 RETURNOP(PL_op); 2580 } 2581 2582 PP(pp_cswitch) 2583 { 2584 dSP; 2585 register I32 match; 2586 2587 if (PL_multiline) 2588 PL_op = PL_op->op_next; /* can't assume anything */ 2589 else { 2590 match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255; 2591 match -= cCOP->uop.scop.scop_offset; 2592 if (match < 0) 2593 match = 0; 2594 else if (match > cCOP->uop.scop.scop_max) 2595 match = cCOP->uop.scop.scop_max; 2596 PL_op = cCOP->uop.scop.scop_next[match]; 2597 } 2598 RETURNOP(PL_op); 2599 } 2600 #endif 2601 2602 /* Eval. */ 2603 2604 STATIC void 2605 S_save_lines(pTHX_ AV *array, SV *sv) 2606 { 2607 const char *s = SvPVX_const(sv); 2608 const char * const send = SvPVX_const(sv) + SvCUR(sv); 2609 I32 line = 1; 2610 2611 while (s && s < send) { 2612 const char *t; 2613 SV * const tmpstr = NEWSV(85,0); 2614 2615 sv_upgrade(tmpstr, SVt_PVMG); 2616 t = strchr(s, '\n'); 2617 if (t) 2618 t++; 2619 else 2620 t = send; 2621 2622 sv_setpvn(tmpstr, s, t - s); 2623 av_store(array, line++, tmpstr); 2624 s = t; 2625 } 2626 } 2627 2628 #ifdef PERL_FLEXIBLE_EXCEPTIONS 2629 STATIC void * 2630 S_docatch_body(pTHX_ va_list args) 2631 { 2632 return docatch_body(); 2633 } 2634 #endif 2635 2636 STATIC void 2637 S_docatch_body(pTHX) 2638 { 2639 CALLRUNOPS(aTHX); 2640 return; 2641 } 2642 2643 STATIC OP * 2644 S_docatch(pTHX_ OP *o) 2645 { 2646 int ret; 2647 OP * const oldop = PL_op; 2648 OP *retop; 2649 volatile PERL_SI *cursi = PL_curstackinfo; 2650 dJMPENV; 2651 2652 #ifdef DEBUGGING 2653 assert(CATCH_GET == TRUE); 2654 #endif 2655 PL_op = o; 2656 2657 /* Normally, the leavetry at the end of this block of ops will 2658 * pop an op off the return stack and continue there. By setting 2659 * the op to Nullop, we force an exit from the inner runops() 2660 * loop. DAPM. 2661 */ 2662 retop = pop_return(); 2663 push_return(Nullop); 2664 2665 #ifdef PERL_FLEXIBLE_EXCEPTIONS 2666 redo_body: 2667 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body)); 2668 #else 2669 JMPENV_PUSH(ret); 2670 #endif 2671 switch (ret) { 2672 case 0: 2673 #ifndef PERL_FLEXIBLE_EXCEPTIONS 2674 redo_body: 2675 docatch_body(); 2676 #endif 2677 break; 2678 case 3: 2679 /* die caught by an inner eval - continue inner loop */ 2680 if (PL_restartop && cursi == PL_curstackinfo) { 2681 PL_op = PL_restartop; 2682 PL_restartop = 0; 2683 goto redo_body; 2684 } 2685 /* a die in this eval - continue in outer loop */ 2686 if (!PL_restartop) 2687 break; 2688 /* FALL THROUGH */ 2689 default: 2690 JMPENV_POP; 2691 PL_op = oldop; 2692 JMPENV_JUMP(ret); 2693 /* NOTREACHED */ 2694 } 2695 JMPENV_POP; 2696 PL_op = oldop; 2697 return retop; 2698 } 2699 2700 OP * 2701 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) 2702 /* sv Text to convert to OP tree. */ 2703 /* startop op_free() this to undo. */ 2704 /* code Short string id of the caller. */ 2705 { 2706 dSP; /* Make POPBLOCK work. */ 2707 PERL_CONTEXT *cx; 2708 SV **newsp; 2709 I32 gimme = G_VOID; 2710 I32 optype; 2711 OP dummy; 2712 OP *rop; 2713 char tbuf[TYPE_DIGITS(long) + 12 + 10]; 2714 char *tmpbuf = tbuf; 2715 char *safestr; 2716 int runtime; 2717 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */ 2718 2719 ENTER; 2720 lex_start(sv); 2721 SAVETMPS; 2722 /* switch to eval mode */ 2723 2724 if (IN_PERL_COMPILETIME) { 2725 SAVECOPSTASH_FREE(&PL_compiling); 2726 CopSTASH_set(&PL_compiling, PL_curstash); 2727 } 2728 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { 2729 SV * const sv = sv_newmortal(); 2730 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]", 2731 code, (unsigned long)++PL_evalseq, 2732 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 2733 tmpbuf = SvPVX(sv); 2734 } 2735 else 2736 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); 2737 SAVECOPFILE_FREE(&PL_compiling); 2738 CopFILE_set(&PL_compiling, tmpbuf+2); 2739 SAVECOPLINE(&PL_compiling); 2740 CopLINE_set(&PL_compiling, 1); 2741 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up 2742 deleting the eval's FILEGV from the stash before gv_check() runs 2743 (i.e. before run-time proper). To work around the coredump that 2744 ensues, we always turn GvMULTI_on for any globals that were 2745 introduced within evals. See force_ident(). GSAR 96-10-12 */ 2746 safestr = savepv(tmpbuf); 2747 SAVEDELETE(PL_defstash, safestr, strlen(safestr)); 2748 SAVEHINTS(); 2749 #ifdef OP_IN_REGISTER 2750 PL_opsave = op; 2751 #else 2752 SAVEVPTR(PL_op); 2753 #endif 2754 2755 /* we get here either during compilation, or via pp_regcomp at runtime */ 2756 runtime = IN_PERL_RUNTIME; 2757 if (runtime) 2758 runcv = find_runcv(NULL); 2759 2760 PL_op = &dummy; 2761 PL_op->op_type = OP_ENTEREVAL; 2762 PL_op->op_flags = 0; /* Avoid uninit warning. */ 2763 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP); 2764 PUSHEVAL(cx, 0, Nullgv); 2765 2766 if (runtime) 2767 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); 2768 else 2769 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); 2770 POPBLOCK(cx,PL_curpm); 2771 POPEVAL(cx); 2772 2773 (*startop)->op_type = OP_NULL; 2774 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL]; 2775 lex_end(); 2776 /* XXX DAPM do this properly one year */ 2777 *padp = (AV*)SvREFCNT_inc(PL_comppad); 2778 LEAVE; 2779 if (IN_PERL_COMPILETIME) 2780 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); 2781 #ifdef OP_IN_REGISTER 2782 op = PL_opsave; 2783 #endif 2784 PERL_UNUSED_VAR(newsp); 2785 PERL_UNUSED_VAR(optype); 2786 2787 return rop; 2788 } 2789 2790 2791 /* 2792 =for apidoc find_runcv 2793 2794 Locate the CV corresponding to the currently executing sub or eval. 2795 If db_seqp is non_null, skip CVs that are in the DB package and populate 2796 *db_seqp with the cop sequence number at the point that the DB:: code was 2797 entered. (allows debuggers to eval in the scope of the breakpoint rather 2798 than in the scope of the debugger itself). 2799 2800 =cut 2801 */ 2802 2803 CV* 2804 Perl_find_runcv(pTHX_ U32 *db_seqp) 2805 { 2806 PERL_SI *si; 2807 2808 if (db_seqp) 2809 *db_seqp = PL_curcop->cop_seq; 2810 for (si = PL_curstackinfo; si; si = si->si_prev) { 2811 I32 ix; 2812 for (ix = si->si_cxix; ix >= 0; ix--) { 2813 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]); 2814 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { 2815 CV * const cv = cx->blk_sub.cv; 2816 /* skip DB:: code */ 2817 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) { 2818 *db_seqp = cx->blk_oldcop->cop_seq; 2819 continue; 2820 } 2821 return cv; 2822 } 2823 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) 2824 return PL_compcv; 2825 } 2826 } 2827 return PL_main_cv; 2828 } 2829 2830 2831 /* Compile a require/do, an eval '', or a /(?{...})/. 2832 * In the last case, startop is non-null, and contains the address of 2833 * a pointer that should be set to the just-compiled code. 2834 * outside is the lexically enclosing CV (if any) that invoked us. 2835 */ 2836 2837 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */ 2838 STATIC OP * 2839 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) 2840 { 2841 dSP; 2842 OP * const saveop = PL_op; 2843 2844 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) 2845 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) 2846 : EVAL_INEVAL); 2847 2848 PUSHMARK(SP); 2849 2850 SAVESPTR(PL_compcv); 2851 PL_compcv = (CV*)NEWSV(1104,0); 2852 sv_upgrade((SV *)PL_compcv, SVt_PVCV); 2853 CvEVAL_on(PL_compcv); 2854 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); 2855 cxstack[cxstack_ix].blk_eval.cv = PL_compcv; 2856 2857 #ifdef USE_5005THREADS 2858 CvOWNER(PL_compcv) = 0; 2859 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex); 2860 MUTEX_INIT(CvMUTEXP(PL_compcv)); 2861 #endif /* USE_5005THREADS */ 2862 2863 CvOUTSIDE_SEQ(PL_compcv) = seq; 2864 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside); 2865 2866 /* set up a scratch pad */ 2867 2868 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE); 2869 2870 2871 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ 2872 2873 /* make sure we compile in the right package */ 2874 2875 if (CopSTASH_ne(PL_curcop, PL_curstash)) { 2876 SAVESPTR(PL_curstash); 2877 PL_curstash = CopSTASH(PL_curcop); 2878 } 2879 SAVESPTR(PL_beginav); 2880 PL_beginav = newAV(); 2881 SAVEFREESV(PL_beginav); 2882 SAVEI32(PL_error_count); 2883 2884 /* try to compile it */ 2885 2886 PL_eval_root = Nullop; 2887 PL_error_count = 0; 2888 PL_curcop = &PL_compiling; 2889 PL_curcop->cop_arybase = 0; 2890 if (saveop && saveop->op_flags & OPf_SPECIAL) 2891 PL_in_eval |= EVAL_KEEPERR; 2892 else 2893 sv_setpvn(ERRSV,"",0); 2894 if (yyparse() || PL_error_count || !PL_eval_root) { 2895 SV **newsp; /* Used by POPBLOCK. */ 2896 PERL_CONTEXT *cx; 2897 I32 optype = 0; /* Might be reset by POPEVAL. */ 2898 const char *msg; 2899 2900 PL_op = saveop; 2901 if (PL_eval_root) { 2902 op_free(PL_eval_root); 2903 PL_eval_root = Nullop; 2904 } 2905 SP = PL_stack_base + POPMARK; /* pop original mark */ 2906 if (!startop) { 2907 POPBLOCK(cx,PL_curpm); 2908 POPEVAL(cx); 2909 pop_return(); 2910 } 2911 lex_end(); 2912 LEAVE; 2913 2914 msg = SvPVx_nolen_const(ERRSV); 2915 if (optype == OP_REQUIRE) { 2916 const char* const msg = SvPVx_nolen_const(ERRSV); 2917 DIE(aTHX_ "%sCompilation failed in require", 2918 *msg ? msg : "Unknown error\n"); 2919 } 2920 else if (startop) { 2921 POPBLOCK(cx,PL_curpm); 2922 POPEVAL(cx); 2923 Perl_croak(aTHX_ "%sCompilation failed in regexp", 2924 (*msg ? msg : "Unknown error\n")); 2925 } 2926 else { 2927 if (!*msg) { 2928 sv_setpv(ERRSV, "Compilation error"); 2929 } 2930 } 2931 #ifdef USE_5005THREADS 2932 MUTEX_LOCK(&PL_eval_mutex); 2933 PL_eval_owner = 0; 2934 COND_SIGNAL(&PL_eval_cond); 2935 MUTEX_UNLOCK(&PL_eval_mutex); 2936 #endif /* USE_5005THREADS */ 2937 PERL_UNUSED_VAR(newsp); 2938 RETPUSHUNDEF; 2939 } 2940 CopLINE_set(&PL_compiling, 0); 2941 if (startop) { 2942 *startop = PL_eval_root; 2943 } else 2944 SAVEFREEOP(PL_eval_root); 2945 2946 /* Set the context for this new optree. 2947 * If the last op is an OP_REQUIRE, force scalar context. 2948 * Otherwise, propagate the context from the eval(). */ 2949 if (PL_eval_root->op_type == OP_LEAVEEVAL 2950 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ 2951 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type 2952 == OP_REQUIRE) 2953 scalar(PL_eval_root); 2954 else if (gimme & G_VOID) 2955 scalarvoid(PL_eval_root); 2956 else if (gimme & G_ARRAY) 2957 list(PL_eval_root); 2958 else 2959 scalar(PL_eval_root); 2960 2961 DEBUG_x(dump_eval()); 2962 2963 /* Register with debugger: */ 2964 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { 2965 CV * const cv = get_cv("DB::postponed", FALSE); 2966 if (cv) { 2967 dSP; 2968 PUSHMARK(SP); 2969 XPUSHs((SV*)CopFILEGV(&PL_compiling)); 2970 PUTBACK; 2971 call_sv((SV*)cv, G_DISCARD); 2972 } 2973 } 2974 2975 /* compiled okay, so do it */ 2976 2977 CvDEPTH(PL_compcv) = 1; 2978 SP = PL_stack_base + POPMARK; /* pop original mark */ 2979 PL_op = saveop; /* The caller may need it. */ 2980 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */ 2981 #ifdef USE_5005THREADS 2982 MUTEX_LOCK(&PL_eval_mutex); 2983 PL_eval_owner = 0; 2984 COND_SIGNAL(&PL_eval_cond); 2985 MUTEX_UNLOCK(&PL_eval_mutex); 2986 #endif /* USE_5005THREADS */ 2987 2988 RETURNOP(PL_eval_start); 2989 } 2990 2991 STATIC PerlIO * 2992 S_check_type_and_open(pTHX_ const char *name, const char *mode) 2993 { 2994 Stat_t st; 2995 int st_rc; 2996 st_rc = PerlLIO_stat(name, &st); 2997 if (st_rc < 0) { 2998 return Nullfp; 2999 } 3000 3001 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { 3002 Perl_die(aTHX_ "%s %s not allowed in require", 3003 S_ISDIR(st.st_mode) ? "Directory" : "Block device", name); 3004 } 3005 return PerlIO_open(name, mode); 3006 } 3007 3008 STATIC PerlIO * 3009 S_doopen_pm(pTHX_ const char *name, const char *mode) 3010 { 3011 #ifndef PERL_DISABLE_PMC 3012 const STRLEN namelen = strlen(name); 3013 PerlIO *fp; 3014 3015 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) { 3016 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c'); 3017 const char * const pmc = SvPV_nolen_const(pmcsv); 3018 Stat_t pmcstat; 3019 if (PerlLIO_stat(pmc, &pmcstat) < 0) { 3020 fp = check_type_and_open(name, mode); 3021 } 3022 else { 3023 Stat_t pmstat; 3024 if (PerlLIO_stat(name, &pmstat) < 0 || 3025 pmstat.st_mtime < pmcstat.st_mtime) 3026 { 3027 fp = check_type_and_open(pmc, mode); 3028 } 3029 else { 3030 fp = check_type_and_open(name, mode); 3031 } 3032 } 3033 SvREFCNT_dec(pmcsv); 3034 } 3035 else { 3036 fp = check_type_and_open(name, mode); 3037 } 3038 return fp; 3039 #else 3040 return check_type_and_open(name, mode); 3041 #endif /* !PERL_DISABLE_PMC */ 3042 } 3043 3044 PP(pp_require) 3045 { 3046 dSP; 3047 register PERL_CONTEXT *cx; 3048 SV *sv; 3049 const char *name; 3050 STRLEN len; 3051 const char *tryname = Nullch; 3052 SV *namesv = Nullsv; 3053 SV** svp; 3054 const I32 gimme = GIMME_V; 3055 PerlIO *tryrsfp = 0; 3056 int filter_has_file = 0; 3057 GV *filter_child_proc = 0; 3058 SV *filter_state = 0; 3059 SV *filter_sub = 0; 3060 SV *hook_sv = 0; 3061 SV *encoding; 3062 OP *op; 3063 3064 sv = POPs; 3065 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) { 3066 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */ 3067 UV rev = 0, ver = 0, sver = 0; 3068 STRLEN len; 3069 U8 *s = (U8*)SvPVX(sv); 3070 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv); 3071 if (s < end) { 3072 rev = utf8n_to_uvchr(s, end - s, &len, 0); 3073 s += len; 3074 if (s < end) { 3075 ver = utf8n_to_uvchr(s, end - s, &len, 0); 3076 s += len; 3077 if (s < end) 3078 sver = utf8n_to_uvchr(s, end - s, &len, 0); 3079 } 3080 } 3081 if (PERL_REVISION < rev 3082 || (PERL_REVISION == rev 3083 && (PERL_VERSION < ver 3084 || (PERL_VERSION == ver 3085 && PERL_SUBVERSION < sver)))) 3086 { 3087 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only " 3088 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION, 3089 PERL_VERSION, PERL_SUBVERSION); 3090 } 3091 RETPUSHYES; 3092 } 3093 else if (!SvPOKp(sv)) { /* require 5.005_03 */ 3094 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000) 3095 + ((NV)PERL_SUBVERSION/(NV)1000000) 3096 + 0.00000099 < SvNV(sv)) 3097 { 3098 NV nrev = SvNV(sv); 3099 UV rev = (UV)nrev; 3100 NV nver = (nrev - rev) * 1000; 3101 UV ver = (UV)(nver + 0.0009); 3102 NV nsver = (nver - ver) * 1000; 3103 UV sver = (UV)(nsver + 0.0009); 3104 3105 /* help out with the "use 5.6" confusion */ 3106 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) { 3107 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required" 3108 " (did you mean v%"UVuf".%03"UVuf"?)--" 3109 "this is only v%d.%d.%d, stopped", 3110 rev, ver, sver, rev, ver/100, 3111 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION); 3112 } 3113 else { 3114 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--" 3115 "this is only v%d.%d.%d, stopped", 3116 rev, ver, sver, PERL_REVISION, PERL_VERSION, 3117 PERL_SUBVERSION); 3118 } 3119 } 3120 RETPUSHYES; 3121 } 3122 } 3123 name = SvPV_const(sv, len); 3124 if (!(name && len > 0 && *name)) 3125 DIE(aTHX_ "Null filename used"); 3126 TAINT_PROPER("require"); 3127 if (PL_op->op_type == OP_REQUIRE && 3128 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) && 3129 *svp != &PL_sv_undef) 3130 RETPUSHYES; 3131 3132 /* prepare to compile file */ 3133 3134 if (path_is_absolute(name)) { 3135 tryname = name; 3136 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE); 3137 } 3138 #ifdef MACOS_TRADITIONAL 3139 if (!tryrsfp) { 3140 char newname[256]; 3141 3142 MacPerl_CanonDir(name, newname, 1); 3143 if (path_is_absolute(newname)) { 3144 tryname = newname; 3145 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE); 3146 } 3147 } 3148 #endif 3149 if (!tryrsfp) { 3150 AV * const ar = GvAVn(PL_incgv); 3151 I32 i; 3152 #ifdef VMS 3153 char *unixname; 3154 if ((unixname = tounixspec((char *)name, Nullch)) != Nullch) 3155 #endif 3156 { 3157 namesv = NEWSV(806, 0); 3158 for (i = 0; i <= AvFILL(ar); i++) { 3159 SV *dirsv = *av_fetch(ar, i, TRUE); 3160 3161 if (SvROK(dirsv)) { 3162 int count; 3163 SV *loader = dirsv; 3164 3165 if (SvTYPE(SvRV(loader)) == SVt_PVAV 3166 && !sv_isobject(loader)) 3167 { 3168 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE); 3169 } 3170 3171 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", 3172 PTR2UV(SvRV(dirsv)), name); 3173 tryname = SvPVX_const(namesv); 3174 tryrsfp = 0; 3175 3176 ENTER; 3177 SAVETMPS; 3178 EXTEND(SP, 2); 3179 3180 PUSHMARK(SP); 3181 PUSHs(dirsv); 3182 PUSHs(sv); 3183 PUTBACK; 3184 if (sv_isobject(loader)) 3185 count = call_method("INC", G_ARRAY); 3186 else 3187 count = call_sv(loader, G_ARRAY); 3188 SPAGAIN; 3189 3190 if (count > 0) { 3191 int i = 0; 3192 SV *arg; 3193 3194 SP -= count - 1; 3195 arg = SP[i++]; 3196 3197 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) { 3198 arg = SvRV(arg); 3199 } 3200 3201 if (SvTYPE(arg) == SVt_PVGV) { 3202 IO *io = GvIO((GV *)arg); 3203 3204 ++filter_has_file; 3205 3206 if (io) { 3207 tryrsfp = IoIFP(io); 3208 if (IoTYPE(io) == IoTYPE_PIPE) { 3209 /* reading from a child process doesn't 3210 nest -- when returning from reading 3211 the inner module, the outer one is 3212 unreadable (closed?) I've tried to 3213 save the gv to manage the lifespan of 3214 the pipe, but this didn't help. XXX */ 3215 filter_child_proc = (GV *)arg; 3216 (void)SvREFCNT_inc(filter_child_proc); 3217 } 3218 else { 3219 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { 3220 PerlIO_close(IoOFP(io)); 3221 } 3222 IoIFP(io) = Nullfp; 3223 IoOFP(io) = Nullfp; 3224 } 3225 } 3226 3227 if (i < count) { 3228 arg = SP[i++]; 3229 } 3230 } 3231 3232 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) { 3233 filter_sub = arg; 3234 (void)SvREFCNT_inc(filter_sub); 3235 3236 if (i < count) { 3237 filter_state = SP[i]; 3238 (void)SvREFCNT_inc(filter_state); 3239 } 3240 3241 if (tryrsfp == 0) { 3242 tryrsfp = PerlIO_open("/dev/null", 3243 PERL_SCRIPT_MODE); 3244 } 3245 } 3246 SP--; 3247 } 3248 3249 PUTBACK; 3250 FREETMPS; 3251 LEAVE; 3252 3253 if (tryrsfp) { 3254 hook_sv = dirsv; 3255 break; 3256 } 3257 3258 filter_has_file = 0; 3259 if (filter_child_proc) { 3260 SvREFCNT_dec(filter_child_proc); 3261 filter_child_proc = 0; 3262 } 3263 if (filter_state) { 3264 SvREFCNT_dec(filter_state); 3265 filter_state = 0; 3266 } 3267 if (filter_sub) { 3268 SvREFCNT_dec(filter_sub); 3269 filter_sub = 0; 3270 } 3271 } 3272 else { 3273 if (!path_is_absolute(name) 3274 #ifdef MACOS_TRADITIONAL 3275 /* We consider paths of the form :a:b ambiguous and interpret them first 3276 as global then as local 3277 */ 3278 || (*name == ':' && name[1] != ':' && strchr(name+2, ':')) 3279 #endif 3280 ) { 3281 const char *dir = SvPVx_nolen_const(dirsv); 3282 #ifdef MACOS_TRADITIONAL 3283 char buf1[256]; 3284 char buf2[256]; 3285 3286 MacPerl_CanonDir(name, buf2, 1); 3287 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':')); 3288 #else 3289 # ifdef VMS 3290 char *unixdir; 3291 if ((unixdir = tounixpath((char *)dir, Nullch)) == Nullch) 3292 continue; 3293 sv_setpv(namesv, unixdir); 3294 sv_catpv(namesv, unixname); 3295 # else 3296 # ifdef SYMBIAN 3297 if (PL_origfilename[0] && 3298 PL_origfilename[1] == ':' && 3299 !(dir[0] && dir[1] == ':')) 3300 Perl_sv_setpvf(aTHX_ namesv, 3301 "%c:%s\\%s", 3302 PL_origfilename[0], 3303 dir, name); 3304 else 3305 Perl_sv_setpvf(aTHX_ namesv, 3306 "%s\\%s", 3307 dir, name); 3308 # else 3309 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); 3310 # endif 3311 # endif 3312 #endif 3313 TAINT_PROPER("require"); 3314 tryname = SvPVX_const(namesv); 3315 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE); 3316 if (tryrsfp) { 3317 if (tryname[0] == '.' && tryname[1] == '/') 3318 tryname += 2; 3319 break; 3320 } 3321 } 3322 } 3323 } 3324 } 3325 } 3326 SAVECOPFILE_FREE(&PL_compiling); 3327 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name); 3328 SvREFCNT_dec(namesv); 3329 if (!tryrsfp) { 3330 if (PL_op->op_type == OP_REQUIRE) { 3331 const char *msgstr = name; 3332 if(errno == EMFILE) { 3333 SV * const msg = sv_2mortal(newSVpv(msgstr,0)); 3334 sv_catpv(msg, ": "); 3335 sv_catpv(msg, Strerror(errno)); 3336 msgstr = SvPV_nolen_const(msg); 3337 } else { 3338 if (namesv) { /* did we lookup @INC? */ 3339 SV * const msg = sv_2mortal(newSVpv(msgstr,0)); 3340 SV * const dirmsgsv = NEWSV(0, 0); 3341 AV * const ar = GvAVn(PL_incgv); 3342 I32 i; 3343 sv_catpvn(msg, " in @INC", 8); 3344 if (instr(SvPVX_const(msg), ".h ")) 3345 sv_catpv(msg, " (change .h to .ph maybe?)"); 3346 if (instr(SvPVX_const(msg), ".ph ")) 3347 sv_catpv(msg, " (did you run h2ph?)"); 3348 sv_catpv(msg, " (@INC contains:"); 3349 for (i = 0; i <= AvFILL(ar); i++) { 3350 const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE)); 3351 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir); 3352 sv_catsv(msg, dirmsgsv); 3353 } 3354 sv_catpvn(msg, ")", 1); 3355 SvREFCNT_dec(dirmsgsv); 3356 msgstr = SvPV_nolen_const(msg); 3357 } 3358 } 3359 DIE(aTHX_ "Can't locate %s", msgstr); 3360 } 3361 3362 RETPUSHUNDEF; 3363 } 3364 else 3365 SETERRNO(0, SS_NORMAL); 3366 3367 /* Assume success here to prevent recursive requirement. */ 3368 len = strlen(name); 3369 /* Check whether a hook in @INC has already filled %INC */ 3370 if (!hook_sv) { 3371 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0); 3372 } else { 3373 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); 3374 if (!svp) 3375 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 ); 3376 } 3377 3378 ENTER; 3379 SAVETMPS; 3380 lex_start(sv_2mortal(newSVpvn("",0))); 3381 SAVEGENERICSV(PL_rsfp_filters); 3382 PL_rsfp_filters = Nullav; 3383 3384 PL_rsfp = tryrsfp; 3385 SAVEHINTS(); 3386 PL_hints = 0; 3387 SAVESPTR(PL_compiling.cop_warnings); 3388 if (PL_dowarn & G_WARN_ALL_ON) 3389 PL_compiling.cop_warnings = pWARN_ALL ; 3390 else if (PL_dowarn & G_WARN_ALL_OFF) 3391 PL_compiling.cop_warnings = pWARN_NONE ; 3392 else if (PL_taint_warn) 3393 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize); 3394 else 3395 PL_compiling.cop_warnings = pWARN_STD ; 3396 SAVESPTR(PL_compiling.cop_io); 3397 PL_compiling.cop_io = Nullsv; 3398 3399 if (filter_sub || filter_child_proc) { 3400 SV * const datasv = filter_add(run_user_filter, Nullsv); 3401 IoLINES(datasv) = filter_has_file; 3402 IoFMT_GV(datasv) = (GV *)filter_child_proc; 3403 IoTOP_GV(datasv) = (GV *)filter_state; 3404 IoBOTTOM_GV(datasv) = (GV *)filter_sub; 3405 } 3406 3407 /* switch to eval mode */ 3408 push_return(PL_op->op_next); 3409 PUSHBLOCK(cx, CXt_EVAL, SP); 3410 PUSHEVAL(cx, name, Nullgv); 3411 3412 SAVECOPLINE(&PL_compiling); 3413 CopLINE_set(&PL_compiling, 0); 3414 3415 PUTBACK; 3416 #ifdef USE_5005THREADS 3417 MUTEX_LOCK(&PL_eval_mutex); 3418 if (PL_eval_owner && PL_eval_owner != thr) 3419 while (PL_eval_owner) 3420 COND_WAIT(&PL_eval_cond, &PL_eval_mutex); 3421 PL_eval_owner = thr; 3422 MUTEX_UNLOCK(&PL_eval_mutex); 3423 #endif /* USE_5005THREADS */ 3424 3425 /* Store and reset encoding. */ 3426 encoding = PL_encoding; 3427 PL_encoding = Nullsv; 3428 3429 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq)); 3430 3431 /* Restore encoding. */ 3432 PL_encoding = encoding; 3433 3434 return op; 3435 } 3436 3437 PP(pp_dofile) 3438 { 3439 return pp_require(); 3440 } 3441 3442 PP(pp_entereval) 3443 { 3444 dSP; 3445 register PERL_CONTEXT *cx; 3446 dPOPss; 3447 const I32 gimme = GIMME_V; 3448 const I32 was = PL_sub_generation; 3449 char tbuf[TYPE_DIGITS(long) + 12]; 3450 char *tmpbuf = tbuf; 3451 char *safestr; 3452 STRLEN len; 3453 OP *ret; 3454 CV* runcv; 3455 U32 seq; 3456 3457 if (!SvPV_const(sv,len)) 3458 RETPUSHUNDEF; 3459 TAINT_PROPER("eval"); 3460 3461 ENTER; 3462 lex_start(sv); 3463 SAVETMPS; 3464 3465 /* switch to eval mode */ 3466 3467 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { 3468 SV * const sv = sv_newmortal(); 3469 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]", 3470 (unsigned long)++PL_evalseq, 3471 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 3472 tmpbuf = SvPVX(sv); 3473 } 3474 else 3475 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); 3476 SAVECOPFILE_FREE(&PL_compiling); 3477 CopFILE_set(&PL_compiling, tmpbuf+2); 3478 SAVECOPLINE(&PL_compiling); 3479 CopLINE_set(&PL_compiling, 1); 3480 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up 3481 deleting the eval's FILEGV from the stash before gv_check() runs 3482 (i.e. before run-time proper). To work around the coredump that 3483 ensues, we always turn GvMULTI_on for any globals that were 3484 introduced within evals. See force_ident(). GSAR 96-10-12 */ 3485 safestr = savepv(tmpbuf); 3486 SAVEDELETE(PL_defstash, safestr, strlen(safestr)); 3487 SAVEHINTS(); 3488 PL_hints = PL_op->op_targ; 3489 SAVESPTR(PL_compiling.cop_warnings); 3490 if (specialWARN(PL_curcop->cop_warnings)) 3491 PL_compiling.cop_warnings = PL_curcop->cop_warnings; 3492 else { 3493 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings); 3494 SAVEFREESV(PL_compiling.cop_warnings); 3495 } 3496 SAVESPTR(PL_compiling.cop_io); 3497 if (specialCopIO(PL_curcop->cop_io)) 3498 PL_compiling.cop_io = PL_curcop->cop_io; 3499 else { 3500 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io); 3501 SAVEFREESV(PL_compiling.cop_io); 3502 } 3503 /* special case: an eval '' executed within the DB package gets lexically 3504 * placed in the first non-DB CV rather than the current CV - this 3505 * allows the debugger to execute code, find lexicals etc, in the 3506 * scope of the code being debugged. Passing &seq gets find_runcv 3507 * to do the dirty work for us */ 3508 runcv = find_runcv(&seq); 3509 3510 push_return(PL_op->op_next); 3511 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); 3512 PUSHEVAL(cx, 0, Nullgv); 3513 3514 /* prepare to compile string */ 3515 3516 if (PERLDB_LINE && PL_curstash != PL_debstash) 3517 save_lines(CopFILEAV(&PL_compiling), PL_linestr); 3518 PUTBACK; 3519 #ifdef USE_5005THREADS 3520 MUTEX_LOCK(&PL_eval_mutex); 3521 if (PL_eval_owner && PL_eval_owner != thr) 3522 while (PL_eval_owner) 3523 COND_WAIT(&PL_eval_cond, &PL_eval_mutex); 3524 PL_eval_owner = thr; 3525 MUTEX_UNLOCK(&PL_eval_mutex); 3526 #endif /* USE_5005THREADS */ 3527 ret = doeval(gimme, NULL, runcv, seq); 3528 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */ 3529 && ret != PL_op->op_next) { /* Successive compilation. */ 3530 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */ 3531 } 3532 return DOCATCH(ret); 3533 } 3534 3535 PP(pp_leaveeval) 3536 { 3537 dSP; 3538 register SV **mark; 3539 SV **newsp; 3540 PMOP *newpm; 3541 I32 gimme; 3542 register PERL_CONTEXT *cx; 3543 OP *retop; 3544 const U8 save_flags = PL_op -> op_flags; 3545 I32 optype; 3546 3547 POPBLOCK(cx,newpm); 3548 POPEVAL(cx); 3549 retop = pop_return(); 3550 3551 TAINT_NOT; 3552 if (gimme == G_VOID) 3553 MARK = newsp; 3554 else if (gimme == G_SCALAR) { 3555 MARK = newsp + 1; 3556 if (MARK <= SP) { 3557 if (SvFLAGS(TOPs) & SVs_TEMP) 3558 *MARK = TOPs; 3559 else 3560 *MARK = sv_mortalcopy(TOPs); 3561 } 3562 else { 3563 MEXTEND(mark,0); 3564 *MARK = &PL_sv_undef; 3565 } 3566 SP = MARK; 3567 } 3568 else { 3569 /* in case LEAVE wipes old return values */ 3570 for (mark = newsp + 1; mark <= SP; mark++) { 3571 if (!(SvFLAGS(*mark) & SVs_TEMP)) { 3572 *mark = sv_mortalcopy(*mark); 3573 TAINT_NOT; /* Each item is independent */ 3574 } 3575 } 3576 } 3577 PL_curpm = newpm; /* Don't pop $1 et al till now */ 3578 3579 #ifdef DEBUGGING 3580 assert(CvDEPTH(PL_compcv) == 1); 3581 #endif 3582 CvDEPTH(PL_compcv) = 0; 3583 lex_end(); 3584 3585 if (optype == OP_REQUIRE && 3586 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) 3587 { 3588 /* Unassume the success we assumed earlier. */ 3589 SV * const nsv = cx->blk_eval.old_namesv; 3590 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); 3591 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv); 3592 /* die_where() did LEAVE, or we won't be here */ 3593 } 3594 else { 3595 LEAVE; 3596 if (!(save_flags & OPf_SPECIAL)) 3597 sv_setpvn(ERRSV,"",0); 3598 } 3599 3600 RETURNOP(retop); 3601 } 3602 3603 PP(pp_entertry) 3604 { 3605 dSP; 3606 register PERL_CONTEXT *cx; 3607 const I32 gimme = GIMME_V; 3608 3609 ENTER; 3610 SAVETMPS; 3611 3612 push_return(cLOGOP->op_other->op_next); 3613 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP); 3614 PUSHEVAL(cx, 0, 0); 3615 3616 PL_in_eval = EVAL_INEVAL; 3617 sv_setpvn(ERRSV,"",0); 3618 PUTBACK; 3619 return DOCATCH(PL_op->op_next); 3620 } 3621 3622 PP(pp_leavetry) 3623 { 3624 dSP; 3625 register SV **mark; 3626 SV **newsp; 3627 PMOP *newpm; 3628 OP* retop; 3629 I32 gimme; 3630 register PERL_CONTEXT *cx; 3631 I32 optype; 3632 3633 POPBLOCK(cx,newpm); 3634 POPEVAL(cx); 3635 retop = pop_return(); 3636 PERL_UNUSED_VAR(optype); 3637 3638 TAINT_NOT; 3639 if (gimme == G_VOID) 3640 SP = newsp; 3641 else if (gimme == G_SCALAR) { 3642 MARK = newsp + 1; 3643 if (MARK <= SP) { 3644 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) 3645 *MARK = TOPs; 3646 else 3647 *MARK = sv_mortalcopy(TOPs); 3648 } 3649 else { 3650 MEXTEND(mark,0); 3651 *MARK = &PL_sv_undef; 3652 } 3653 SP = MARK; 3654 } 3655 else { 3656 /* in case LEAVE wipes old return values */ 3657 for (mark = newsp + 1; mark <= SP; mark++) { 3658 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { 3659 *mark = sv_mortalcopy(*mark); 3660 TAINT_NOT; /* Each item is independent */ 3661 } 3662 } 3663 } 3664 PL_curpm = newpm; /* Don't pop $1 et al till now */ 3665 3666 LEAVE; 3667 sv_setpvn(ERRSV,"",0); 3668 RETURNOP(retop); 3669 } 3670 3671 STATIC OP * 3672 S_doparseform(pTHX_ SV *sv) 3673 { 3674 STRLEN len; 3675 register char *s = SvPV_force(sv, len); 3676 register char *send = s + len; 3677 register char *base = Nullch; 3678 register I32 skipspaces = 0; 3679 bool noblank = FALSE; 3680 bool repeat = FALSE; 3681 bool postspace = FALSE; 3682 U32 *fops; 3683 register U32 *fpc; 3684 U32 *linepc = 0; 3685 register I32 arg; 3686 bool ischop; 3687 bool unchopnum = FALSE; 3688 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */ 3689 3690 if (len == 0) 3691 Perl_croak(aTHX_ "Null picture in formline"); 3692 3693 /* estimate the buffer size needed */ 3694 for (base = s; s <= send; s++) { 3695 if (*s == '\n' || *s == '@' || *s == '^') 3696 maxops += 10; 3697 } 3698 s = base; 3699 base = Nullch; 3700 3701 Newx(fops, maxops, U32); 3702 fpc = fops; 3703 3704 if (s < send) { 3705 linepc = fpc; 3706 *fpc++ = FF_LINEMARK; 3707 noblank = repeat = FALSE; 3708 base = s; 3709 } 3710 3711 while (s <= send) { 3712 switch (*s++) { 3713 default: 3714 skipspaces = 0; 3715 continue; 3716 3717 case '~': 3718 if (*s == '~') { 3719 repeat = TRUE; 3720 *s = ' '; 3721 } 3722 noblank = TRUE; 3723 s[-1] = ' '; 3724 /* FALL THROUGH */ 3725 case ' ': case '\t': 3726 skipspaces++; 3727 continue; 3728 case 0: 3729 if (s < send) { 3730 skipspaces = 0; 3731 continue; 3732 } /* else FALL THROUGH */ 3733 case '\n': 3734 arg = s - base; 3735 skipspaces++; 3736 arg -= skipspaces; 3737 if (arg) { 3738 if (postspace) 3739 *fpc++ = FF_SPACE; 3740 *fpc++ = FF_LITERAL; 3741 *fpc++ = (U16)arg; 3742 } 3743 postspace = FALSE; 3744 if (s <= send) 3745 skipspaces--; 3746 if (skipspaces) { 3747 *fpc++ = FF_SKIP; 3748 *fpc++ = (U16)skipspaces; 3749 } 3750 skipspaces = 0; 3751 if (s <= send) 3752 *fpc++ = FF_NEWLINE; 3753 if (noblank) { 3754 *fpc++ = FF_BLANK; 3755 if (repeat) 3756 arg = fpc - linepc + 1; 3757 else 3758 arg = 0; 3759 *fpc++ = (U16)arg; 3760 } 3761 if (s < send) { 3762 linepc = fpc; 3763 *fpc++ = FF_LINEMARK; 3764 noblank = repeat = FALSE; 3765 base = s; 3766 } 3767 else 3768 s++; 3769 continue; 3770 3771 case '@': 3772 case '^': 3773 ischop = s[-1] == '^'; 3774 3775 if (postspace) { 3776 *fpc++ = FF_SPACE; 3777 postspace = FALSE; 3778 } 3779 arg = (s - base) - 1; 3780 if (arg) { 3781 *fpc++ = FF_LITERAL; 3782 *fpc++ = (U16)arg; 3783 } 3784 3785 base = s - 1; 3786 *fpc++ = FF_FETCH; 3787 if (*s == '*') { 3788 s++; 3789 *fpc++ = 2; /* skip the @* or ^* */ 3790 if (ischop) { 3791 *fpc++ = FF_LINESNGL; 3792 *fpc++ = FF_CHOP; 3793 } else 3794 *fpc++ = FF_LINEGLOB; 3795 } 3796 else if (*s == '#' || (*s == '.' && s[1] == '#')) { 3797 arg = ischop ? 512 : 0; 3798 base = s - 1; 3799 while (*s == '#') 3800 s++; 3801 if (*s == '.') { 3802 const char * const f = ++s; 3803 while (*s == '#') 3804 s++; 3805 arg |= 256 + (s - f); 3806 } 3807 *fpc++ = s - base; /* fieldsize for FETCH */ 3808 *fpc++ = FF_DECIMAL; 3809 *fpc++ = (U16)arg; 3810 unchopnum |= ! ischop; 3811 } 3812 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */ 3813 arg = ischop ? 512 : 0; 3814 base = s - 1; 3815 s++; /* skip the '0' first */ 3816 while (*s == '#') 3817 s++; 3818 if (*s == '.') { 3819 const char * const f = ++s; 3820 while (*s == '#') 3821 s++; 3822 arg |= 256 + (s - f); 3823 } 3824 *fpc++ = s - base; /* fieldsize for FETCH */ 3825 *fpc++ = FF_0DECIMAL; 3826 *fpc++ = (U16)arg; 3827 unchopnum |= ! ischop; 3828 } 3829 else { 3830 I32 prespace = 0; 3831 bool ismore = FALSE; 3832 3833 if (*s == '>') { 3834 while (*++s == '>') ; 3835 prespace = FF_SPACE; 3836 } 3837 else if (*s == '|') { 3838 while (*++s == '|') ; 3839 prespace = FF_HALFSPACE; 3840 postspace = TRUE; 3841 } 3842 else { 3843 if (*s == '<') 3844 while (*++s == '<') ; 3845 postspace = TRUE; 3846 } 3847 if (*s == '.' && s[1] == '.' && s[2] == '.') { 3848 s += 3; 3849 ismore = TRUE; 3850 } 3851 *fpc++ = s - base; /* fieldsize for FETCH */ 3852 3853 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL; 3854 3855 if (prespace) 3856 *fpc++ = (U16)prespace; 3857 *fpc++ = FF_ITEM; 3858 if (ismore) 3859 *fpc++ = FF_MORE; 3860 if (ischop) 3861 *fpc++ = FF_CHOP; 3862 } 3863 base = s; 3864 skipspaces = 0; 3865 continue; 3866 } 3867 } 3868 *fpc++ = FF_END; 3869 3870 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */ 3871 arg = fpc - fops; 3872 { /* need to jump to the next word */ 3873 int z; 3874 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN; 3875 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4); 3876 s = SvPVX(sv) + SvCUR(sv) + z; 3877 } 3878 Copy(fops, s, arg, U32); 3879 Safefree(fops); 3880 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0); 3881 SvCOMPILED_on(sv); 3882 3883 if (unchopnum && repeat) 3884 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)"); 3885 return 0; 3886 } 3887 3888 3889 STATIC bool 3890 S_num_overflow(NV value, I32 fldsize, I32 frcsize) 3891 { 3892 /* Can value be printed in fldsize chars, using %*.*f ? */ 3893 NV pwr = 1; 3894 NV eps = 0.5; 3895 bool res = FALSE; 3896 int intsize = fldsize - (value < 0 ? 1 : 0); 3897 3898 if (frcsize & 256) 3899 intsize--; 3900 frcsize &= 255; 3901 intsize -= frcsize; 3902 3903 while (intsize--) pwr *= 10.0; 3904 while (frcsize--) eps /= 10.0; 3905 3906 if( value >= 0 ){ 3907 if (value + eps >= pwr) 3908 res = TRUE; 3909 } else { 3910 if (value - eps <= -pwr) 3911 res = TRUE; 3912 } 3913 return res; 3914 } 3915 3916 static I32 3917 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) 3918 { 3919 SV *datasv = FILTER_DATA(idx); 3920 const int filter_has_file = IoLINES(datasv); 3921 GV *filter_child_proc = (GV *)IoFMT_GV(datasv); 3922 SV *filter_state = (SV *)IoTOP_GV(datasv); 3923 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv); 3924 int len = 0; 3925 3926 /* I was having segfault trouble under Linux 2.2.5 after a 3927 parse error occured. (Had to hack around it with a test 3928 for PL_error_count == 0.) Solaris doesn't segfault -- 3929 not sure where the trouble is yet. XXX */ 3930 3931 if (filter_has_file) { 3932 len = FILTER_READ(idx+1, buf_sv, maxlen); 3933 } 3934 3935 if (filter_sub && len >= 0) { 3936 dSP; 3937 int count; 3938 3939 ENTER; 3940 SAVE_DEFSV; 3941 SAVETMPS; 3942 EXTEND(SP, 2); 3943 3944 DEFSV = buf_sv; 3945 PUSHMARK(SP); 3946 PUSHs(sv_2mortal(newSViv(maxlen))); 3947 if (filter_state) { 3948 PUSHs(filter_state); 3949 } 3950 PUTBACK; 3951 count = call_sv(filter_sub, G_SCALAR); 3952 SPAGAIN; 3953 3954 if (count > 0) { 3955 SV *out = POPs; 3956 if (SvOK(out)) { 3957 len = SvIV(out); 3958 } 3959 } 3960 3961 PUTBACK; 3962 FREETMPS; 3963 LEAVE; 3964 } 3965 3966 if (len <= 0) { 3967 IoLINES(datasv) = 0; 3968 if (filter_child_proc) { 3969 SvREFCNT_dec(filter_child_proc); 3970 IoFMT_GV(datasv) = Nullgv; 3971 } 3972 if (filter_state) { 3973 SvREFCNT_dec(filter_state); 3974 IoTOP_GV(datasv) = Nullgv; 3975 } 3976 if (filter_sub) { 3977 SvREFCNT_dec(filter_sub); 3978 IoBOTTOM_GV(datasv) = Nullgv; 3979 } 3980 filter_del(run_user_filter); 3981 } 3982 3983 return len; 3984 } 3985 3986 /* perhaps someone can come up with a better name for 3987 this? it is not really "absolute", per se ... */ 3988 static bool 3989 S_path_is_absolute(pTHX_ const char *name) 3990 { 3991 if (PERL_FILE_IS_ABSOLUTE(name) 3992 #ifdef MACOS_TRADITIONAL 3993 || (*name == ':')) 3994 #else 3995 || (*name == '.' && (name[1] == '/' || 3996 (name[1] == '.' && name[2] == '/')))) 3997 #endif 3998 { 3999 return TRUE; 4000 } 4001 else 4002 return FALSE; 4003 } 4004 4005 /* 4006 * Local variables: 4007 * c-indentation-style: bsd 4008 * c-basic-offset: 4 4009 * indent-tabs-mode: t 4010 * End: 4011 * 4012 * ex: set ts=8 sts=4 sw=4 noet: 4013 */ 4014