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