1 /* pp_ctl.c 2 * 3 * Copyright (c) 1991-1994, 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 #include "perl.h" 21 22 #ifndef WORD_ALIGN 23 #define WORD_ALIGN sizeof(U16) 24 #endif 25 26 static OP *doeval _((int gimme)); 27 static OP *dofindlabel _((OP *op, char *label, OP **opstack)); 28 static void doparseform _((SV *sv)); 29 static I32 dopoptoeval _((I32 startingblock)); 30 static I32 dopoptolabel _((char *label)); 31 static I32 dopoptoloop _((I32 startingblock)); 32 static I32 dopoptosub _((I32 startingblock)); 33 static void save_lines _((AV *array, SV *sv)); 34 static int sortcmp _((const void *, const void *)); 35 static int sortcv _((const void *, const void *)); 36 37 static I32 sortcxix; 38 39 PP(pp_wantarray) 40 { 41 dSP; 42 I32 cxix; 43 EXTEND(SP, 1); 44 45 cxix = dopoptosub(cxstack_ix); 46 if (cxix < 0) 47 RETPUSHUNDEF; 48 49 if (cxstack[cxix].blk_gimme == G_ARRAY) 50 RETPUSHYES; 51 else 52 RETPUSHNO; 53 } 54 55 PP(pp_regcmaybe) 56 { 57 return NORMAL; 58 } 59 60 PP(pp_regcomp) { 61 dSP; 62 register PMOP *pm = (PMOP*)cLOGOP->op_other; 63 register char *t; 64 SV *tmpstr; 65 STRLEN len; 66 67 tmpstr = POPs; 68 t = SvPV(tmpstr, len); 69 70 /* JMR: Check against the last compiled regexp */ 71 if ( ! pm->op_pmregexp || ! pm->op_pmregexp->precomp 72 || strnNE(pm->op_pmregexp->precomp, t, len) 73 || pm->op_pmregexp->precomp[len]) { 74 if (pm->op_pmregexp) { 75 pregfree(pm->op_pmregexp); 76 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */ 77 } 78 79 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ 80 pm->op_pmregexp = pregcomp(t, t + len, pm); 81 } 82 83 if (!pm->op_pmregexp->prelen && curpm) 84 pm = curpm; 85 else if (strEQ("\\s+", pm->op_pmregexp->precomp)) 86 pm->op_pmflags |= PMf_WHITE; 87 88 if (pm->op_pmflags & PMf_KEEP) { 89 pm->op_pmflags &= ~PMf_RUNTIME; /* no point compiling again */ 90 hoistmust(pm); 91 cLOGOP->op_first->op_next = op->op_next; 92 } 93 RETURN; 94 } 95 96 PP(pp_substcont) 97 { 98 dSP; 99 register PMOP *pm = (PMOP*) cLOGOP->op_other; 100 register CONTEXT *cx = &cxstack[cxstack_ix]; 101 register SV *dstr = cx->sb_dstr; 102 register char *s = cx->sb_s; 103 register char *m = cx->sb_m; 104 char *orig = cx->sb_orig; 105 register REGEXP *rx = cx->sb_rx; 106 107 if (cx->sb_iters++) { 108 if (cx->sb_iters > cx->sb_maxiters) 109 DIE("Substitution loop"); 110 111 sv_catsv(dstr, POPs); 112 if (rx->subbase) 113 Safefree(rx->subbase); 114 rx->subbase = cx->sb_subbase; 115 116 /* Are we done */ 117 if (cx->sb_once || !pregexec(rx, s, cx->sb_strend, orig, 118 s == m, Nullsv, cx->sb_safebase)) 119 { 120 SV *targ = cx->sb_targ; 121 sv_catpvn(dstr, s, cx->sb_strend - s); 122 123 (void)SvOOK_off(targ); 124 Safefree(SvPVX(targ)); 125 SvPVX(targ) = SvPVX(dstr); 126 SvCUR_set(targ, SvCUR(dstr)); 127 SvLEN_set(targ, SvLEN(dstr)); 128 SvPVX(dstr) = 0; 129 sv_free(dstr); 130 131 (void)SvPOK_only(targ); 132 SvSETMAGIC(targ); 133 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); 134 LEAVE_SCOPE(cx->sb_oldsave); 135 POPSUBST(cx); 136 RETURNOP(pm->op_next); 137 } 138 } 139 if (rx->subbase && rx->subbase != orig) { 140 m = s; 141 s = orig; 142 cx->sb_orig = orig = rx->subbase; 143 s = orig + (m - s); 144 cx->sb_strend = s + (cx->sb_strend - m); 145 } 146 cx->sb_m = m = rx->startp[0]; 147 sv_catpvn(dstr, s, m-s); 148 cx->sb_s = rx->endp[0]; 149 cx->sb_subbase = rx->subbase; 150 151 rx->subbase = Nullch; /* so recursion works */ 152 RETURNOP(pm->op_pmreplstart); 153 } 154 155 PP(pp_formline) 156 { 157 dSP; dMARK; dORIGMARK; 158 register SV *form = *++MARK; 159 register U16 *fpc; 160 register char *t; 161 register char *f; 162 register char *s; 163 register char *send; 164 register I32 arg; 165 register SV *sv; 166 char *item; 167 I32 itemsize; 168 I32 fieldsize; 169 I32 lines = 0; 170 bool chopspace = (strchr(chopset, ' ') != Nullch); 171 char *chophere; 172 char *linemark; 173 double value; 174 bool gotsome; 175 STRLEN len; 176 177 if (!SvCOMPILED(form)) { 178 SvREADONLY_off(form); 179 doparseform(form); 180 } 181 182 SvPV_force(formtarget, len); 183 t = SvGROW(formtarget, len + SvCUR(form) + 1); /* XXX SvCUR bad */ 184 t += len; 185 f = SvPV(form, len); 186 /* need to jump to the next word */ 187 s = f + len + WORD_ALIGN - SvCUR(form) % WORD_ALIGN; 188 189 fpc = (U16*)s; 190 191 for (;;) { 192 DEBUG_f( { 193 char *name = "???"; 194 arg = -1; 195 switch (*fpc) { 196 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break; 197 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break; 198 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break; 199 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break; 200 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break; 201 202 case FF_CHECKNL: name = "CHECKNL"; break; 203 case FF_CHECKCHOP: name = "CHECKCHOP"; break; 204 case FF_SPACE: name = "SPACE"; break; 205 case FF_HALFSPACE: name = "HALFSPACE"; break; 206 case FF_ITEM: name = "ITEM"; break; 207 case FF_CHOP: name = "CHOP"; break; 208 case FF_LINEGLOB: name = "LINEGLOB"; break; 209 case FF_NEWLINE: name = "NEWLINE"; break; 210 case FF_MORE: name = "MORE"; break; 211 case FF_LINEMARK: name = "LINEMARK"; break; 212 case FF_END: name = "END"; break; 213 } 214 if (arg >= 0) 215 fprintf(stderr, "%-16s%ld\n", name, (long) arg); 216 else 217 fprintf(stderr, "%-16s\n", name); 218 } ) 219 switch (*fpc++) { 220 case FF_LINEMARK: 221 linemark = t; 222 lines++; 223 gotsome = FALSE; 224 break; 225 226 case FF_LITERAL: 227 arg = *fpc++; 228 while (arg--) 229 *t++ = *f++; 230 break; 231 232 case FF_SKIP: 233 f += *fpc++; 234 break; 235 236 case FF_FETCH: 237 arg = *fpc++; 238 f += arg; 239 fieldsize = arg; 240 241 if (MARK < SP) 242 sv = *++MARK; 243 else { 244 sv = &sv_no; 245 if (dowarn) 246 warn("Not enough format arguments"); 247 } 248 break; 249 250 case FF_CHECKNL: 251 item = s = SvPV(sv, len); 252 itemsize = len; 253 if (itemsize > fieldsize) 254 itemsize = fieldsize; 255 send = chophere = s + itemsize; 256 while (s < send) { 257 if (*s & ~31) 258 gotsome = TRUE; 259 else if (*s == '\n') 260 break; 261 s++; 262 } 263 itemsize = s - item; 264 break; 265 266 case FF_CHECKCHOP: 267 item = s = SvPV(sv, len); 268 itemsize = len; 269 if (itemsize <= fieldsize) { 270 send = chophere = s + itemsize; 271 while (s < send) { 272 if (*s == '\r') { 273 itemsize = s - item; 274 break; 275 } 276 if (*s++ & ~31) 277 gotsome = TRUE; 278 } 279 } 280 else { 281 itemsize = fieldsize; 282 send = chophere = s + itemsize; 283 while (s < send || (s == send && isSPACE(*s))) { 284 if (isSPACE(*s)) { 285 if (chopspace) 286 chophere = s; 287 if (*s == '\r') 288 break; 289 } 290 else { 291 if (*s & ~31) 292 gotsome = TRUE; 293 if (strchr(chopset, *s)) 294 chophere = s + 1; 295 } 296 s++; 297 } 298 itemsize = chophere - item; 299 } 300 break; 301 302 case FF_SPACE: 303 arg = fieldsize - itemsize; 304 if (arg) { 305 fieldsize -= arg; 306 while (arg-- > 0) 307 *t++ = ' '; 308 } 309 break; 310 311 case FF_HALFSPACE: 312 arg = fieldsize - itemsize; 313 if (arg) { 314 arg /= 2; 315 fieldsize -= arg; 316 while (arg-- > 0) 317 *t++ = ' '; 318 } 319 break; 320 321 case FF_ITEM: 322 arg = itemsize; 323 s = item; 324 while (arg--) { 325 #if 'z' - 'a' != 25 326 int ch = *t++ = *s++; 327 if (!iscntrl(ch)) 328 t[-1] = ' '; 329 #else 330 if ( !((*t++ = *s++) & ~31) ) 331 t[-1] = ' '; 332 #endif 333 334 } 335 break; 336 337 case FF_CHOP: 338 s = chophere; 339 if (chopspace) { 340 while (*s && isSPACE(*s)) 341 s++; 342 } 343 sv_chop(sv,s); 344 break; 345 346 case FF_LINEGLOB: 347 item = s = SvPV(sv, len); 348 itemsize = len; 349 if (itemsize) { 350 gotsome = TRUE; 351 send = s + itemsize; 352 while (s < send) { 353 if (*s++ == '\n') { 354 if (s == send) 355 itemsize--; 356 else 357 lines++; 358 } 359 } 360 SvCUR_set(formtarget, t - SvPVX(formtarget)); 361 sv_catpvn(formtarget, item, itemsize); 362 SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1); 363 t = SvPVX(formtarget) + SvCUR(formtarget); 364 } 365 break; 366 367 case FF_DECIMAL: 368 /* If the field is marked with ^ and the value is undefined, 369 blank it out. */ 370 arg = *fpc++; 371 if ((arg & 512) && !SvOK(sv)) { 372 arg = fieldsize; 373 while (arg--) 374 *t++ = ' '; 375 break; 376 } 377 gotsome = TRUE; 378 value = SvNV(sv); 379 if (arg & 256) { 380 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value); 381 } else { 382 sprintf(t, "%*.0f", (int) fieldsize, value); 383 } 384 t += fieldsize; 385 break; 386 387 case FF_NEWLINE: 388 f++; 389 while (t-- > linemark && *t == ' ') ; 390 t++; 391 *t++ = '\n'; 392 break; 393 394 case FF_BLANK: 395 arg = *fpc++; 396 if (gotsome) { 397 if (arg) { /* repeat until fields exhausted? */ 398 *t = '\0'; 399 SvCUR_set(formtarget, t - SvPVX(formtarget)); 400 lines += FmLINES(formtarget); 401 if (lines == 200) { 402 arg = t - linemark; 403 if (strnEQ(linemark, linemark - arg, arg)) 404 DIE("Runaway format"); 405 } 406 FmLINES(formtarget) = lines; 407 SP = ORIGMARK; 408 RETURNOP(cLISTOP->op_first); 409 } 410 } 411 else { 412 t = linemark; 413 lines--; 414 } 415 break; 416 417 case FF_MORE: 418 if (itemsize) { 419 arg = fieldsize - itemsize; 420 if (arg) { 421 fieldsize -= arg; 422 while (arg-- > 0) 423 *t++ = ' '; 424 } 425 s = t - 3; 426 if (strnEQ(s," ",3)) { 427 while (s > SvPVX(formtarget) && isSPACE(s[-1])) 428 s--; 429 } 430 *s++ = '.'; 431 *s++ = '.'; 432 *s++ = '.'; 433 } 434 break; 435 436 case FF_END: 437 *t = '\0'; 438 SvCUR_set(formtarget, t - SvPVX(formtarget)); 439 FmLINES(formtarget) += lines; 440 SP = ORIGMARK; 441 RETPUSHYES; 442 } 443 } 444 } 445 446 PP(pp_grepstart) 447 { 448 dSP; 449 SV *src; 450 451 if (stack_base + *markstack_ptr == sp) { 452 (void)POPMARK; 453 if (GIMME != G_ARRAY) 454 XPUSHs(&sv_no); 455 RETURNOP(op->op_next->op_next); 456 } 457 stack_sp = stack_base + *markstack_ptr + 1; 458 pp_pushmark(); /* push dst */ 459 pp_pushmark(); /* push src */ 460 ENTER; /* enter outer scope */ 461 462 SAVETMPS; 463 SAVESPTR(GvSV(defgv)); 464 465 ENTER; /* enter inner scope */ 466 SAVESPTR(curpm); 467 468 src = stack_base[*markstack_ptr]; 469 SvTEMP_off(src); 470 GvSV(defgv) = src; 471 472 PUTBACK; 473 if (op->op_type == OP_MAPSTART) 474 pp_pushmark(); /* push top */ 475 return ((LOGOP*)op->op_next)->op_other; 476 } 477 478 PP(pp_mapstart) 479 { 480 DIE("panic: mapstart"); /* uses grepstart */ 481 } 482 483 PP(pp_mapwhile) 484 { 485 dSP; 486 I32 diff = (sp - stack_base) - *markstack_ptr; 487 I32 count; 488 I32 shift; 489 SV** src; 490 SV** dst; 491 492 ++markstack_ptr[-1]; 493 if (diff) { 494 if (diff > markstack_ptr[-1] - markstack_ptr[-2]) { 495 shift = diff - (markstack_ptr[-1] - markstack_ptr[-2]); 496 count = (sp - stack_base) - markstack_ptr[-1] + 2; 497 498 EXTEND(sp,shift); 499 src = sp; 500 dst = (sp += shift); 501 markstack_ptr[-1] += shift; 502 *markstack_ptr += shift; 503 while (--count) 504 *dst-- = *src--; 505 } 506 dst = stack_base + (markstack_ptr[-2] += diff) - 1; 507 ++diff; 508 while (--diff) 509 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs); 510 } 511 LEAVE; /* exit inner scope */ 512 513 /* All done yet? */ 514 if (markstack_ptr[-1] > *markstack_ptr) { 515 I32 items; 516 517 (void)POPMARK; /* pop top */ 518 LEAVE; /* exit outer scope */ 519 (void)POPMARK; /* pop src */ 520 items = --*markstack_ptr - markstack_ptr[-1]; 521 (void)POPMARK; /* pop dst */ 522 SP = stack_base + POPMARK; /* pop original mark */ 523 if (GIMME != G_ARRAY) { 524 dTARGET; 525 XPUSHi(items); 526 RETURN; 527 } 528 SP += items; 529 RETURN; 530 } 531 else { 532 SV *src; 533 534 ENTER; /* enter inner scope */ 535 SAVESPTR(curpm); 536 537 src = stack_base[markstack_ptr[-1]]; 538 SvTEMP_off(src); 539 GvSV(defgv) = src; 540 541 RETURNOP(cLOGOP->op_other); 542 } 543 } 544 545 546 PP(pp_sort) 547 { 548 dSP; dMARK; dORIGMARK; 549 register SV **up; 550 SV **myorigmark = ORIGMARK; 551 register I32 max; 552 HV *stash; 553 GV *gv; 554 CV *cv; 555 I32 gimme = GIMME; 556 OP* nextop = op->op_next; 557 558 if (gimme != G_ARRAY) { 559 SP = MARK; 560 RETPUSHUNDEF; 561 } 562 563 if (op->op_flags & OPf_STACKED) { 564 ENTER; 565 if (op->op_flags & OPf_SPECIAL) { 566 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */ 567 kid = kUNOP->op_first; /* pass rv2gv */ 568 kid = kUNOP->op_first; /* pass leave */ 569 sortcop = kid->op_next; 570 stash = curcop->cop_stash; 571 } 572 else { 573 cv = sv_2cv(*++MARK, &stash, &gv, 0); 574 if (!(cv && CvROOT(cv))) { 575 if (gv) { 576 SV *tmpstr = sv_newmortal(); 577 gv_efullname(tmpstr, gv); 578 if (cv && CvXSUB(cv)) 579 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr)); 580 DIE("Undefined sort subroutine \"%s\" called", 581 SvPVX(tmpstr)); 582 } 583 if (cv) { 584 if (CvXSUB(cv)) 585 DIE("Xsub called in sort"); 586 DIE("Undefined subroutine in sort"); 587 } 588 DIE("Not a CODE reference in sort"); 589 } 590 sortcop = CvSTART(cv); 591 SAVESPTR(CvROOT(cv)->op_ppaddr); 592 CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL]; 593 594 SAVESPTR(curpad); 595 curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); 596 } 597 } 598 else { 599 sortcop = Nullop; 600 stash = curcop->cop_stash; 601 } 602 603 up = myorigmark + 1; 604 while (MARK < SP) { /* This may or may not shift down one here. */ 605 /*SUPPRESS 560*/ 606 if (*up = *++MARK) { /* Weed out nulls. */ 607 if (!SvPOK(*up)) 608 (void)sv_2pv(*up, &na); 609 else 610 SvTEMP_off(*up); 611 up++; 612 } 613 } 614 max = --up - myorigmark; 615 if (sortcop) { 616 if (max > 1) { 617 AV *oldstack; 618 CONTEXT *cx; 619 SV** newsp; 620 621 SAVETMPS; 622 SAVESPTR(op); 623 624 oldstack = stack; 625 if (!sortstack) { 626 sortstack = newAV(); 627 AvREAL_off(sortstack); 628 av_extend(sortstack, 32); 629 } 630 SWITCHSTACK(stack, sortstack); 631 if (sortstash != stash) { 632 firstgv = gv_fetchpv("a", TRUE, SVt_PV); 633 secondgv = gv_fetchpv("b", TRUE, SVt_PV); 634 sortstash = stash; 635 } 636 637 SAVESPTR(GvSV(firstgv)); 638 SAVESPTR(GvSV(secondgv)); 639 PUSHBLOCK(cx, CXt_LOOP, stack_base); 640 sortcxix = cxstack_ix; 641 642 qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv); 643 644 POPBLOCK(cx,curpm); 645 SWITCHSTACK(sortstack, oldstack); 646 } 647 LEAVE; 648 } 649 else { 650 if (max > 1) { 651 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ 652 qsort((char*)(ORIGMARK+1), max, sizeof(SV*), sortcmp); 653 } 654 } 655 stack_sp = ORIGMARK + max; 656 return nextop; 657 } 658 659 /* Range stuff. */ 660 661 PP(pp_range) 662 { 663 if (GIMME == G_ARRAY) 664 return cCONDOP->op_true; 665 return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true; 666 } 667 668 PP(pp_flip) 669 { 670 dSP; 671 672 if (GIMME == G_ARRAY) { 673 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false); 674 } 675 else { 676 dTOPss; 677 SV *targ = PAD_SV(op->op_targ); 678 679 if ((op->op_private & OPpFLIP_LINENUM) 680 ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv)) 681 : SvTRUE(sv) ) { 682 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); 683 if (op->op_flags & OPf_SPECIAL) { 684 sv_setiv(targ, 1); 685 RETURN; 686 } 687 else { 688 sv_setiv(targ, 0); 689 sp--; 690 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false); 691 } 692 } 693 sv_setpv(TARG, ""); 694 SETs(targ); 695 RETURN; 696 } 697 } 698 699 PP(pp_flop) 700 { 701 dSP; 702 703 if (GIMME == G_ARRAY) { 704 dPOPPOPssrl; 705 register I32 i; 706 register SV *sv; 707 I32 max; 708 709 if (SvNIOKp(left) || !SvPOKp(left) || 710 (looks_like_number(left) && *SvPVX(left) != '0') ) { 711 i = SvIV(left); 712 max = SvIV(right); 713 if (max > i) 714 EXTEND(SP, max - i + 1); 715 while (i <= max) { 716 sv = sv_mortalcopy(&sv_no); 717 sv_setiv(sv,i++); 718 PUSHs(sv); 719 } 720 } 721 else { 722 SV *final = sv_mortalcopy(right); 723 STRLEN len; 724 char *tmps = SvPV(final, len); 725 726 sv = sv_mortalcopy(left); 727 while (!SvNIOKp(sv) && SvCUR(sv) <= len && 728 strNE(SvPVX(sv),tmps) ) { 729 XPUSHs(sv); 730 sv = sv_2mortal(newSVsv(sv)); 731 sv_inc(sv); 732 } 733 if (strEQ(SvPVX(sv),tmps)) 734 XPUSHs(sv); 735 } 736 } 737 else { 738 dTOPss; 739 SV *targ = PAD_SV(cUNOP->op_first->op_targ); 740 sv_inc(targ); 741 if ((op->op_private & OPpFLIP_LINENUM) 742 ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv)) 743 : SvTRUE(sv) ) { 744 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); 745 sv_catpv(targ, "E0"); 746 } 747 SETs(targ); 748 } 749 750 RETURN; 751 } 752 753 /* Control. */ 754 755 static I32 756 dopoptolabel(label) 757 char *label; 758 { 759 register I32 i; 760 register CONTEXT *cx; 761 762 for (i = cxstack_ix; i >= 0; i--) { 763 cx = &cxstack[i]; 764 switch (cx->cx_type) { 765 case CXt_SUBST: 766 if (dowarn) 767 warn("Exiting substitution via %s", op_name[op->op_type]); 768 break; 769 case CXt_SUB: 770 if (dowarn) 771 warn("Exiting subroutine via %s", op_name[op->op_type]); 772 break; 773 case CXt_EVAL: 774 if (dowarn) 775 warn("Exiting eval via %s", op_name[op->op_type]); 776 break; 777 case CXt_LOOP: 778 if (!cx->blk_loop.label || 779 strNE(label, cx->blk_loop.label) ) { 780 DEBUG_l(deb("(Skipping label #%d %s)\n", 781 i, cx->blk_loop.label)); 782 continue; 783 } 784 DEBUG_l( deb("(Found label #%d %s)\n", i, label)); 785 return i; 786 } 787 } 788 return i; 789 } 790 791 I32 792 dowantarray() 793 { 794 I32 cxix; 795 796 cxix = dopoptosub(cxstack_ix); 797 if (cxix < 0) 798 return G_SCALAR; 799 800 if (cxstack[cxix].blk_gimme == G_ARRAY) 801 return G_ARRAY; 802 else 803 return G_SCALAR; 804 } 805 806 static I32 807 dopoptosub(startingblock) 808 I32 startingblock; 809 { 810 I32 i; 811 register CONTEXT *cx; 812 for (i = startingblock; i >= 0; i--) { 813 cx = &cxstack[i]; 814 switch (cx->cx_type) { 815 default: 816 continue; 817 case CXt_EVAL: 818 case CXt_SUB: 819 DEBUG_l( deb("(Found sub #%d)\n", i)); 820 return i; 821 } 822 } 823 return i; 824 } 825 826 static I32 827 dopoptoeval(startingblock) 828 I32 startingblock; 829 { 830 I32 i; 831 register CONTEXT *cx; 832 for (i = startingblock; i >= 0; i--) { 833 cx = &cxstack[i]; 834 switch (cx->cx_type) { 835 default: 836 continue; 837 case CXt_EVAL: 838 DEBUG_l( deb("(Found eval #%d)\n", i)); 839 return i; 840 } 841 } 842 return i; 843 } 844 845 static I32 846 dopoptoloop(startingblock) 847 I32 startingblock; 848 { 849 I32 i; 850 register CONTEXT *cx; 851 for (i = startingblock; i >= 0; i--) { 852 cx = &cxstack[i]; 853 switch (cx->cx_type) { 854 case CXt_SUBST: 855 if (dowarn) 856 warn("Exiting substitition via %s", op_name[op->op_type]); 857 break; 858 case CXt_SUB: 859 if (dowarn) 860 warn("Exiting subroutine via %s", op_name[op->op_type]); 861 break; 862 case CXt_EVAL: 863 if (dowarn) 864 warn("Exiting eval via %s", op_name[op->op_type]); 865 break; 866 case CXt_LOOP: 867 DEBUG_l( deb("(Found loop #%d)\n", i)); 868 return i; 869 } 870 } 871 return i; 872 } 873 874 void 875 dounwind(cxix) 876 I32 cxix; 877 { 878 register CONTEXT *cx; 879 SV **newsp; 880 I32 optype; 881 882 while (cxstack_ix > cxix) { 883 cx = &cxstack[cxstack_ix--]; 884 DEBUG_l(fprintf(stderr, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1, 885 block_type[cx->cx_type])); 886 /* Note: we don't need to restore the base context info till the end. */ 887 switch (cx->cx_type) { 888 case CXt_SUB: 889 POPSUB(cx); 890 break; 891 case CXt_EVAL: 892 POPEVAL(cx); 893 break; 894 case CXt_LOOP: 895 POPLOOP(cx); 896 break; 897 case CXt_SUBST: 898 break; 899 } 900 } 901 } 902 903 #ifdef I_STDARG 904 OP * 905 die(char* pat, ...) 906 #else 907 /*VARARGS0*/ 908 OP * 909 die(pat, va_alist) 910 char *pat; 911 va_dcl 912 #endif 913 { 914 va_list args; 915 char *message; 916 int oldrunlevel = runlevel; 917 int was_in_eval = in_eval; 918 HV *stash; 919 GV *gv; 920 CV *cv; 921 922 #ifdef I_STDARG 923 va_start(args, pat); 924 #else 925 va_start(args); 926 #endif 927 message = mess(pat, &args); 928 va_end(args); 929 if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) { 930 dSP; 931 932 PUSHMARK(sp); 933 EXTEND(sp, 1); 934 PUSHs(sv_2mortal(newSVpv(message,0))); 935 PUTBACK; 936 perl_call_sv((SV*)cv, G_DISCARD); 937 } 938 restartop = die_where(message); 939 if ((!restartop && was_in_eval) || oldrunlevel > 1) 940 Siglongjmp(top_env, 3); 941 return restartop; 942 } 943 944 OP * 945 die_where(message) 946 char *message; 947 { 948 if (in_eval) { 949 I32 cxix; 950 register CONTEXT *cx; 951 I32 gimme; 952 SV **newsp; 953 954 if (in_eval & 4) { 955 SV **svp; 956 STRLEN klen = strlen(message); 957 958 svp = hv_fetch(GvHV(errgv), message, klen, TRUE); 959 if (svp) { 960 if (!SvIOK(*svp)) { 961 static char prefix[] = "\t(in cleanup) "; 962 sv_upgrade(*svp, SVt_IV); 963 (void)SvIOK_only(*svp); 964 SvGROW(GvSV(errgv), SvCUR(GvSV(errgv))+sizeof(prefix)+klen); 965 sv_catpvn(GvSV(errgv), prefix, sizeof(prefix)-1); 966 sv_catpvn(GvSV(errgv), message, klen); 967 } 968 sv_inc(*svp); 969 } 970 } 971 else 972 sv_setpv(GvSV(errgv), message); 973 974 cxix = dopoptoeval(cxstack_ix); 975 if (cxix >= 0) { 976 I32 optype; 977 978 if (cxix < cxstack_ix) 979 dounwind(cxix); 980 981 POPBLOCK(cx,curpm); 982 if (cx->cx_type != CXt_EVAL) { 983 fprintf(stderr, "panic: die %s", message); 984 my_exit(1); 985 } 986 POPEVAL(cx); 987 988 if (gimme == G_SCALAR) 989 *++newsp = &sv_undef; 990 stack_sp = newsp; 991 992 LEAVE; 993 994 if (optype == OP_REQUIRE) 995 DIE("%s", SvPVx(GvSV(errgv), na)); 996 return pop_return(); 997 } 998 } 999 fputs(message, stderr); 1000 (void)Fflush(stderr); 1001 if (e_tmpname) { 1002 if (e_fp) { 1003 fclose(e_fp); 1004 e_fp = Nullfp; 1005 } 1006 (void)UNLINK(e_tmpname); 1007 Safefree(e_tmpname); 1008 e_tmpname = Nullch; 1009 } 1010 statusvalue = SHIFTSTATUS(statusvalue); 1011 #ifdef VMS 1012 my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT); 1013 #else 1014 my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255))); 1015 #endif 1016 return 0; 1017 } 1018 1019 PP(pp_xor) 1020 { 1021 dSP; dPOPTOPssrl; 1022 if (SvTRUE(left) != SvTRUE(right)) 1023 RETSETYES; 1024 else 1025 RETSETNO; 1026 } 1027 1028 PP(pp_andassign) 1029 { 1030 dSP; 1031 if (!SvTRUE(TOPs)) 1032 RETURN; 1033 else 1034 RETURNOP(cLOGOP->op_other); 1035 } 1036 1037 PP(pp_orassign) 1038 { 1039 dSP; 1040 if (SvTRUE(TOPs)) 1041 RETURN; 1042 else 1043 RETURNOP(cLOGOP->op_other); 1044 } 1045 1046 #ifdef DEPRECATED 1047 PP(pp_entersubr) 1048 { 1049 dSP; 1050 SV** mark = (stack_base + *markstack_ptr + 1); 1051 SV* cv = *mark; 1052 while (mark < sp) { /* emulate old interface */ 1053 *mark = mark[1]; 1054 mark++; 1055 } 1056 *sp = cv; 1057 return pp_entersub(); 1058 } 1059 #endif 1060 1061 PP(pp_caller) 1062 { 1063 dSP; 1064 register I32 cxix = dopoptosub(cxstack_ix); 1065 register CONTEXT *cx; 1066 I32 dbcxix; 1067 SV *sv; 1068 I32 count = 0; 1069 1070 if (MAXARG) 1071 count = POPi; 1072 EXTEND(SP, 6); 1073 for (;;) { 1074 if (cxix < 0) { 1075 if (GIMME != G_ARRAY) 1076 RETPUSHUNDEF; 1077 RETURN; 1078 } 1079 if (DBsub && cxix >= 0 && 1080 cxstack[cxix].blk_sub.cv == GvCV(DBsub)) 1081 count++; 1082 if (!count--) 1083 break; 1084 cxix = dopoptosub(cxix - 1); 1085 } 1086 cx = &cxstack[cxix]; 1087 if (cxstack[cxix].cx_type == CXt_SUB) { 1088 dbcxix = dopoptosub(cxix - 1); 1089 /* We expect that cxstack[dbcxix] is CXt_SUB, anyway, the 1090 field below is defined for any cx. */ 1091 if (DBsub && dbcxix >= 0 && cxstack[dbcxix].blk_sub.cv == GvCV(DBsub)) 1092 cx = &cxstack[dbcxix]; 1093 } 1094 1095 if (GIMME != G_ARRAY) { 1096 dTARGET; 1097 1098 sv_setpv(TARG, HvNAME(cx->blk_oldcop->cop_stash)); 1099 PUSHs(TARG); 1100 RETURN; 1101 } 1102 1103 PUSHs(sv_2mortal(newSVpv(HvNAME(cx->blk_oldcop->cop_stash), 0))); 1104 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0))); 1105 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line))); 1106 if (!MAXARG) 1107 RETURN; 1108 if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */ 1109 sv = NEWSV(49, 0); 1110 gv_efullname(sv, CvGV(cxstack[cxix].blk_sub.cv)); 1111 PUSHs(sv_2mortal(sv)); 1112 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); 1113 } 1114 else { 1115 PUSHs(sv_2mortal(newSVpv("(eval)",0))); 1116 PUSHs(sv_2mortal(newSViv(0))); 1117 } 1118 PUSHs(sv_2mortal(newSViv((I32)cx->blk_gimme))); 1119 if (cx->cx_type == CXt_EVAL) { 1120 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { 1121 PUSHs(cx->blk_eval.cur_text); 1122 PUSHs(&sv_no); 1123 } 1124 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */ 1125 /* Require, put the name. */ 1126 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0))); 1127 PUSHs(&sv_yes); 1128 } 1129 } 1130 else if (cx->cx_type == CXt_SUB && 1131 cx->blk_sub.hasargs && 1132 curcop->cop_stash == debstash) 1133 { 1134 AV *ary = cx->blk_sub.argarray; 1135 int off = AvARRAY(ary) - AvALLOC(ary); 1136 1137 if (!dbargs) { 1138 GV* tmpgv; 1139 dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE, 1140 SVt_PVAV))); 1141 GvMULTI_on(tmpgv); 1142 AvREAL_off(dbargs); /* XXX Should be REIFY */ 1143 } 1144 1145 if (AvMAX(dbargs) < AvFILL(ary) + off) 1146 av_extend(dbargs, AvFILL(ary) + off); 1147 Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILL(ary) + 1 + off, SV*); 1148 AvFILL(dbargs) = AvFILL(ary) + off; 1149 } 1150 RETURN; 1151 } 1152 1153 static int 1154 sortcv(a, b) 1155 const void *a; 1156 const void *b; 1157 { 1158 SV **str1 = (SV **) a; 1159 SV **str2 = (SV **) b; 1160 I32 oldsaveix = savestack_ix; 1161 I32 oldscopeix = scopestack_ix; 1162 I32 result; 1163 GvSV(firstgv) = *str1; 1164 GvSV(secondgv) = *str2; 1165 stack_sp = stack_base; 1166 op = sortcop; 1167 runops(); 1168 if (stack_sp != stack_base + 1) 1169 croak("Sort subroutine didn't return single value"); 1170 if (!SvNIOKp(*stack_sp)) 1171 croak("Sort subroutine didn't return a numeric value"); 1172 result = SvIV(*stack_sp); 1173 while (scopestack_ix > oldscopeix) { 1174 LEAVE; 1175 } 1176 leave_scope(oldsaveix); 1177 return result; 1178 } 1179 1180 static int 1181 sortcmp(a, b) 1182 const void *a; 1183 const void *b; 1184 { 1185 register SV *str1 = *(SV **) a; 1186 register SV *str2 = *(SV **) b; 1187 I32 retval; 1188 1189 if (!SvPOKp(str1)) { 1190 if (!SvPOKp(str2)) 1191 return 0; 1192 else 1193 return -1; 1194 } 1195 if (!SvPOKp(str2)) 1196 return 1; 1197 1198 if (SvCUR(str1) < SvCUR(str2)) { 1199 /*SUPPRESS 560*/ 1200 if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str1))) 1201 return retval; 1202 else 1203 return -1; 1204 } 1205 /*SUPPRESS 560*/ 1206 else if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str2))) 1207 return retval; 1208 else if (SvCUR(str1) == SvCUR(str2)) 1209 return 0; 1210 else 1211 return 1; 1212 } 1213 1214 PP(pp_reset) 1215 { 1216 dSP; 1217 char *tmps; 1218 1219 if (MAXARG < 1) 1220 tmps = ""; 1221 else 1222 tmps = POPp; 1223 sv_reset(tmps, curcop->cop_stash); 1224 PUSHs(&sv_yes); 1225 RETURN; 1226 } 1227 1228 PP(pp_lineseq) 1229 { 1230 return NORMAL; 1231 } 1232 1233 PP(pp_dbstate) 1234 { 1235 curcop = (COP*)op; 1236 TAINT_NOT; /* Each statement is presumed innocent */ 1237 stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp; 1238 FREETMPS; 1239 1240 if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace)) 1241 { 1242 SV **sp; 1243 register CV *cv; 1244 register CONTEXT *cx; 1245 I32 gimme = G_ARRAY; 1246 I32 hasargs; 1247 GV *gv; 1248 1249 gv = DBgv; 1250 cv = GvCV(gv); 1251 if (!cv) 1252 DIE("No DB::DB routine defined"); 1253 1254 if (CvDEPTH(cv) >= 1 && !(debug & (1<<30))) /* don't do recursive DB::DB call */ 1255 return NORMAL; 1256 1257 ENTER; 1258 SAVETMPS; 1259 1260 SAVEI32(debug); 1261 SAVESPTR(stack_sp); 1262 debug = 0; 1263 hasargs = 0; 1264 sp = stack_sp; 1265 1266 push_return(op->op_next); 1267 PUSHBLOCK(cx, CXt_SUB, sp); 1268 PUSHSUB(cx); 1269 CvDEPTH(cv)++; 1270 (void)SvREFCNT_inc(cv); 1271 SAVESPTR(curpad); 1272 curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE)); 1273 RETURNOP(CvSTART(cv)); 1274 } 1275 else 1276 return NORMAL; 1277 } 1278 1279 PP(pp_scope) 1280 { 1281 return NORMAL; 1282 } 1283 1284 PP(pp_enteriter) 1285 { 1286 dSP; dMARK; 1287 register CONTEXT *cx; 1288 I32 gimme = GIMME; 1289 SV **svp; 1290 1291 ENTER; 1292 SAVETMPS; 1293 1294 if (op->op_targ) 1295 svp = &curpad[op->op_targ]; /* "my" variable */ 1296 else 1297 svp = &GvSV((GV*)POPs); /* symbol table variable */ 1298 1299 SAVESPTR(*svp); 1300 1301 ENTER; 1302 1303 PUSHBLOCK(cx, CXt_LOOP, SP); 1304 PUSHLOOP(cx, svp, MARK); 1305 if (op->op_flags & OPf_STACKED) { 1306 AV* av = (AV*)POPs; 1307 cx->blk_loop.iterary = av; 1308 cx->blk_loop.iterix = -1; 1309 } 1310 else { 1311 cx->blk_loop.iterary = stack; 1312 AvFILL(stack) = sp - stack_base; 1313 cx->blk_loop.iterix = MARK - stack_base; 1314 } 1315 1316 RETURN; 1317 } 1318 1319 PP(pp_enterloop) 1320 { 1321 dSP; 1322 register CONTEXT *cx; 1323 I32 gimme = GIMME; 1324 1325 ENTER; 1326 SAVETMPS; 1327 ENTER; 1328 1329 PUSHBLOCK(cx, CXt_LOOP, SP); 1330 PUSHLOOP(cx, 0, SP); 1331 1332 RETURN; 1333 } 1334 1335 PP(pp_leaveloop) 1336 { 1337 dSP; 1338 register CONTEXT *cx; 1339 I32 gimme; 1340 SV **newsp; 1341 PMOP *newpm; 1342 SV **mark; 1343 1344 POPBLOCK(cx,newpm); 1345 mark = newsp; 1346 POPLOOP(cx); 1347 if (gimme == G_SCALAR) { 1348 if (op->op_private & OPpLEAVE_VOID) 1349 ; 1350 else { 1351 if (mark < SP) 1352 *++newsp = sv_mortalcopy(*SP); 1353 else 1354 *++newsp = &sv_undef; 1355 } 1356 } 1357 else { 1358 while (mark < SP) 1359 *++newsp = sv_mortalcopy(*++mark); 1360 } 1361 curpm = newpm; /* Don't pop $1 et al till now */ 1362 sp = newsp; 1363 LEAVE; 1364 LEAVE; 1365 1366 RETURN; 1367 } 1368 1369 PP(pp_return) 1370 { 1371 dSP; dMARK; 1372 I32 cxix; 1373 register CONTEXT *cx; 1374 I32 gimme; 1375 SV **newsp; 1376 PMOP *newpm; 1377 I32 optype = 0; 1378 1379 if (stack == sortstack) { 1380 if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) < sortcxix) { 1381 if (cxstack_ix > sortcxix) 1382 dounwind(sortcxix); 1383 AvARRAY(stack)[1] = *SP; 1384 stack_sp = stack_base + 1; 1385 return 0; 1386 } 1387 } 1388 1389 cxix = dopoptosub(cxstack_ix); 1390 if (cxix < 0) 1391 DIE("Can't return outside a subroutine"); 1392 if (cxix < cxstack_ix) 1393 dounwind(cxix); 1394 1395 POPBLOCK(cx,newpm); 1396 switch (cx->cx_type) { 1397 case CXt_SUB: 1398 POPSUB(cx); 1399 break; 1400 case CXt_EVAL: 1401 POPEVAL(cx); 1402 if (optype == OP_REQUIRE && 1403 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) 1404 { 1405 char *name = cx->blk_eval.old_name; 1406 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD); 1407 DIE("%s did not return a true value", name); 1408 } 1409 break; 1410 default: 1411 DIE("panic: return"); 1412 break; 1413 } 1414 1415 if (gimme == G_SCALAR) { 1416 if (MARK < SP) 1417 *++newsp = sv_mortalcopy(*SP); 1418 else 1419 *++newsp = &sv_undef; 1420 } 1421 else { 1422 while (MARK < SP) 1423 *++newsp = sv_mortalcopy(*++MARK); 1424 } 1425 curpm = newpm; /* Don't pop $1 et al till now */ 1426 stack_sp = newsp; 1427 1428 LEAVE; 1429 return pop_return(); 1430 } 1431 1432 PP(pp_last) 1433 { 1434 dSP; 1435 I32 cxix; 1436 register CONTEXT *cx; 1437 I32 gimme; 1438 I32 optype; 1439 OP *nextop; 1440 SV **newsp; 1441 PMOP *newpm; 1442 SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp; 1443 1444 if (op->op_flags & OPf_SPECIAL) { 1445 cxix = dopoptoloop(cxstack_ix); 1446 if (cxix < 0) 1447 DIE("Can't \"last\" outside a block"); 1448 } 1449 else { 1450 cxix = dopoptolabel(cPVOP->op_pv); 1451 if (cxix < 0) 1452 DIE("Label not found for \"last %s\"", cPVOP->op_pv); 1453 } 1454 if (cxix < cxstack_ix) 1455 dounwind(cxix); 1456 1457 POPBLOCK(cx,newpm); 1458 switch (cx->cx_type) { 1459 case CXt_LOOP: 1460 POPLOOP(cx); 1461 nextop = cx->blk_loop.last_op->op_next; 1462 LEAVE; 1463 break; 1464 case CXt_EVAL: 1465 POPEVAL(cx); 1466 nextop = pop_return(); 1467 break; 1468 case CXt_SUB: 1469 POPSUB(cx); 1470 nextop = pop_return(); 1471 break; 1472 default: 1473 DIE("panic: last"); 1474 break; 1475 } 1476 1477 if (gimme == G_SCALAR) { 1478 if (mark < SP) 1479 *++newsp = sv_mortalcopy(*SP); 1480 else 1481 *++newsp = &sv_undef; 1482 } 1483 else { 1484 while (mark < SP) 1485 *++newsp = sv_mortalcopy(*++mark); 1486 } 1487 curpm = newpm; /* Don't pop $1 et al till now */ 1488 sp = newsp; 1489 1490 LEAVE; 1491 RETURNOP(nextop); 1492 } 1493 1494 PP(pp_next) 1495 { 1496 I32 cxix; 1497 register CONTEXT *cx; 1498 I32 oldsave; 1499 1500 if (op->op_flags & OPf_SPECIAL) { 1501 cxix = dopoptoloop(cxstack_ix); 1502 if (cxix < 0) 1503 DIE("Can't \"next\" outside a block"); 1504 } 1505 else { 1506 cxix = dopoptolabel(cPVOP->op_pv); 1507 if (cxix < 0) 1508 DIE("Label not found for \"next %s\"", cPVOP->op_pv); 1509 } 1510 if (cxix < cxstack_ix) 1511 dounwind(cxix); 1512 1513 TOPBLOCK(cx); 1514 oldsave = scopestack[scopestack_ix - 1]; 1515 LEAVE_SCOPE(oldsave); 1516 return cx->blk_loop.next_op; 1517 } 1518 1519 PP(pp_redo) 1520 { 1521 I32 cxix; 1522 register CONTEXT *cx; 1523 I32 oldsave; 1524 1525 if (op->op_flags & OPf_SPECIAL) { 1526 cxix = dopoptoloop(cxstack_ix); 1527 if (cxix < 0) 1528 DIE("Can't \"redo\" outside a block"); 1529 } 1530 else { 1531 cxix = dopoptolabel(cPVOP->op_pv); 1532 if (cxix < 0) 1533 DIE("Label not found for \"redo %s\"", cPVOP->op_pv); 1534 } 1535 if (cxix < cxstack_ix) 1536 dounwind(cxix); 1537 1538 TOPBLOCK(cx); 1539 oldsave = scopestack[scopestack_ix - 1]; 1540 LEAVE_SCOPE(oldsave); 1541 return cx->blk_loop.redo_op; 1542 } 1543 1544 static OP* lastgotoprobe; 1545 1546 static OP * 1547 dofindlabel(op,label,opstack) 1548 OP *op; 1549 char *label; 1550 OP **opstack; 1551 { 1552 OP *kid; 1553 OP **ops = opstack; 1554 1555 if (op->op_type == OP_LEAVE || 1556 op->op_type == OP_SCOPE || 1557 op->op_type == OP_LEAVELOOP || 1558 op->op_type == OP_LEAVETRY) 1559 *ops++ = cUNOP->op_first; 1560 *ops = 0; 1561 if (op->op_flags & OPf_KIDS) { 1562 /* First try all the kids at this level, since that's likeliest. */ 1563 for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) { 1564 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && 1565 kCOP->cop_label && strEQ(kCOP->cop_label, label)) 1566 return kid; 1567 } 1568 for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) { 1569 if (kid == lastgotoprobe) 1570 continue; 1571 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { 1572 if (ops > opstack && 1573 (ops[-1]->op_type == OP_NEXTSTATE || 1574 ops[-1]->op_type == OP_DBSTATE)) 1575 *ops = kid; 1576 else 1577 *ops++ = kid; 1578 } 1579 if (op = dofindlabel(kid,label,ops)) 1580 return op; 1581 } 1582 } 1583 *ops = 0; 1584 return 0; 1585 } 1586 1587 PP(pp_dump) 1588 { 1589 return pp_goto(ARGS); 1590 /*NOTREACHED*/ 1591 } 1592 1593 PP(pp_goto) 1594 { 1595 dSP; 1596 OP *retop = 0; 1597 I32 ix; 1598 register CONTEXT *cx; 1599 OP *enterops[64]; 1600 char *label; 1601 int do_dump = (op->op_type == OP_DUMP); 1602 1603 label = 0; 1604 if (op->op_flags & OPf_STACKED) { 1605 SV *sv = POPs; 1606 1607 /* This egregious kludge implements goto &subroutine */ 1608 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { 1609 I32 cxix; 1610 register CONTEXT *cx; 1611 CV* cv = (CV*)SvRV(sv); 1612 SV** mark; 1613 I32 items = 0; 1614 I32 oldsave; 1615 1616 if (!CvROOT(cv) && !CvXSUB(cv)) { 1617 if (CvGV(cv)) { 1618 SV *tmpstr = sv_newmortal(); 1619 gv_efullname(tmpstr, CvGV(cv)); 1620 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr)); 1621 } 1622 DIE("Goto undefined subroutine"); 1623 } 1624 1625 /* First do some returnish stuff. */ 1626 cxix = dopoptosub(cxstack_ix); 1627 if (cxix < 0) 1628 DIE("Can't goto subroutine outside a subroutine"); 1629 if (cxix < cxstack_ix) 1630 dounwind(cxix); 1631 TOPBLOCK(cx); 1632 mark = stack_sp; 1633 if (cx->blk_sub.hasargs) { /* put @_ back onto stack */ 1634 AV* av = cx->blk_sub.argarray; 1635 1636 items = AvFILL(av) + 1; 1637 Copy(AvARRAY(av), ++stack_sp, items, SV*); 1638 stack_sp += items; 1639 GvAV(defgv) = cx->blk_sub.savearray; 1640 AvREAL_off(av); 1641 av_clear(av); 1642 } 1643 if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) 1644 SvREFCNT_dec(cx->blk_sub.cv); 1645 oldsave = scopestack[scopestack_ix - 1]; 1646 LEAVE_SCOPE(oldsave); 1647 1648 /* Now do some callish stuff. */ 1649 SAVETMPS; 1650 if (CvXSUB(cv)) { 1651 if (CvOLDSTYLE(cv)) { 1652 I32 (*fp3)_((int,int,int)); 1653 while (sp > mark) { 1654 sp[1] = sp[0]; 1655 sp--; 1656 } 1657 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv); 1658 items = (*fp3)(CvXSUBANY(cv).any_i32, 1659 mark - stack_base + 1, 1660 items); 1661 sp = stack_base + items; 1662 } 1663 else { 1664 (void)(*CvXSUB(cv))(cv); 1665 } 1666 LEAVE; 1667 return pop_return(); 1668 } 1669 else { 1670 AV* padlist = CvPADLIST(cv); 1671 SV** svp = AvARRAY(padlist); 1672 cx->blk_sub.cv = cv; 1673 cx->blk_sub.olddepth = CvDEPTH(cv); 1674 CvDEPTH(cv)++; 1675 if (CvDEPTH(cv) < 2) 1676 (void)SvREFCNT_inc(cv); 1677 else { /* save temporaries on recursion? */ 1678 if (CvDEPTH(cv) == 100 && dowarn) 1679 warn("Deep recursion on subroutine \"%s\"", 1680 GvENAME(CvGV(cv))); 1681 if (CvDEPTH(cv) > AvFILL(padlist)) { 1682 AV *newpad = newAV(); 1683 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]); 1684 I32 ix = AvFILL((AV*)svp[1]); 1685 svp = AvARRAY(svp[0]); 1686 for ( ;ix > 0; ix--) { 1687 if (svp[ix] != &sv_undef) { 1688 char *name = SvPVX(svp[ix]); 1689 if (SvFLAGS(svp[ix]) & SVf_FAKE) { 1690 /* outer lexical? */ 1691 av_store(newpad, ix, 1692 SvREFCNT_inc(oldpad[ix]) ); 1693 } 1694 else { /* our own lexical */ 1695 if (*name == '@') 1696 av_store(newpad, ix, sv = (SV*)newAV()); 1697 else if (*name == '%') 1698 av_store(newpad, ix, sv = (SV*)newHV()); 1699 else 1700 av_store(newpad, ix, sv = NEWSV(0,0)); 1701 SvPADMY_on(sv); 1702 } 1703 } 1704 else { 1705 av_store(newpad, ix, sv = NEWSV(0,0)); 1706 SvPADTMP_on(sv); 1707 } 1708 } 1709 if (cx->blk_sub.hasargs) { 1710 AV* av = newAV(); 1711 av_extend(av, 0); 1712 av_store(newpad, 0, (SV*)av); 1713 AvFLAGS(av) = AVf_REIFY; 1714 } 1715 av_store(padlist, CvDEPTH(cv), (SV*)newpad); 1716 AvFILL(padlist) = CvDEPTH(cv); 1717 svp = AvARRAY(padlist); 1718 } 1719 } 1720 SAVESPTR(curpad); 1721 curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); 1722 if (cx->blk_sub.hasargs) { 1723 AV* av = (AV*)curpad[0]; 1724 SV** ary; 1725 1726 cx->blk_sub.savearray = GvAV(defgv); 1727 cx->blk_sub.argarray = av; 1728 GvAV(defgv) = cx->blk_sub.argarray; 1729 ++mark; 1730 1731 if (items >= AvMAX(av) + 1) { 1732 ary = AvALLOC(av); 1733 if (AvARRAY(av) != ary) { 1734 AvMAX(av) += AvARRAY(av) - AvALLOC(av); 1735 SvPVX(av) = (char*)ary; 1736 } 1737 if (items >= AvMAX(av) + 1) { 1738 AvMAX(av) = items - 1; 1739 Renew(ary,items+1,SV*); 1740 AvALLOC(av) = ary; 1741 SvPVX(av) = (char*)ary; 1742 } 1743 } 1744 Copy(mark,AvARRAY(av),items,SV*); 1745 AvFILL(av) = items - 1; 1746 1747 while (items--) { 1748 if (*mark) 1749 SvTEMP_off(*mark); 1750 mark++; 1751 } 1752 } 1753 RETURNOP(CvSTART(cv)); 1754 } 1755 } 1756 else 1757 label = SvPV(sv,na); 1758 } 1759 else if (op->op_flags & OPf_SPECIAL) { 1760 if (! do_dump) 1761 DIE("goto must have label"); 1762 } 1763 else 1764 label = cPVOP->op_pv; 1765 1766 if (label && *label) { 1767 OP *gotoprobe = 0; 1768 1769 /* find label */ 1770 1771 lastgotoprobe = 0; 1772 *enterops = 0; 1773 for (ix = cxstack_ix; ix >= 0; ix--) { 1774 cx = &cxstack[ix]; 1775 switch (cx->cx_type) { 1776 case CXt_SUB: 1777 gotoprobe = CvROOT(cx->blk_sub.cv); 1778 break; 1779 case CXt_EVAL: 1780 gotoprobe = eval_root; /* XXX not good for nested eval */ 1781 break; 1782 case CXt_LOOP: 1783 gotoprobe = cx->blk_oldcop->op_sibling; 1784 break; 1785 case CXt_SUBST: 1786 continue; 1787 case CXt_BLOCK: 1788 if (ix) 1789 gotoprobe = cx->blk_oldcop->op_sibling; 1790 else 1791 gotoprobe = main_root; 1792 break; 1793 default: 1794 if (ix) 1795 DIE("panic: goto"); 1796 else 1797 gotoprobe = main_root; 1798 break; 1799 } 1800 retop = dofindlabel(gotoprobe, label, enterops); 1801 if (retop) 1802 break; 1803 lastgotoprobe = gotoprobe; 1804 } 1805 if (!retop) 1806 DIE("Can't find label %s", label); 1807 1808 /* pop unwanted frames */ 1809 1810 if (ix < cxstack_ix) { 1811 I32 oldsave; 1812 1813 if (ix < 0) 1814 ix = 0; 1815 dounwind(ix); 1816 TOPBLOCK(cx); 1817 oldsave = scopestack[scopestack_ix]; 1818 LEAVE_SCOPE(oldsave); 1819 } 1820 1821 /* push wanted frames */ 1822 1823 if (*enterops && enterops[1]) { 1824 OP *oldop = op; 1825 for (ix = 1; enterops[ix]; ix++) { 1826 op = enterops[ix]; 1827 (*op->op_ppaddr)(); 1828 } 1829 op = oldop; 1830 } 1831 } 1832 1833 if (do_dump) { 1834 #ifdef VMS 1835 if (!retop) retop = main_start; 1836 #endif 1837 restartop = retop; 1838 do_undump = TRUE; 1839 1840 my_unexec(); 1841 1842 restartop = 0; /* hmm, must be GNU unexec().. */ 1843 do_undump = FALSE; 1844 } 1845 1846 if (stack == signalstack) { 1847 restartop = retop; 1848 Siglongjmp(top_env, 3); 1849 } 1850 1851 RETURNOP(retop); 1852 } 1853 1854 PP(pp_exit) 1855 { 1856 dSP; 1857 I32 anum; 1858 1859 if (MAXARG < 1) 1860 anum = 0; 1861 else 1862 anum = SvIVx(POPs); 1863 my_exit(anum); 1864 PUSHs(&sv_undef); 1865 RETURN; 1866 } 1867 1868 #ifdef NOTYET 1869 PP(pp_nswitch) 1870 { 1871 dSP; 1872 double value = SvNVx(GvSV(cCOP->cop_gv)); 1873 register I32 match = I_32(value); 1874 1875 if (value < 0.0) { 1876 if (((double)match) > value) 1877 --match; /* was fractional--truncate other way */ 1878 } 1879 match -= cCOP->uop.scop.scop_offset; 1880 if (match < 0) 1881 match = 0; 1882 else if (match > cCOP->uop.scop.scop_max) 1883 match = cCOP->uop.scop.scop_max; 1884 op = cCOP->uop.scop.scop_next[match]; 1885 RETURNOP(op); 1886 } 1887 1888 PP(pp_cswitch) 1889 { 1890 dSP; 1891 register I32 match; 1892 1893 if (multiline) 1894 op = op->op_next; /* can't assume anything */ 1895 else { 1896 match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255; 1897 match -= cCOP->uop.scop.scop_offset; 1898 if (match < 0) 1899 match = 0; 1900 else if (match > cCOP->uop.scop.scop_max) 1901 match = cCOP->uop.scop.scop_max; 1902 op = cCOP->uop.scop.scop_next[match]; 1903 } 1904 RETURNOP(op); 1905 } 1906 #endif 1907 1908 /* Eval. */ 1909 1910 static void 1911 save_lines(array, sv) 1912 AV *array; 1913 SV *sv; 1914 { 1915 register char *s = SvPVX(sv); 1916 register char *send = SvPVX(sv) + SvCUR(sv); 1917 register char *t; 1918 register I32 line = 1; 1919 1920 while (s && s < send) { 1921 SV *tmpstr = NEWSV(85,0); 1922 1923 sv_upgrade(tmpstr, SVt_PVMG); 1924 t = strchr(s, '\n'); 1925 if (t) 1926 t++; 1927 else 1928 t = send; 1929 1930 sv_setpvn(tmpstr, s, t - s); 1931 av_store(array, line++, tmpstr); 1932 s = t; 1933 } 1934 } 1935 1936 static OP * 1937 doeval(gimme) 1938 int gimme; 1939 { 1940 dSP; 1941 OP *saveop = op; 1942 HV *newstash; 1943 AV* comppadlist; 1944 1945 in_eval = 1; 1946 1947 /* set up a scratch pad */ 1948 1949 SAVEINT(padix); 1950 SAVESPTR(curpad); 1951 SAVESPTR(comppad); 1952 SAVESPTR(comppad_name); 1953 SAVEINT(comppad_name_fill); 1954 SAVEINT(min_intro_pending); 1955 SAVEINT(max_intro_pending); 1956 1957 SAVESPTR(compcv); 1958 compcv = (CV*)NEWSV(1104,0); 1959 sv_upgrade((SV *)compcv, SVt_PVCV); 1960 1961 comppad = newAV(); 1962 comppad_name = newAV(); 1963 comppad_name_fill = 0; 1964 min_intro_pending = 0; 1965 av_push(comppad, Nullsv); 1966 curpad = AvARRAY(comppad); 1967 padix = 0; 1968 1969 comppadlist = newAV(); 1970 AvREAL_off(comppadlist); 1971 av_store(comppadlist, 0, (SV*)comppad_name); 1972 av_store(comppadlist, 1, (SV*)comppad); 1973 CvPADLIST(compcv) = comppadlist; 1974 SAVEFREESV(compcv); 1975 1976 /* make sure we compile in the right package */ 1977 1978 newstash = curcop->cop_stash; 1979 if (curstash != newstash) { 1980 SAVESPTR(curstash); 1981 curstash = newstash; 1982 } 1983 SAVESPTR(beginav); 1984 beginav = newAV(); 1985 SAVEFREESV(beginav); 1986 1987 /* try to compile it */ 1988 1989 eval_root = Nullop; 1990 error_count = 0; 1991 curcop = &compiling; 1992 curcop->cop_arybase = 0; 1993 SvREFCNT_dec(rs); 1994 rs = newSVpv("\n", 1); 1995 sv_setpv(GvSV(errgv),""); 1996 if (yyparse() || error_count || !eval_root) { 1997 SV **newsp; 1998 I32 gimme; 1999 CONTEXT *cx; 2000 I32 optype; 2001 2002 op = saveop; 2003 if (eval_root) { 2004 op_free(eval_root); 2005 eval_root = Nullop; 2006 } 2007 POPBLOCK(cx,curpm); 2008 POPEVAL(cx); 2009 pop_return(); 2010 lex_end(); 2011 LEAVE; 2012 if (optype == OP_REQUIRE) 2013 DIE("%s", SvPVx(GvSV(errgv), na)); 2014 SvREFCNT_dec(rs); 2015 rs = SvREFCNT_inc(nrs); 2016 RETPUSHUNDEF; 2017 } 2018 SvREFCNT_dec(rs); 2019 rs = SvREFCNT_inc(nrs); 2020 compiling.cop_line = 0; 2021 SAVEFREEOP(eval_root); 2022 if (gimme & G_ARRAY) 2023 list(eval_root); 2024 else 2025 scalar(eval_root); 2026 2027 DEBUG_x(dump_eval()); 2028 2029 /* compiled okay, so do it */ 2030 2031 RETURNOP(eval_start); 2032 } 2033 2034 PP(pp_require) 2035 { 2036 dSP; 2037 register CONTEXT *cx; 2038 SV *sv; 2039 char *name; 2040 char *tmpname; 2041 SV** svp; 2042 I32 gimme = G_SCALAR; 2043 FILE *tryrsfp = 0; 2044 2045 sv = POPs; 2046 if (SvNIOKp(sv) && !SvPOKp(sv)) { 2047 if (atof(patchlevel) + 0.00000999 < SvNV(sv)) 2048 DIE("Perl %s required--this is only version %s, stopped", 2049 SvPV(sv,na),patchlevel); 2050 RETPUSHYES; 2051 } 2052 name = SvPV(sv, na); 2053 if (!*name) 2054 DIE("Null filename used"); 2055 TAINT_PROPER("require"); 2056 if (op->op_type == OP_REQUIRE && 2057 (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) && 2058 *svp != &sv_undef) 2059 RETPUSHYES; 2060 2061 /* prepare to compile file */ 2062 2063 tmpname = savepv(name); 2064 if (*tmpname == '/' || 2065 (*tmpname == '.' && 2066 (tmpname[1] == '/' || 2067 (tmpname[1] == '.' && tmpname[2] == '/'))) 2068 #ifdef DOSISH 2069 || (tmpname[0] && tmpname[1] == ':') 2070 #endif 2071 #ifdef VMS 2072 || (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') && 2073 (tmpname[1] == '-' || tmpname[1] == ']' || tmpname[1] == '>'))) 2074 #endif 2075 ) 2076 { 2077 tryrsfp = fopen(tmpname,"r"); 2078 } 2079 else { 2080 AV *ar = GvAVn(incgv); 2081 I32 i; 2082 2083 for (i = 0; i <= AvFILL(ar); i++) { 2084 #ifdef VMS 2085 if (tounixpath_ts(SvPVx(*av_fetch(ar, i, TRUE), na),buf) == NULL) 2086 continue; 2087 strcat(buf,name); 2088 #else 2089 (void)sprintf(buf, "%s/%s", 2090 SvPVx(*av_fetch(ar, i, TRUE), na), name); 2091 #endif 2092 tryrsfp = fopen(buf, "r"); 2093 if (tryrsfp) { 2094 char *s = buf; 2095 2096 if (*s == '.' && s[1] == '/') 2097 s += 2; 2098 Safefree(tmpname); 2099 tmpname = savepv(s); 2100 break; 2101 } 2102 } 2103 } 2104 SAVESPTR(compiling.cop_filegv); 2105 compiling.cop_filegv = gv_fetchfile(tmpname); 2106 Safefree(tmpname); 2107 tmpname = Nullch; 2108 if (!tryrsfp) { 2109 if (op->op_type == OP_REQUIRE) { 2110 sprintf(tokenbuf,"Can't locate %s in @INC", name); 2111 if (instr(tokenbuf,".h ")) 2112 strcat(tokenbuf," (change .h to .ph maybe?)"); 2113 if (instr(tokenbuf,".ph ")) 2114 strcat(tokenbuf," (did you run h2ph?)"); 2115 DIE("%s",tokenbuf); 2116 } 2117 2118 RETPUSHUNDEF; 2119 } 2120 2121 /* Assume success here to prevent recursive requirement. */ 2122 (void)hv_store(GvHVn(incgv), name, strlen(name), 2123 newSVsv(GvSV(compiling.cop_filegv)), 0 ); 2124 2125 ENTER; 2126 SAVETMPS; 2127 lex_start(sv_2mortal(newSVpv("",0))); 2128 if (rsfp_filters){ 2129 save_aptr(&rsfp_filters); 2130 rsfp_filters = NULL; 2131 } 2132 2133 rsfp = tryrsfp; 2134 name = savepv(name); 2135 SAVEFREEPV(name); 2136 SAVEI32(hints); 2137 hints = 0; 2138 2139 /* switch to eval mode */ 2140 2141 push_return(op->op_next); 2142 PUSHBLOCK(cx, CXt_EVAL, SP); 2143 PUSHEVAL(cx, name, compiling.cop_filegv); 2144 2145 compiling.cop_line = 0; 2146 2147 PUTBACK; 2148 return doeval(G_SCALAR); 2149 } 2150 2151 PP(pp_dofile) 2152 { 2153 return pp_require(ARGS); 2154 } 2155 2156 PP(pp_entereval) 2157 { 2158 dSP; 2159 register CONTEXT *cx; 2160 dPOPss; 2161 I32 gimme = GIMME; 2162 char tmpbuf[32]; 2163 STRLEN len; 2164 2165 if (!SvPV(sv,len) || !len) 2166 RETPUSHUNDEF; 2167 TAINT_PROPER("eval"); 2168 2169 ENTER; 2170 lex_start(sv); 2171 SAVETMPS; 2172 2173 /* switch to eval mode */ 2174 2175 SAVESPTR(compiling.cop_filegv); 2176 sprintf(tmpbuf, "_<(eval %d)", ++evalseq); 2177 compiling.cop_filegv = gv_fetchfile(tmpbuf+2); 2178 compiling.cop_line = 1; 2179 SAVEDELETE(defstash, savepv(tmpbuf), strlen(tmpbuf)); 2180 SAVEI32(hints); 2181 hints = op->op_targ; 2182 2183 push_return(op->op_next); 2184 PUSHBLOCK(cx, CXt_EVAL, SP); 2185 PUSHEVAL(cx, 0, compiling.cop_filegv); 2186 2187 /* prepare to compile string */ 2188 2189 if (perldb && curstash != debstash) 2190 save_lines(GvAV(compiling.cop_filegv), linestr); 2191 PUTBACK; 2192 return doeval(gimme); 2193 } 2194 2195 PP(pp_leaveeval) 2196 { 2197 dSP; 2198 register SV **mark; 2199 SV **newsp; 2200 PMOP *newpm; 2201 I32 gimme; 2202 register CONTEXT *cx; 2203 OP *retop; 2204 I32 optype; 2205 2206 POPBLOCK(cx,newpm); 2207 POPEVAL(cx); 2208 retop = pop_return(); 2209 2210 if (gimme == G_SCALAR) { 2211 if (op->op_private & OPpLEAVE_VOID) 2212 MARK = newsp; 2213 else { 2214 MARK = newsp + 1; 2215 if (MARK <= SP) { 2216 if (SvFLAGS(TOPs) & SVs_TEMP) 2217 *MARK = TOPs; 2218 else 2219 *MARK = sv_mortalcopy(TOPs); 2220 } 2221 else { 2222 MEXTEND(mark,0); 2223 *MARK = &sv_undef; 2224 } 2225 } 2226 SP = MARK; 2227 } 2228 else { 2229 for (mark = newsp + 1; mark <= SP; mark++) 2230 if (!(SvFLAGS(TOPs) & SVs_TEMP)) 2231 *mark = sv_mortalcopy(*mark); 2232 /* in case LEAVE wipes old return values */ 2233 } 2234 curpm = newpm; /* Don't pop $1 et al till now */ 2235 2236 if (optype != OP_ENTEREVAL) { 2237 char *name = cx->blk_eval.old_name; 2238 2239 if (!(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) { 2240 /* Unassume the success we assumed earlier. */ 2241 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD); 2242 2243 if (optype == OP_REQUIRE) 2244 retop = die("%s did not return a true value", name); 2245 } 2246 } 2247 2248 lex_end(); 2249 LEAVE; 2250 sv_setpv(GvSV(errgv),""); 2251 2252 RETURNOP(retop); 2253 } 2254 2255 PP(pp_entertry) 2256 { 2257 dSP; 2258 register CONTEXT *cx; 2259 I32 gimme = GIMME; 2260 2261 ENTER; 2262 SAVETMPS; 2263 2264 push_return(cLOGOP->op_other->op_next); 2265 PUSHBLOCK(cx, CXt_EVAL, SP); 2266 PUSHEVAL(cx, 0, 0); 2267 eval_root = op; /* Only needed so that goto works right. */ 2268 2269 in_eval = 1; 2270 sv_setpv(GvSV(errgv),""); 2271 RETURN; 2272 } 2273 2274 PP(pp_leavetry) 2275 { 2276 dSP; 2277 register SV **mark; 2278 SV **newsp; 2279 PMOP *newpm; 2280 I32 gimme; 2281 register CONTEXT *cx; 2282 I32 optype; 2283 2284 POPBLOCK(cx,newpm); 2285 POPEVAL(cx); 2286 pop_return(); 2287 2288 if (gimme == G_SCALAR) { 2289 if (op->op_private & OPpLEAVE_VOID) 2290 MARK = newsp; 2291 else { 2292 MARK = newsp + 1; 2293 if (MARK <= SP) { 2294 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) 2295 *MARK = TOPs; 2296 else 2297 *MARK = sv_mortalcopy(TOPs); 2298 } 2299 else { 2300 MEXTEND(mark,0); 2301 *MARK = &sv_undef; 2302 } 2303 } 2304 SP = MARK; 2305 } 2306 else { 2307 for (mark = newsp + 1; mark <= SP; mark++) 2308 if (!(SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))) 2309 *mark = sv_mortalcopy(*mark); 2310 /* in case LEAVE wipes old return values */ 2311 } 2312 curpm = newpm; /* Don't pop $1 et al till now */ 2313 2314 LEAVE; 2315 sv_setpv(GvSV(errgv),""); 2316 RETURN; 2317 } 2318 2319 static void 2320 doparseform(sv) 2321 SV *sv; 2322 { 2323 STRLEN len; 2324 register char *s = SvPV_force(sv, len); 2325 register char *send = s + len; 2326 register char *base; 2327 register I32 skipspaces = 0; 2328 bool noblank; 2329 bool repeat; 2330 bool postspace = FALSE; 2331 U16 *fops; 2332 register U16 *fpc; 2333 U16 *linepc; 2334 register I32 arg; 2335 bool ischop; 2336 2337 New(804, fops, (send - s)*3+2, U16); /* Almost certainly too long... */ 2338 fpc = fops; 2339 2340 if (s < send) { 2341 linepc = fpc; 2342 *fpc++ = FF_LINEMARK; 2343 noblank = repeat = FALSE; 2344 base = s; 2345 } 2346 2347 while (s <= send) { 2348 switch (*s++) { 2349 default: 2350 skipspaces = 0; 2351 continue; 2352 2353 case '~': 2354 if (*s == '~') { 2355 repeat = TRUE; 2356 *s = ' '; 2357 } 2358 noblank = TRUE; 2359 s[-1] = ' '; 2360 /* FALL THROUGH */ 2361 case ' ': case '\t': 2362 skipspaces++; 2363 continue; 2364 2365 case '\n': case 0: 2366 arg = s - base; 2367 skipspaces++; 2368 arg -= skipspaces; 2369 if (arg) { 2370 if (postspace) { 2371 *fpc++ = FF_SPACE; 2372 postspace = FALSE; 2373 } 2374 *fpc++ = FF_LITERAL; 2375 *fpc++ = arg; 2376 } 2377 if (s <= send) 2378 skipspaces--; 2379 if (skipspaces) { 2380 *fpc++ = FF_SKIP; 2381 *fpc++ = skipspaces; 2382 } 2383 skipspaces = 0; 2384 if (s <= send) 2385 *fpc++ = FF_NEWLINE; 2386 if (noblank) { 2387 *fpc++ = FF_BLANK; 2388 if (repeat) 2389 arg = fpc - linepc + 1; 2390 else 2391 arg = 0; 2392 *fpc++ = arg; 2393 } 2394 if (s < send) { 2395 linepc = fpc; 2396 *fpc++ = FF_LINEMARK; 2397 noblank = repeat = FALSE; 2398 base = s; 2399 } 2400 else 2401 s++; 2402 continue; 2403 2404 case '@': 2405 case '^': 2406 ischop = s[-1] == '^'; 2407 2408 if (postspace) { 2409 *fpc++ = FF_SPACE; 2410 postspace = FALSE; 2411 } 2412 arg = (s - base) - 1; 2413 if (arg) { 2414 *fpc++ = FF_LITERAL; 2415 *fpc++ = arg; 2416 } 2417 2418 base = s - 1; 2419 *fpc++ = FF_FETCH; 2420 if (*s == '*') { 2421 s++; 2422 *fpc++ = 0; 2423 *fpc++ = FF_LINEGLOB; 2424 } 2425 else if (*s == '#' || (*s == '.' && s[1] == '#')) { 2426 arg = ischop ? 512 : 0; 2427 base = s - 1; 2428 while (*s == '#') 2429 s++; 2430 if (*s == '.') { 2431 char *f; 2432 s++; 2433 f = s; 2434 while (*s == '#') 2435 s++; 2436 arg |= 256 + (s - f); 2437 } 2438 *fpc++ = s - base; /* fieldsize for FETCH */ 2439 *fpc++ = FF_DECIMAL; 2440 *fpc++ = arg; 2441 } 2442 else { 2443 I32 prespace = 0; 2444 bool ismore = FALSE; 2445 2446 if (*s == '>') { 2447 while (*++s == '>') ; 2448 prespace = FF_SPACE; 2449 } 2450 else if (*s == '|') { 2451 while (*++s == '|') ; 2452 prespace = FF_HALFSPACE; 2453 postspace = TRUE; 2454 } 2455 else { 2456 if (*s == '<') 2457 while (*++s == '<') ; 2458 postspace = TRUE; 2459 } 2460 if (*s == '.' && s[1] == '.' && s[2] == '.') { 2461 s += 3; 2462 ismore = TRUE; 2463 } 2464 *fpc++ = s - base; /* fieldsize for FETCH */ 2465 2466 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL; 2467 2468 if (prespace) 2469 *fpc++ = prespace; 2470 *fpc++ = FF_ITEM; 2471 if (ismore) 2472 *fpc++ = FF_MORE; 2473 if (ischop) 2474 *fpc++ = FF_CHOP; 2475 } 2476 base = s; 2477 skipspaces = 0; 2478 continue; 2479 } 2480 } 2481 *fpc++ = FF_END; 2482 2483 arg = fpc - fops; 2484 { /* need to jump to the next word */ 2485 int z; 2486 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN; 2487 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4); 2488 s = SvPVX(sv) + SvCUR(sv) + z; 2489 } 2490 Copy(fops, s, arg, U16); 2491 Safefree(fops); 2492 SvCOMPILED_on(sv); 2493 } 2494