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