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