pp_ctl.c

   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 (!SvMAGICAL(form) || !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                 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
 216             else
 217                 PerlIO_printf(PerlIO_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_efullname3(tmpstr, gv, Nullch);
 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 = curstack;
 625             if (!sortstack) {
 626                 sortstack = newAV();
 627                 AvREAL_off(sortstack);
 628                 av_extend(sortstack, 32);
 629             }
 630             SWITCHSTACK(curstack, 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             SV *sv_iv;
 712
 713             i = SvIV(left);
 714             max = SvIV(right);
 715             if (max > i)
 716                 EXTEND(SP, max - i + 1);
 717             sv_iv = sv_2mortal(newSViv(i));
 718             if (i++ <= max) PUSHs(sv_iv);
 719             while (i <= max) {
 720                 sv = sv_mortalcopy(sv_iv);
 721                 sv_setiv(sv,i++);
 722                 PUSHs(sv);
 723             }
 724         }
 725         else {
 726             SV *final = sv_mortalcopy(right);
 727             STRLEN len;
 728             char *tmps = SvPV(final, len);
 729
 730             sv = sv_mortalcopy(left);
 731             while (!SvNIOKp(sv) && SvCUR(sv) <= len &&
 732                 strNE(SvPVX(sv),tmps) ) {
 733                 XPUSHs(sv);
 734                 sv = sv_2mortal(newSVsv(sv));
 735                 sv_inc(sv);
 736             }
 737             if (strEQ(SvPVX(sv),tmps))
 738                 XPUSHs(sv);
 739         }
 740     }
 741     else {
 742         dTOPss;
 743         SV *targ = PAD_SV(cUNOP->op_first->op_targ);
 744         sv_inc(targ);
 745         if ((op->op_private & OPpFLIP_LINENUM)
 746           ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv))
 747           : SvTRUE(sv) ) {
 748             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
 749             sv_catpv(targ, "E0");
 750         }
 751         SETs(targ);
 752     }
 753
 754     RETURN;
 755 }
 756
 757 /* Control. */
 758
 759 static I32
 760 dopoptolabel(label)
 761 char *label;
 762 {
 763     register I32 i;
 764     register CONTEXT *cx;
 765
 766     for (i = cxstack_ix; i >= 0; i--) {
 767         cx = &cxstack[i];
 768         switch (cx->cx_type) {
 769         case CXt_SUBST:
 770             if (dowarn)
 771                 warn("Exiting substitution via %s", op_name[op->op_type]);
 772             break;
 773         case CXt_SUB:
 774             if (dowarn)
 775                 warn("Exiting subroutine via %s", op_name[op->op_type]);
 776             break;
 777         case CXt_EVAL:
 778             if (dowarn)
 779                 warn("Exiting eval via %s", op_name[op->op_type]);
 780             break;
 781         case CXt_LOOP:
 782             if (!cx->blk_loop.label ||
 783               strNE(label, cx->blk_loop.label) ) {
 784                 DEBUG_l(deb("(Skipping label #%d %s)\n",
 785                         i, cx->blk_loop.label));
 786                 continue;
 787             }
 788             DEBUG_l( deb("(Found label #%d %s)\n", i, label));
 789             return i;
 790         }
 791     }
 792     return i;
 793 }
 794
 795 I32
 796 dowantarray()
 797 {
 798     I32 cxix;
 799
 800     cxix = dopoptosub(cxstack_ix);
 801     if (cxix < 0)
 802         return G_SCALAR;
 803
 804     if (cxstack[cxix].blk_gimme == G_ARRAY)
 805         return G_ARRAY;
 806     else
 807         return G_SCALAR;
 808 }
 809
 810 static I32
 811 dopoptosub(startingblock)
 812 I32 startingblock;
 813 {
 814     I32 i;
 815     register CONTEXT *cx;
 816     for (i = startingblock; i >= 0; i--) {
 817         cx = &cxstack[i];
 818         switch (cx->cx_type) {
 819         default:
 820             continue;
 821         case CXt_EVAL:
 822         case CXt_SUB:
 823             DEBUG_l( deb("(Found sub #%d)\n", i));
 824             return i;
 825         }
 826     }
 827     return i;
 828 }
 829
 830 static I32
 831 dopoptoeval(startingblock)
 832 I32 startingblock;
 833 {
 834     I32 i;
 835     register CONTEXT *cx;
 836     for (i = startingblock; i >= 0; i--) {
 837         cx = &cxstack[i];
 838         switch (cx->cx_type) {
 839         default:
 840             continue;
 841         case CXt_EVAL:
 842             DEBUG_l( deb("(Found eval #%d)\n", i));
 843             return i;
 844         }
 845     }
 846     return i;
 847 }
 848
 849 static I32
 850 dopoptoloop(startingblock)
 851 I32 startingblock;
 852 {
 853     I32 i;
 854     register CONTEXT *cx;
 855     for (i = startingblock; i >= 0; i--) {
 856         cx = &cxstack[i];
 857         switch (cx->cx_type) {
 858         case CXt_SUBST:
 859             if (dowarn)
 860                 warn("Exiting substitition via %s", op_name[op->op_type]);
 861             break;
 862         case CXt_SUB:
 863             if (dowarn)
 864                 warn("Exiting subroutine via %s", op_name[op->op_type]);
 865             break;
 866         case CXt_EVAL:
 867             if (dowarn)
 868                 warn("Exiting eval via %s", op_name[op->op_type]);
 869             break;
 870         case CXt_LOOP:
 871             DEBUG_l( deb("(Found loop #%d)\n", i));
 872             return i;
 873         }
 874     }
 875     return i;
 876 }
 877
 878 void
 879 dounwind(cxix)
 880 I32 cxix;
 881 {
 882     register CONTEXT *cx;
 883     SV **newsp;
 884     I32 optype;
 885
 886     while (cxstack_ix > cxix) {
 887         cx = &cxstack[cxstack_ix--];
 888         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
 889                     block_type[cx->cx_type]));
 890         /* Note: we don't need to restore the base context info till the end. */
 891         switch (cx->cx_type) {
 892         case CXt_SUB:
 893             POPSUB(cx);
 894             break;
 895         case CXt_EVAL:
 896             POPEVAL(cx);
 897             break;
 898         case CXt_LOOP:
 899             POPLOOP(cx);
 900             break;
 901         case CXt_SUBST:
 902             break;
 903         }
 904     }
 905 }
 906
 907 #ifdef I_STDARG
 908 OP *
 909 die(char* pat, ...)
 910 #else
 911 /*VARARGS0*/
 912 OP *
 913 die(pat, va_alist)
 914     char *pat;
 915     va_dcl
 916 #endif
 917 {
 918     va_list args;
 919     char *message;
 920     int oldrunlevel = runlevel;
 921     int was_in_eval = in_eval;
 922     HV *stash;
 923     GV *gv;
 924     CV *cv;
 925
 926     /* We have to switch back to mainstack or die_where may try to pop
 927      * the eval block from the wrong stack if die is being called from a
 928      * signal handler.  - dkindred@cs.cmu.edu */
 929     if (curstack != mainstack) {
 930         dSP;
 931         SWITCHSTACK(curstack, mainstack);
 932     }
 933 #ifdef I_STDARG
 934     va_start(args, pat);
 935 #else
 936     va_start(args);
 937 #endif
 938     message = mess(pat, &args);
 939     va_end(args);
 940     if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
 941         dSP;
 942
 943         PUSHMARK(sp);
 944         EXTEND(sp, 1);
 945         PUSHs(sv_2mortal(newSVpv(message,0)));
 946         PUTBACK;
 947         perl_call_sv((SV*)cv, G_DISCARD);
 948     }
 949     restartop = die_where(message);
 950     if ((!restartop && was_in_eval) || oldrunlevel > 1)
 951         Siglongjmp(top_env, 3);
 952     return restartop;
 953 }
 954
 955 OP *
 956 die_where(message)
 957 char *message;
 958 {
 959     if (in_eval) {
 960         I32 cxix;
 961         register CONTEXT *cx;
 962         I32 gimme;
 963         SV **newsp;
 964
 965         if (in_eval & 4) {
 966             SV **svp;
 967             STRLEN klen = strlen(message);
 968
 969             svp = hv_fetch(GvHV(errgv), message, klen, TRUE);
 970             if (svp) {
 971                 if (!SvIOK(*svp)) {
 972                     static char prefix[] = "\t(in cleanup) ";
 973                     sv_upgrade(*svp, SVt_IV);
 974                     (void)SvIOK_only(*svp);
 975                     SvGROW(GvSV(errgv), SvCUR(GvSV(errgv))+sizeof(prefix)+klen);
 976                     sv_catpvn(GvSV(errgv), prefix, sizeof(prefix)-1);
 977                     sv_catpvn(GvSV(errgv), message, klen);
 978                 }
 979                 sv_inc(*svp);
 980             }
 981         }
 982         else
 983             sv_setpv(GvSV(errgv), message);
 984
 985         cxix = dopoptoeval(cxstack_ix);
 986         if (cxix >= 0) {
 987             I32 optype;
 988
 989             if (cxix < cxstack_ix)
 990                 dounwind(cxix);
 991
 992             POPBLOCK(cx,curpm);
 993             if (cx->cx_type != CXt_EVAL) {
 994                 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
 995                 my_exit(1);
 996             }
 997             POPEVAL(cx);
 998
 999             if (gimme == G_SCALAR)
1000                 *++newsp = &sv_undef;
1001             stack_sp = newsp;
1002
1003             LEAVE;
1004
1005             if (optype == OP_REQUIRE)
1006                 DIE("%s", SvPVx(GvSV(errgv), na));
1007             return pop_return();
1008         }
1009     }
1010     PerlIO_printf(PerlIO_stderr(), "%s",message);
1011     PerlIO_flush(PerlIO_stderr());
1012     if (e_tmpname) {
1013         if (e_fp) {
1014             PerlIO_close(e_fp);
1015             e_fp = Nullfp;
1016         }
1017         (void)UNLINK(e_tmpname);
1018         Safefree(e_tmpname);
1019         e_tmpname = Nullch;
1020     }
1021     statusvalue = SHIFTSTATUS(statusvalue);
1022 #ifdef VMS
1023     my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT);
1024 #else
1025     my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
1026 #endif
1027     return 0;
1028 }
1029
1030 PP(pp_xor)
1031 {
1032     dSP; dPOPTOPssrl;
1033     if (SvTRUE(left) != SvTRUE(right))
1034         RETSETYES;
1035     else
1036         RETSETNO;
1037 }
1038
1039 PP(pp_andassign)
1040 {
1041     dSP;
1042     if (!SvTRUE(TOPs))
1043         RETURN;
1044     else
1045         RETURNOP(cLOGOP->op_other);
1046 }
1047
1048 PP(pp_orassign)
1049 {
1050     dSP;
1051     if (SvTRUE(TOPs))
1052         RETURN;
1053     else
1054         RETURNOP(cLOGOP->op_other);
1055 }
1056
1057 #ifdef DEPRECATED
1058 PP(pp_entersubr)
1059 {
1060     dSP;
1061     SV** mark = (stack_base + *markstack_ptr + 1);
1062     SV* cv = *mark;
1063     while (mark < sp) { /* emulate old interface */
1064         *mark = mark[1];
1065         mark++;
1066     }
1067     *sp = cv;
1068     return pp_entersub();
1069 }
1070 #endif
1071
1072 PP(pp_caller)
1073 {
1074     dSP;
1075     register I32 cxix = dopoptosub(cxstack_ix);
1076     register CONTEXT *cx;
1077     I32 dbcxix;
1078     SV *sv;
1079     I32 count = 0;
1080
1081     if (MAXARG)
1082         count = POPi;
1083     EXTEND(SP, 6);
1084     for (;;) {
1085         if (cxix < 0) {
1086             if (GIMME != G_ARRAY)
1087                 RETPUSHUNDEF;
1088             RETURN;
1089         }
1090         if (DBsub && cxix >= 0 &&
1091                 cxstack[cxix].blk_sub.cv == GvCV(DBsub))
1092             count++;
1093         if (!count--)
1094             break;
1095         cxix = dopoptosub(cxix - 1);
1096     }
1097     cx = &cxstack[cxix];
1098     if (cxstack[cxix].cx_type == CXt_SUB) {
1099         dbcxix = dopoptosub(cxix - 1);
1100         /* We expect that cxstack[dbcxix] is CXt_SUB, anyway, the
1101            field below is defined for any cx. */
1102         if (DBsub && dbcxix >= 0 && cxstack[dbcxix].blk_sub.cv == GvCV(DBsub))
1103             cx = &cxstack[dbcxix];
1104     }
1105
1106     if (GIMME != G_ARRAY) {
1107         dTARGET;
1108
1109         sv_setpv(TARG, HvNAME(cx->blk_oldcop->cop_stash));
1110         PUSHs(TARG);
1111         RETURN;
1112     }
1113
1114     PUSHs(sv_2mortal(newSVpv(HvNAME(cx->blk_oldcop->cop_stash), 0)));
1115     PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1116     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1117     if (!MAXARG)
1118         RETURN;
1119     if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
1120         sv = NEWSV(49, 0);
1121         gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch);
1122         PUSHs(sv_2mortal(sv));
1123         PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1124     }
1125     else {
1126         PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1127         PUSHs(sv_2mortal(newSViv(0)));
1128     }
1129     PUSHs(sv_2mortal(newSViv((I32)cx->blk_gimme)));
1130     if (cx->cx_type == CXt_EVAL) {
1131         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1132             PUSHs(cx->blk_eval.cur_text);
1133             PUSHs(&sv_no);
1134         }
1135         else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1136             /* Require, put the name. */
1137             PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1138             PUSHs(&sv_yes);
1139         }
1140     }
1141     else if (cx->cx_type == CXt_SUB &&
1142             cx->blk_sub.hasargs &&
1143             curcop->cop_stash == debstash)
1144     {
1145         AV *ary = cx->blk_sub.argarray;
1146         int off = AvARRAY(ary) - AvALLOC(ary);
1147
1148         if (!dbargs) {
1149             GV* tmpgv;
1150             dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1151                                 SVt_PVAV)));
1152             GvMULTI_on(tmpgv);
1153             AvREAL_off(dbargs);         /* XXX Should be REIFY */
1154         }
1155
1156         if (AvMAX(dbargs) < AvFILL(ary) + off)
1157             av_extend(dbargs, AvFILL(ary) + off);
1158         Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILL(ary) + 1 + off, SV*);
1159         AvFILL(dbargs) = AvFILL(ary) + off;
1160     }
1161     RETURN;
1162 }
1163
1164 static int
1165 sortcv(a, b)
1166 const void *a;
1167 const void *b;
1168 {
1169     SV **str1 = (SV **) a;
1170     SV **str2 = (SV **) b;
1171     I32 oldsaveix = savestack_ix;
1172     I32 oldscopeix = scopestack_ix;
1173     I32 result;
1174     GvSV(firstgv) = *str1;
1175     GvSV(secondgv) = *str2;
1176     stack_sp = stack_base;
1177     op = sortcop;
1178     runops();
1179     if (stack_sp != stack_base + 1)
1180         croak("Sort subroutine didn't return single value");
1181     if (!SvNIOKp(*stack_sp))
1182         croak("Sort subroutine didn't return a numeric value");
1183     result = SvIV(*stack_sp);
1184     while (scopestack_ix > oldscopeix) {
1185         LEAVE;
1186     }
1187     leave_scope(oldsaveix);
1188     return result;
1189 }
1190
1191 static int
1192 sortcmp(a, b)
1193 const void *a;
1194 const void *b;
1195 {
1196     register SV *str1 = *(SV **) a;
1197     register SV *str2 = *(SV **) b;
1198     I32 retval;
1199
1200     if (!SvPOKp(str1)) {
1201         if (!SvPOKp(str2))
1202             return 0;
1203         else
1204             return -1;
1205     }
1206     if (!SvPOKp(str2))
1207         return 1;
1208
1209     if (lc_collate_active) {    /* NOTE: this is the LC_COLLATE branch */
1210       register char * pv1, * pv2, * pvx;
1211       STRLEN cur1, cur2, curx;
1212
1213       pv1 = SvPV(str1, cur1);
1214       pvx = mem_collxfrm(pv1, cur1, &curx);
1215       pv1 = pvx;
1216       cur1 = curx;
1217
1218       pv2 = SvPV(str2, cur2);
1219       pvx = mem_collxfrm(pv2, cur2, &curx);
1220       pv2 = pvx;
1221       cur2 = curx;
1222
1223       retval = memcmp((void *)pv1, (void *)pv2, cur1 < cur2 ? cur1 : cur2);
1224
1225       Safefree(pv1);
1226       Safefree(pv2);
1227
1228       if (retval)
1229         return retval < 0 ? -1 : 1;
1230
1231       if (cur1 == cur2)
1232         return 0;
1233       else
1234         return cur1 < cur2 ? -1 : 1;
1235     }
1236
1237     /* NOTE: this is the non-LC_COLLATE area */
1238
1239     if (SvCUR(str1) < SvCUR(str2)) {
1240         /*SUPPRESS 560*/
1241         if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str1)))
1242             return retval;
1243         else
1244             return -1;
1245     }
1246     /*SUPPRESS 560*/
1247     else if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str2)))
1248         return retval;
1249     else if (SvCUR(str1) == SvCUR(str2))
1250         return 0;
1251     else
1252         return 1;
1253 }
1254
1255 PP(pp_reset)
1256 {
1257     dSP;
1258     char *tmps;
1259
1260     if (MAXARG < 1)
1261         tmps = "";
1262     else
1263         tmps = POPp;
1264     sv_reset(tmps, curcop->cop_stash);
1265     PUSHs(&sv_yes);
1266     RETURN;
1267 }
1268
1269 PP(pp_lineseq)
1270 {
1271     return NORMAL;
1272 }
1273
1274 PP(pp_dbstate)
1275 {
1276     curcop = (COP*)op;
1277     TAINT_NOT;          /* Each statement is presumed innocent */
1278     stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
1279     FREETMPS;
1280
1281     if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace))
1282     {
1283         SV **sp;
1284         register CV *cv;
1285         register CONTEXT *cx;
1286         I32 gimme = G_ARRAY;
1287         I32 hasargs;
1288         GV *gv;
1289
1290         gv = DBgv;
1291         cv = GvCV(gv);
1292         if (!cv)
1293             DIE("No DB::DB routine defined");
1294
1295         if (CvDEPTH(cv) >= 1 && !(debug & (1<<30))) /* don't do recursive DB::DB call */
1296             return NORMAL;
1297
1298         ENTER;
1299         SAVETMPS;
1300
1301         SAVEI32(debug);
1302         SAVESTACK_POS();
1303         debug = 0;
1304         hasargs = 0;
1305         sp = stack_sp;
1306
1307         push_return(op->op_next);
1308         PUSHBLOCK(cx, CXt_SUB, sp);
1309         PUSHSUB(cx);
1310         CvDEPTH(cv)++;
1311         (void)SvREFCNT_inc(cv);
1312         SAVESPTR(curpad);
1313         curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1314         RETURNOP(CvSTART(cv));
1315     }
1316     else
1317         return NORMAL;
1318 }
1319
1320 PP(pp_scope)
1321 {
1322     return NORMAL;
1323 }
1324
1325 PP(pp_enteriter)
1326 {
1327     dSP; dMARK;
1328     register CONTEXT *cx;
1329     I32 gimme = GIMME;
1330     SV **svp;
1331
1332     ENTER;
1333     SAVETMPS;
1334
1335     if (op->op_targ)
1336         svp = &curpad[op->op_targ];             /* "my" variable */
1337     else
1338         svp = &GvSV((GV*)POPs);                 /* symbol table variable */
1339
1340     SAVESPTR(*svp);
1341
1342     ENTER;
1343
1344     PUSHBLOCK(cx, CXt_LOOP, SP);
1345     PUSHLOOP(cx, svp, MARK);
1346     if (op->op_flags & OPf_STACKED) {
1347         AV* av = (AV*)POPs;
1348         cx->blk_loop.iterary = av;
1349         cx->blk_loop.iterix = -1;
1350     }
1351     else {
1352         cx->blk_loop.iterary = curstack;
1353         AvFILL(curstack) = sp - stack_base;
1354         cx->blk_loop.iterix = MARK - stack_base;
1355     }
1356
1357     RETURN;
1358 }
1359
1360 PP(pp_enterloop)
1361 {
1362     dSP;
1363     register CONTEXT *cx;
1364     I32 gimme = GIMME;
1365
1366     ENTER;
1367     SAVETMPS;
1368     ENTER;
1369
1370     PUSHBLOCK(cx, CXt_LOOP, SP);
1371     PUSHLOOP(cx, 0, SP);
1372
1373     RETURN;
1374 }
1375
1376 PP(pp_leaveloop)
1377 {
1378     dSP;
1379     register CONTEXT *cx;
1380     I32 gimme;
1381     SV **newsp;
1382     PMOP *newpm;
1383     SV **mark;
1384
1385     POPBLOCK(cx,newpm);
1386     mark = newsp;
1387     POPLOOP(cx);
1388     if (gimme == G_SCALAR) {
1389         if (op->op_private & OPpLEAVE_VOID)
1390             ;
1391         else {
1392             if (mark < SP)
1393                 *++newsp = sv_mortalcopy(*SP);
1394             else
1395                 *++newsp = &sv_undef;
1396         }
1397     }
1398     else {
1399         while (mark < SP)
1400             *++newsp = sv_mortalcopy(*++mark);
1401     }
1402     curpm = newpm;      /* Don't pop $1 et al till now */
1403     sp = newsp;
1404     LEAVE;
1405     LEAVE;
1406
1407     RETURN;
1408 }
1409
1410 PP(pp_return)
1411 {
1412     dSP; dMARK;
1413     I32 cxix;
1414     register CONTEXT *cx;
1415     I32 gimme;
1416     SV **newsp;
1417     PMOP *newpm;
1418     I32 optype = 0;
1419
1420     if (curstack == sortstack) {
1421         if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) < sortcxix) {
1422             if (cxstack_ix > sortcxix)
1423                 dounwind(sortcxix);
1424             AvARRAY(curstack)[1] = *SP;
1425             stack_sp = stack_base + 1;
1426             return 0;
1427         }
1428     }
1429
1430     cxix = dopoptosub(cxstack_ix);
1431     if (cxix < 0)
1432         DIE("Can't return outside a subroutine");
1433     if (cxix < cxstack_ix)
1434         dounwind(cxix);
1435
1436     POPBLOCK(cx,newpm);
1437     switch (cx->cx_type) {
1438     case CXt_SUB:
1439         POPSUB(cx);
1440         break;
1441     case CXt_EVAL:
1442         POPEVAL(cx);
1443         if (optype == OP_REQUIRE &&
1444             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1445         {
1446             char *name = cx->blk_eval.old_name;
1447             (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
1448             DIE("%s did not return a true value", name);
1449         }
1450         break;
1451     default:
1452         DIE("panic: return");
1453         break;
1454     }
1455
1456     if (gimme == G_SCALAR) {
1457         if (MARK < SP)
1458             *++newsp = sv_mortalcopy(*SP);
1459         else
1460             *++newsp = &sv_undef;
1461     }
1462     else {
1463         while (MARK < SP)
1464             *++newsp = sv_mortalcopy(*++MARK);
1465     }
1466     curpm = newpm;      /* Don't pop $1 et al till now */
1467     stack_sp = newsp;
1468
1469     LEAVE;
1470     return pop_return();
1471 }
1472
1473 PP(pp_last)
1474 {
1475     dSP;
1476     I32 cxix;
1477     register CONTEXT *cx;
1478     I32 gimme;
1479     I32 optype;
1480     OP *nextop;
1481     SV **newsp;
1482     PMOP *newpm;
1483     SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
1484
1485     if (op->op_flags & OPf_SPECIAL) {
1486         cxix = dopoptoloop(cxstack_ix);
1487         if (cxix < 0)
1488             DIE("Can't \"last\" outside a block");
1489     }
1490     else {
1491         cxix = dopoptolabel(cPVOP->op_pv);
1492         if (cxix < 0)
1493             DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1494     }
1495     if (cxix < cxstack_ix)
1496         dounwind(cxix);
1497
1498     POPBLOCK(cx,newpm);
1499     switch (cx->cx_type) {
1500     case CXt_LOOP:
1501         POPLOOP(cx);
1502         nextop = cx->blk_loop.last_op->op_next;
1503         LEAVE;
1504         break;
1505     case CXt_EVAL:
1506         POPEVAL(cx);
1507         nextop = pop_return();
1508         break;
1509     case CXt_SUB:
1510         POPSUB(cx);
1511         nextop = pop_return();
1512         break;
1513     default:
1514         DIE("panic: last");
1515         break;
1516     }
1517
1518     if (gimme == G_SCALAR) {
1519         if (mark < SP)
1520             *++newsp = sv_mortalcopy(*SP);
1521         else
1522             *++newsp = &sv_undef;
1523     }
1524     else {
1525         while (mark < SP)
1526             *++newsp = sv_mortalcopy(*++mark);
1527     }
1528     curpm = newpm;      /* Don't pop $1 et al till now */
1529     sp = newsp;
1530
1531     LEAVE;
1532     RETURNOP(nextop);
1533 }
1534
1535 PP(pp_next)
1536 {
1537     I32 cxix;
1538     register CONTEXT *cx;
1539     I32 oldsave;
1540
1541     if (op->op_flags & OPf_SPECIAL) {
1542         cxix = dopoptoloop(cxstack_ix);
1543         if (cxix < 0)
1544             DIE("Can't \"next\" outside a block");
1545     }
1546     else {
1547         cxix = dopoptolabel(cPVOP->op_pv);
1548         if (cxix < 0)
1549             DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1550     }
1551     if (cxix < cxstack_ix)
1552         dounwind(cxix);
1553
1554     TOPBLOCK(cx);
1555     oldsave = scopestack[scopestack_ix - 1];
1556     LEAVE_SCOPE(oldsave);
1557     return cx->blk_loop.next_op;
1558 }
1559
1560 PP(pp_redo)
1561 {
1562     I32 cxix;
1563     register CONTEXT *cx;
1564     I32 oldsave;
1565
1566     if (op->op_flags & OPf_SPECIAL) {
1567         cxix = dopoptoloop(cxstack_ix);
1568         if (cxix < 0)
1569             DIE("Can't \"redo\" outside a block");
1570     }
1571     else {
1572         cxix = dopoptolabel(cPVOP->op_pv);
1573         if (cxix < 0)
1574             DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1575     }
1576     if (cxix < cxstack_ix)
1577         dounwind(cxix);
1578
1579     TOPBLOCK(cx);
1580     oldsave = scopestack[scopestack_ix - 1];
1581     LEAVE_SCOPE(oldsave);
1582     return cx->blk_loop.redo_op;
1583 }
1584
1585 static OP* lastgotoprobe;
1586
1587 static OP *
1588 dofindlabel(op,label,opstack)
1589 OP *op;
1590 char *label;
1591 OP **opstack;
1592 {
1593     OP *kid;
1594     OP **ops = opstack;
1595
1596     if (op->op_type == OP_LEAVE ||
1597         op->op_type == OP_SCOPE ||
1598         op->op_type == OP_LEAVELOOP ||
1599         op->op_type == OP_LEAVETRY)
1600             *ops++ = cUNOP->op_first;
1601     *ops = 0;
1602     if (op->op_flags & OPf_KIDS) {
1603         /* First try all the kids at this level, since that's likeliest. */
1604         for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
1605             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1606                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
1607                 return kid;
1608         }
1609         for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
1610             if (kid == lastgotoprobe)
1611                 continue;
1612             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1613                 if (ops > opstack &&
1614                   (ops[-1]->op_type == OP_NEXTSTATE ||
1615                    ops[-1]->op_type == OP_DBSTATE))
1616                     *ops = kid;
1617                 else
1618                     *ops++ = kid;
1619             }
1620             if (op = dofindlabel(kid,label,ops))
1621                 return op;
1622         }
1623     }
1624     *ops = 0;
1625     return 0;
1626 }
1627
1628 PP(pp_dump)
1629 {
1630     return pp_goto(ARGS);
1631     /*NOTREACHED*/
1632 }
1633
1634 PP(pp_goto)
1635 {
1636     dSP;
1637     OP *retop = 0;
1638     I32 ix;
1639     register CONTEXT *cx;
1640     OP *enterops[64];
1641     char *label;
1642     int do_dump = (op->op_type == OP_DUMP);
1643
1644     label = 0;
1645     if (op->op_flags & OPf_STACKED) {
1646         SV *sv = POPs;
1647
1648         /* This egregious kludge implements goto &subroutine */
1649         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1650             I32 cxix;
1651             register CONTEXT *cx;
1652             CV* cv = (CV*)SvRV(sv);
1653             SV** mark;
1654             I32 items = 0;
1655             I32 oldsave;
1656
1657             if (!CvROOT(cv) && !CvXSUB(cv)) {
1658                 if (CvGV(cv)) {
1659                     SV *tmpstr = sv_newmortal();
1660                     gv_efullname3(tmpstr, CvGV(cv), Nullch);
1661                     DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1662                 }
1663                 DIE("Goto undefined subroutine");
1664             }
1665
1666             /* First do some returnish stuff. */
1667             cxix = dopoptosub(cxstack_ix);
1668             if (cxix < 0)
1669                 DIE("Can't goto subroutine outside a subroutine");
1670             if (cxix < cxstack_ix)
1671                 dounwind(cxix);
1672             TOPBLOCK(cx);
1673             mark = stack_sp;
1674             if (cx->blk_sub.hasargs) {   /* put @_ back onto stack */
1675                 AV* av = cx->blk_sub.argarray;
1676
1677                 items = AvFILL(av) + 1;
1678                 stack_sp++;
1679                 EXTEND(stack_sp, items); /* @_ could have been extended. */
1680                 Copy(AvARRAY(av), stack_sp, items, SV*);
1681                 stack_sp += items;
1682                 GvAV(defgv) = cx->blk_sub.savearray;
1683                 AvREAL_off(av);
1684                 av_clear(av);
1685             }
1686             if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
1687                 SvREFCNT_dec(cx->blk_sub.cv);
1688             oldsave = scopestack[scopestack_ix - 1];
1689             LEAVE_SCOPE(oldsave);
1690
1691             /* Now do some callish stuff. */
1692             SAVETMPS;
1693             if (CvXSUB(cv)) {
1694                 if (CvOLDSTYLE(cv)) {
1695                     I32 (*fp3)_((int,int,int));
1696                     while (sp > mark) {
1697                         sp[1] = sp[0];
1698                         sp--;
1699                     }
1700                     fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1701                     items = (*fp3)(CvXSUBANY(cv).any_i32,
1702                                    mark - stack_base + 1,
1703                                    items);
1704                     sp = stack_base + items;
1705                 }
1706                 else {
1707                     stack_sp--;         /* There is no cv arg. */
1708                     (void)(*CvXSUB(cv))(cv);
1709                 }
1710                 LEAVE;
1711                 return pop_return();
1712             }
1713             else {
1714                 AV* padlist = CvPADLIST(cv);
1715                 SV** svp = AvARRAY(padlist);
1716                 cx->blk_sub.cv = cv;
1717                 cx->blk_sub.olddepth = CvDEPTH(cv);
1718                 CvDEPTH(cv)++;
1719                 if (CvDEPTH(cv) < 2)
1720                     (void)SvREFCNT_inc(cv);
1721                 else {  /* save temporaries on recursion? */
1722                     if (CvDEPTH(cv) == 100 && dowarn)
1723                         warn("Deep recursion on subroutine \"%s\"",
1724                             GvENAME(CvGV(cv)));
1725                     if (CvDEPTH(cv) > AvFILL(padlist)) {
1726                         AV *newpad = newAV();
1727                         SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1728                         I32 ix = AvFILL((AV*)svp[1]);
1729                         svp = AvARRAY(svp[0]);
1730                         for ( ;ix > 0; ix--) {
1731                             if (svp[ix] != &sv_undef) {
1732                                 char *name = SvPVX(svp[ix]);
1733                                 if (SvFLAGS(svp[ix]) & SVf_FAKE) {
1734                                     /* outer lexical? */
1735                                     av_store(newpad, ix,
1736                                         SvREFCNT_inc(oldpad[ix]) );
1737                                 }
1738                                 else {          /* our own lexical */
1739                                     if (*name == '@')
1740                                         av_store(newpad, ix, sv = (SV*)newAV());
1741                                     else if (*name == '%')
1742                                         av_store(newpad, ix, sv = (SV*)newHV());
1743                                     else
1744                                         av_store(newpad, ix, sv = NEWSV(0,0));
1745                                     SvPADMY_on(sv);
1746                                 }
1747                             }
1748                             else {
1749                                 av_store(newpad, ix, sv = NEWSV(0,0));
1750                                 SvPADTMP_on(sv);
1751                             }
1752                         }
1753                         if (cx->blk_sub.hasargs) {
1754                             AV* av = newAV();
1755                             av_extend(av, 0);
1756                             av_store(newpad, 0, (SV*)av);
1757                             AvFLAGS(av) = AVf_REIFY;
1758                         }
1759                         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1760                         AvFILL(padlist) = CvDEPTH(cv);
1761                         svp = AvARRAY(padlist);
1762                     }
1763                 }
1764                 SAVESPTR(curpad);
1765                 curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1766                 if (cx->blk_sub.hasargs) {
1767                     AV* av = (AV*)curpad[0];
1768                     SV** ary;
1769
1770                     cx->blk_sub.savearray = GvAV(defgv);
1771                     cx->blk_sub.argarray = av;
1772                     GvAV(defgv) = cx->blk_sub.argarray;
1773                     ++mark;
1774
1775                     if (items >= AvMAX(av) + 1) {
1776                         ary = AvALLOC(av);
1777                         if (AvARRAY(av) != ary) {
1778                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1779                             SvPVX(av) = (char*)ary;
1780                         }
1781                         if (items >= AvMAX(av) + 1) {
1782                             AvMAX(av) = items - 1;
1783                             Renew(ary,items+1,SV*);
1784                             AvALLOC(av) = ary;
1785                             SvPVX(av) = (char*)ary;
1786                         }
1787                     }
1788                     Copy(mark,AvARRAY(av),items,SV*);
1789                     AvFILL(av) = items - 1;
1790
1791                     while (items--) {
1792                         if (*mark)
1793                             SvTEMP_off(*mark);
1794                         mark++;
1795                     }
1796                 }
1797                 if (perldb && curstash != debstash) {
1798                     /* &xsub is not copying @_ */
1799                     SV *sv = GvSV(DBsub);
1800                     save_item(sv);
1801                     gv_efullname3(sv, CvGV(cv), Nullch);
1802                     /* We do not care about using sv to call CV,
1803                      * just for info. */
1804                 }
1805                 RETURNOP(CvSTART(cv));
1806             }
1807         }
1808         else
1809             label = SvPV(sv,na);
1810     }
1811     else if (op->op_flags & OPf_SPECIAL) {
1812         if (! do_dump)
1813             DIE("goto must have label");
1814     }
1815     else
1816         label = cPVOP->op_pv;
1817
1818     if (label && *label) {
1819         OP *gotoprobe = 0;
1820
1821         /* find label */
1822
1823         lastgotoprobe = 0;
1824         *enterops = 0;
1825         for (ix = cxstack_ix; ix >= 0; ix--) {
1826             cx = &cxstack[ix];
1827             switch (cx->cx_type) {
1828             case CXt_SUB:
1829                 gotoprobe = CvROOT(cx->blk_sub.cv);
1830                 break;
1831             case CXt_EVAL:
1832                 gotoprobe = eval_root; /* XXX not good for nested eval */
1833                 break;
1834             case CXt_LOOP:
1835                 gotoprobe = cx->blk_oldcop->op_sibling;
1836                 break;
1837             case CXt_SUBST:
1838                 continue;
1839             case CXt_BLOCK:
1840                 if (ix)
1841                     gotoprobe = cx->blk_oldcop->op_sibling;
1842                 else
1843                     gotoprobe = main_root;
1844                 break;
1845             default:
1846                 if (ix)
1847                     DIE("panic: goto");
1848                 else
1849                     gotoprobe = main_root;
1850                 break;
1851             }
1852             retop = dofindlabel(gotoprobe, label, enterops);
1853             if (retop)
1854                 break;
1855             lastgotoprobe = gotoprobe;
1856         }
1857         if (!retop)
1858             DIE("Can't find label %s", label);
1859
1860         /* pop unwanted frames */
1861
1862         if (ix < cxstack_ix) {
1863             I32 oldsave;
1864
1865             if (ix < 0)
1866                 ix = 0;
1867             dounwind(ix);
1868             TOPBLOCK(cx);
1869             oldsave = scopestack[scopestack_ix];
1870             LEAVE_SCOPE(oldsave);
1871         }
1872
1873         /* push wanted frames */
1874
1875         if (*enterops && enterops[1]) {
1876             OP *oldop = op;
1877             for (ix = 1; enterops[ix]; ix++) {
1878                 op = enterops[ix];
1879                 (*op->op_ppaddr)();
1880             }
1881             op = oldop;
1882         }
1883     }
1884
1885     if (do_dump) {
1886 #ifdef VMS
1887         if (!retop) retop = main_start;
1888 #endif
1889         restartop = retop;
1890         do_undump = TRUE;
1891
1892         my_unexec();
1893
1894         restartop = 0;          /* hmm, must be GNU unexec().. */
1895         do_undump = FALSE;
1896     }
1897
1898     if (curstack == signalstack) {
1899         restartop = retop;
1900         Siglongjmp(top_env, 3);
1901     }
1902
1903     RETURNOP(retop);
1904 }
1905
1906 PP(pp_exit)
1907 {
1908     dSP;
1909     I32 anum;
1910
1911     if (MAXARG < 1)
1912         anum = 0;
1913     else
1914         anum = SvIVx(POPs);
1915     my_exit(anum);
1916     PUSHs(&sv_undef);
1917     RETURN;
1918 }
1919
1920 #ifdef NOTYET
1921 PP(pp_nswitch)
1922 {
1923     dSP;
1924     double value = SvNVx(GvSV(cCOP->cop_gv));
1925     register I32 match = I_32(value);
1926
1927     if (value < 0.0) {
1928         if (((double)match) > value)
1929             --match;            /* was fractional--truncate other way */
1930     }
1931     match -= cCOP->uop.scop.scop_offset;
1932     if (match < 0)
1933         match = 0;
1934     else if (match > cCOP->uop.scop.scop_max)
1935         match = cCOP->uop.scop.scop_max;
1936     op = cCOP->uop.scop.scop_next[match];
1937     RETURNOP(op);
1938 }
1939
1940 PP(pp_cswitch)
1941 {
1942     dSP;
1943     register I32 match;
1944
1945     if (multiline)
1946         op = op->op_next;                       /* can't assume anything */
1947     else {
1948         match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255;
1949         match -= cCOP->uop.scop.scop_offset;
1950         if (match < 0)
1951             match = 0;
1952         else if (match > cCOP->uop.scop.scop_max)
1953             match = cCOP->uop.scop.scop_max;
1954         op = cCOP->uop.scop.scop_next[match];
1955     }
1956     RETURNOP(op);
1957 }
1958 #endif
1959
1960 /* Eval. */
1961
1962 static void
1963 save_lines(array, sv)
1964 AV *array;
1965 SV *sv;
1966 {
1967     register char *s = SvPVX(sv);
1968     register char *send = SvPVX(sv) + SvCUR(sv);
1969     register char *t;
1970     register I32 line = 1;
1971
1972     while (s && s < send) {
1973         SV *tmpstr = NEWSV(85,0);
1974
1975         sv_upgrade(tmpstr, SVt_PVMG);
1976         t = strchr(s, '\n');
1977         if (t)
1978             t++;
1979         else
1980             t = send;
1981
1982         sv_setpvn(tmpstr, s, t - s);
1983         av_store(array, line++, tmpstr);
1984         s = t;
1985     }
1986 }
1987
1988 static OP *
1989 doeval(gimme)
1990 int gimme;
1991 {
1992     dSP;
1993     OP *saveop = op;
1994     HV *newstash;
1995     AV* comppadlist;
1996
1997     in_eval = 1;
1998
1999     PUSHMARK(SP);
2000
2001     /* set up a scratch pad */
2002
2003     SAVEI32(padix);
2004     SAVESPTR(curpad);
2005     SAVESPTR(comppad);
2006     SAVESPTR(comppad_name);
2007     SAVEI32(comppad_name_fill);
2008     SAVEI32(min_intro_pending);
2009     SAVEI32(max_intro_pending);
2010
2011     SAVESPTR(compcv);
2012     compcv = (CV*)NEWSV(1104,0);
2013     sv_upgrade((SV *)compcv, SVt_PVCV);
2014
2015     comppad = newAV();
2016     comppad_name = newAV();
2017     comppad_name_fill = 0;
2018     min_intro_pending = 0;
2019     av_push(comppad, Nullsv);
2020     curpad = AvARRAY(comppad);
2021     padix = 0;
2022
2023     comppadlist = newAV();
2024     AvREAL_off(comppadlist);
2025     av_store(comppadlist, 0, (SV*)comppad_name);
2026     av_store(comppadlist, 1, (SV*)comppad);
2027     CvPADLIST(compcv) = comppadlist;
2028     SAVEFREESV(compcv);
2029
2030     /* make sure we compile in the right package */
2031
2032     newstash = curcop->cop_stash;
2033     if (curstash != newstash) {
2034         SAVESPTR(curstash);
2035         curstash = newstash;
2036     }
2037     SAVESPTR(beginav);
2038     beginav = newAV();
2039     SAVEFREESV(beginav);
2040
2041     /* try to compile it */
2042
2043     eval_root = Nullop;
2044     error_count = 0;
2045     curcop = &compiling;
2046     curcop->cop_arybase = 0;
2047     SvREFCNT_dec(rs);
2048     rs = newSVpv("\n", 1);
2049     if (saveop->op_flags & OPf_SPECIAL)
2050         in_eval |= 4;
2051     else
2052         sv_setpv(GvSV(errgv),"");
2053     if (yyparse() || error_count || !eval_root) {
2054         SV **newsp;
2055         I32 gimme;
2056         CONTEXT *cx;
2057         I32 optype;
2058
2059         op = saveop;
2060         if (eval_root) {
2061             op_free(eval_root);
2062             eval_root = Nullop;
2063         }
2064         SP = stack_base + POPMARK;              /* pop original mark */
2065         POPBLOCK(cx,curpm);
2066         POPEVAL(cx);
2067         pop_return();
2068         lex_end();
2069         LEAVE;
2070         if (optype == OP_REQUIRE)
2071             DIE("%s", SvPVx(GvSV(errgv), na));
2072         SvREFCNT_dec(rs);
2073         rs = SvREFCNT_inc(nrs);
2074         RETPUSHUNDEF;
2075     }
2076     SvREFCNT_dec(rs);
2077     rs = SvREFCNT_inc(nrs);
2078     compiling.cop_line = 0;
2079     SAVEFREEOP(eval_root);
2080     if (gimme & G_ARRAY)
2081         list(eval_root);
2082     else
2083         scalar(eval_root);
2084
2085     DEBUG_x(dump_eval());
2086
2087     /* Register with debugger: */
2088
2089     if (perldb && saveop->op_type == OP_REQUIRE) {
2090         CV *cv = perl_get_cv("DB::postponed", FALSE);
2091
2092         if (cv) {
2093             dSP;
2094             PUSHMARK(sp);
2095             XPUSHs((SV*)compiling.cop_filegv);
2096             PUTBACK;
2097             perl_call_sv((SV*)cv, G_DISCARD);
2098         }
2099     }
2100
2101     /* compiled okay, so do it */
2102
2103     SP = stack_base + POPMARK;          /* pop original mark */
2104     RETURNOP(eval_start);
2105 }
2106
2107 PP(pp_require)
2108 {
2109     dSP;
2110     register CONTEXT *cx;
2111     SV *sv;
2112     char *name;
2113     char *tmpname;
2114     SV** svp;
2115     I32 gimme = G_SCALAR;
2116     PerlIO *tryrsfp = 0;
2117
2118     sv = POPs;
2119     if (SvNIOKp(sv) && !SvPOKp(sv)) {
2120         if (atof(patchlevel) + 0.00000999 < SvNV(sv))
2121             DIE("Perl %s required--this is only version %s, stopped",
2122                 SvPV(sv,na),patchlevel);
2123         RETPUSHYES;
2124     }
2125     name = SvPV(sv, na);
2126     if (!*name)
2127         DIE("Null filename used");
2128     TAINT_PROPER("require");
2129     if (op->op_type == OP_REQUIRE &&
2130       (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) &&
2131       *svp != &sv_undef)
2132         RETPUSHYES;
2133
2134     /* prepare to compile file */
2135
2136     tmpname = savepv(name);
2137     if (*tmpname == '/' ||
2138         (*tmpname == '.' &&
2139             (tmpname[1] == '/' ||
2140              (tmpname[1] == '.' && tmpname[2] == '/')))
2141 #ifdef DOSISH
2142       || (tmpname[0] && tmpname[1] == ':')
2143 #endif
2144 #ifdef VMS
2145         || (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') &&
2146             (tmpname[1] == '-' || tmpname[1] == ']' || tmpname[1] == '>')))
2147 #endif
2148     )
2149     {
2150         tryrsfp = PerlIO_open(tmpname,"r");
2151     }
2152     else {
2153         AV *ar = GvAVn(incgv);
2154         I32 i;
2155
2156         for (i = 0; i <= AvFILL(ar); i++) {
2157 #ifdef VMS
2158             if (tounixpath_ts(SvPVx(*av_fetch(ar, i, TRUE), na),buf) == NULL)
2159                 continue;
2160             strcat(buf,name);
2161 #else
2162             (void)sprintf(buf, "%s/%s",
2163                 SvPVx(*av_fetch(ar, i, TRUE), na), name);
2164 #endif
2165             tryrsfp = PerlIO_open(buf, "r");
2166             if (tryrsfp) {
2167                 char *s = buf;
2168
2169                 if (*s == '.' && s[1] == '/')
2170                     s += 2;
2171                 Safefree(tmpname);
2172                 tmpname = savepv(s);
2173                 break;
2174             }
2175         }
2176     }
2177     SAVESPTR(compiling.cop_filegv);
2178     compiling.cop_filegv = gv_fetchfile(tmpname);
2179     Safefree(tmpname);
2180     tmpname = Nullch;
2181     if (!tryrsfp) {
2182         if (op->op_type == OP_REQUIRE) {
2183             sprintf(tokenbuf,"Can't locate %s in @INC", name);
2184             if (instr(tokenbuf,".h "))
2185                 strcat(tokenbuf," (change .h to .ph maybe?)");
2186             if (instr(tokenbuf,".ph "))
2187                 strcat(tokenbuf," (did you run h2ph?)");
2188             DIE("%s",tokenbuf);
2189         }
2190
2191         RETPUSHUNDEF;
2192     }
2193
2194     /* Assume success here to prevent recursive requirement. */
2195     (void)hv_store(GvHVn(incgv), name, strlen(name),
2196         newSVsv(GvSV(compiling.cop_filegv)), 0 );
2197
2198     ENTER;
2199     SAVETMPS;
2200     lex_start(sv_2mortal(newSVpv("",0)));
2201     if (rsfp_filters){
2202         save_aptr(&rsfp_filters);
2203         rsfp_filters = NULL;
2204     }
2205
2206     rsfp = tryrsfp;
2207     name = savepv(name);
2208     SAVEFREEPV(name);
2209     SAVEI32(hints);
2210     hints = 0;
2211
2212     /* switch to eval mode */
2213
2214     push_return(op->op_next);
2215     PUSHBLOCK(cx, CXt_EVAL, SP);
2216     PUSHEVAL(cx, name, compiling.cop_filegv);
2217
2218     compiling.cop_line = 0;
2219
2220     PUTBACK;
2221     return doeval(G_SCALAR);
2222 }
2223
2224 PP(pp_dofile)
2225 {
2226     return pp_require(ARGS);
2227 }
2228
2229 PP(pp_entereval)
2230 {
2231     dSP;
2232     register CONTEXT *cx;
2233     dPOPss;
2234     I32 gimme = GIMME, was = sub_generation;
2235     char tmpbuf[32], *safestr;
2236     STRLEN len;
2237     OP *ret;
2238
2239     if (!SvPV(sv,len) || !len)
2240         RETPUSHUNDEF;
2241     TAINT_PROPER("eval");
2242
2243     ENTER;
2244     lex_start(sv);
2245     SAVETMPS;
2246
2247     /* switch to eval mode */
2248
2249     SAVESPTR(compiling.cop_filegv);
2250     sprintf(tmpbuf, "_<(eval %d)", ++evalseq);
2251     compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2252     compiling.cop_line = 1;
2253     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2254        deleting the eval's FILEGV from the stash before gv_check() runs
2255        (i.e. before run-time proper). To work around the coredump that
2256        ensues, we always turn GvMULTI_on for any globals that were
2257        introduced within evals. See force_ident(). GSAR 96-10-12 */
2258     safestr = savepv(tmpbuf);
2259     SAVEDELETE(defstash, safestr, strlen(safestr));
2260     SAVEI32(hints);
2261     hints = op->op_targ;
2262
2263     push_return(op->op_next);
2264     PUSHBLOCK(cx, CXt_EVAL, SP);
2265     PUSHEVAL(cx, 0, compiling.cop_filegv);
2266
2267     /* prepare to compile string */
2268
2269     if (perldb && curstash != debstash)
2270         save_lines(GvAV(compiling.cop_filegv), linestr);
2271     PUTBACK;
2272     ret = doeval(gimme);
2273     if (perldb && was != sub_generation) { /* Some subs defined here. */
2274         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
2275     }
2276     return ret;
2277 }
2278
2279 PP(pp_leaveeval)
2280 {
2281     dSP;
2282     register SV **mark;
2283     SV **newsp;
2284     PMOP *newpm;
2285     I32 gimme;
2286     register CONTEXT *cx;
2287     OP *retop;
2288     U8 save_flags = op -> op_flags;
2289     I32 optype;
2290
2291     POPBLOCK(cx,newpm);
2292     POPEVAL(cx);
2293     retop = pop_return();
2294
2295     if (gimme == G_SCALAR) {
2296         if (op->op_private & OPpLEAVE_VOID)
2297             MARK = newsp;
2298         else {
2299             MARK = newsp + 1;
2300             if (MARK <= SP) {
2301                 if (SvFLAGS(TOPs) & SVs_TEMP)
2302                     *MARK = TOPs;
2303                 else
2304                     *MARK = sv_mortalcopy(TOPs);
2305             }
2306             else {
2307                 MEXTEND(mark,0);
2308                 *MARK = &sv_undef;
2309             }
2310         }
2311         SP = MARK;
2312     }
2313     else {
2314         for (mark = newsp + 1; mark <= SP; mark++)
2315             if (!(SvFLAGS(*mark) & SVs_TEMP))
2316                 *mark = sv_mortalcopy(*mark);
2317                 /* in case LEAVE wipes old return values */
2318     }
2319     curpm = newpm;      /* Don't pop $1 et al till now */
2320
2321     if (optype == OP_REQUIRE &&
2322         !(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) {
2323         char *name = cx->blk_eval.old_name;
2324
2325         /* Unassume the success we assumed earlier. */
2326         (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
2327         retop = die("%s did not return a true value", name);
2328     }
2329
2330     lex_end();
2331     LEAVE;
2332     if (!(save_flags & OPf_SPECIAL))
2333         sv_setpv(GvSV(errgv),"");
2334
2335     RETURNOP(retop);
2336 }
2337
2338 PP(pp_entertry)
2339 {
2340     dSP;
2341     register CONTEXT *cx;
2342     I32 gimme = GIMME;
2343
2344     ENTER;
2345     SAVETMPS;
2346
2347     push_return(cLOGOP->op_other->op_next);
2348     PUSHBLOCK(cx, CXt_EVAL, SP);
2349     PUSHEVAL(cx, 0, 0);
2350     eval_root = op;             /* Only needed so that goto works right. */
2351
2352     in_eval = 1;
2353     sv_setpv(GvSV(errgv),"");
2354     RETURN;
2355 }
2356
2357 PP(pp_leavetry)
2358 {
2359     dSP;
2360     register SV **mark;
2361     SV **newsp;
2362     PMOP *newpm;
2363     I32 gimme;
2364     register CONTEXT *cx;
2365     I32 optype;
2366
2367     POPBLOCK(cx,newpm);
2368     POPEVAL(cx);
2369     pop_return();
2370
2371     if (gimme == G_SCALAR) {
2372         if (op->op_private & OPpLEAVE_VOID)
2373             MARK = newsp;
2374         else {
2375             MARK = newsp + 1;
2376             if (MARK <= SP) {
2377                 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2378                     *MARK = TOPs;
2379                 else
2380                     *MARK = sv_mortalcopy(TOPs);
2381             }
2382             else {
2383                 MEXTEND(mark,0);
2384                 *MARK = &sv_undef;
2385             }
2386         }
2387         SP = MARK;
2388     }
2389     else {
2390         for (mark = newsp + 1; mark <= SP; mark++)
2391             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP)))
2392                 *mark = sv_mortalcopy(*mark);
2393                 /* in case LEAVE wipes old return values */
2394     }
2395     curpm = newpm;      /* Don't pop $1 et al till now */
2396
2397     LEAVE;
2398     sv_setpv(GvSV(errgv),"");
2399     RETURN;
2400 }
2401
2402 static void
2403 doparseform(sv)
2404 SV *sv;
2405 {
2406     STRLEN len;
2407     register char *s = SvPV_force(sv, len);
2408     register char *send = s + len;
2409     register char *base;
2410     register I32 skipspaces = 0;
2411     bool noblank;
2412     bool repeat;
2413     bool postspace = FALSE;
2414     U16 *fops;
2415     register U16 *fpc;
2416     U16 *linepc;
2417     register I32 arg;
2418     bool ischop;
2419
2420     if (len == 0)
2421         die("Null picture in formline");
2422
2423     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
2424     fpc = fops;
2425
2426     if (s < send) {
2427         linepc = fpc;
2428         *fpc++ = FF_LINEMARK;
2429         noblank = repeat = FALSE;
2430         base = s;
2431     }
2432
2433     while (s <= send) {
2434         switch (*s++) {
2435         default:
2436             skipspaces = 0;
2437             continue;
2438
2439         case '~':
2440             if (*s == '~') {
2441                 repeat = TRUE;
2442                 *s = ' ';
2443             }
2444             noblank = TRUE;
2445             s[-1] = ' ';
2446             /* FALL THROUGH */
2447         case ' ': case '\t':
2448             skipspaces++;
2449             continue;
2450
2451         case '\n': case 0:
2452             arg = s - base;
2453             skipspaces++;
2454             arg -= skipspaces;
2455             if (arg) {
2456                 if (postspace) {
2457                     *fpc++ = FF_SPACE;
2458                     postspace = FALSE;
2459                 }
2460                 *fpc++ = FF_LITERAL;
2461                 *fpc++ = arg;
2462             }
2463             if (s <= send)
2464                 skipspaces--;
2465             if (skipspaces) {
2466                 *fpc++ = FF_SKIP;
2467                 *fpc++ = skipspaces;
2468             }
2469             skipspaces = 0;
2470             if (s <= send)
2471                 *fpc++ = FF_NEWLINE;
2472             if (noblank) {
2473                 *fpc++ = FF_BLANK;
2474                 if (repeat)
2475                     arg = fpc - linepc + 1;
2476                 else
2477                     arg = 0;
2478                 *fpc++ = arg;
2479             }
2480             if (s < send) {
2481                 linepc = fpc;
2482                 *fpc++ = FF_LINEMARK;
2483                 noblank = repeat = FALSE;
2484                 base = s;
2485             }
2486             else
2487                 s++;
2488             continue;
2489
2490         case '@':
2491         case '^':
2492             ischop = s[-1] == '^';
2493
2494             if (postspace) {
2495                 *fpc++ = FF_SPACE;
2496                 postspace = FALSE;
2497             }
2498             arg = (s - base) - 1;
2499             if (arg) {
2500                 *fpc++ = FF_LITERAL;
2501                 *fpc++ = arg;
2502             }
2503
2504             base = s - 1;
2505             *fpc++ = FF_FETCH;
2506             if (*s == '*') {
2507                 s++;
2508                 *fpc++ = 0;
2509                 *fpc++ = FF_LINEGLOB;
2510             }
2511             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2512                 arg = ischop ? 512 : 0;
2513                 base = s - 1;
2514                 while (*s == '#')
2515                     s++;
2516                 if (*s == '.') {
2517                     char *f;
2518                     s++;
2519                     f = s;
2520                     while (*s == '#')
2521                         s++;
2522                     arg |= 256 + (s - f);
2523                 }
2524                 *fpc++ = s - base;              /* fieldsize for FETCH */
2525                 *fpc++ = FF_DECIMAL;
2526                 *fpc++ = arg;
2527             }
2528             else {
2529                 I32 prespace = 0;
2530                 bool ismore = FALSE;
2531
2532                 if (*s == '>') {
2533                     while (*++s == '>') ;
2534                     prespace = FF_SPACE;
2535                 }
2536                 else if (*s == '|') {
2537                     while (*++s == '|') ;
2538                     prespace = FF_HALFSPACE;
2539                     postspace = TRUE;
2540                 }
2541                 else {
2542                     if (*s == '<')
2543                         while (*++s == '<') ;
2544                     postspace = TRUE;
2545                 }
2546                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2547                     s += 3;
2548                     ismore = TRUE;
2549                 }
2550                 *fpc++ = s - base;              /* fieldsize for FETCH */
2551
2552                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
2553
2554                 if (prespace)
2555                     *fpc++ = prespace;
2556                 *fpc++ = FF_ITEM;
2557                 if (ismore)
2558                     *fpc++ = FF_MORE;
2559                 if (ischop)
2560                     *fpc++ = FF_CHOP;
2561             }
2562             base = s;
2563             skipspaces = 0;
2564             continue;
2565         }
2566     }
2567     *fpc++ = FF_END;
2568
2569     arg = fpc - fops;
2570     { /* need to jump to the next word */
2571         int z;
2572         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
2573         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
2574         s = SvPVX(sv) + SvCUR(sv) + z;
2575     }
2576     Copy(fops, s, arg, U16);
2577     Safefree(fops);
2578     sv_magic(sv, Nullsv, 'f', Nullch, 0);
2579     SvCOMPILED_on(sv);
2580 }