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