source: trunk/third/perl/pp_ctl.c @ 10724

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