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

Revision 17035, 115.2 KB checked in by zacheiss, 23 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r17034, which included commits to RCS files with non-trunk default branches.
Line 
1/*    pp_ctl.c
2 *
3 *    Copyright (c) 1991-2001, 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#define PERL_IN_PP_CTL_C
21#include "perl.h"
22
23#ifndef WORD_ALIGN
24#define WORD_ALIGN sizeof(U16)
25#endif
26
27#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
28
29static I32 sortcv(pTHXo_ SV *a, SV *b);
30static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
31static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
32static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
33static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
34static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
35static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b);
36static I32 amagic_cmp(pTHXo_ SV *a, SV *b);
37static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b);
38static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen);
39
40#ifdef PERL_OBJECT
41static I32 sv_cmp_static(pTHXo_ SV *a, SV *b);
42static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b);
43#else
44#define sv_cmp_static Perl_sv_cmp
45#define sv_cmp_locale_static Perl_sv_cmp_locale
46#endif
47
48PP(pp_wantarray)
49{
50    dSP;
51    I32 cxix;
52    EXTEND(SP, 1);
53
54    cxix = dopoptosub(cxstack_ix);
55    if (cxix < 0)
56        RETPUSHUNDEF;
57
58    switch (cxstack[cxix].blk_gimme) {
59    case G_ARRAY:
60        RETPUSHYES;
61    case G_SCALAR:
62        RETPUSHNO;
63    default:
64        RETPUSHUNDEF;
65    }
66}
67
68PP(pp_regcmaybe)
69{
70    return NORMAL;
71}
72
73PP(pp_regcreset)
74{
75    /* XXXX Should store the old value to allow for tie/overload - and
76       restore in regcomp, where marked with XXXX. */
77    PL_reginterp_cnt = 0;
78    return NORMAL;
79}
80
81PP(pp_regcomp)
82{
83    dSP;
84    register PMOP *pm = (PMOP*)cLOGOP->op_other;
85    register char *t;
86    SV *tmpstr;
87    STRLEN len;
88    MAGIC *mg = Null(MAGIC*);
89
90    tmpstr = POPs;
91    if (SvROK(tmpstr)) {
92        SV *sv = SvRV(tmpstr);
93        if(SvMAGICAL(sv))
94            mg = mg_find(sv, 'r');
95    }
96    if (mg) {
97        regexp *re = (regexp *)mg->mg_obj;
98        ReREFCNT_dec(pm->op_pmregexp);
99        pm->op_pmregexp = ReREFCNT_inc(re);
100    }
101    else {
102        t = SvPV(tmpstr, len);
103
104        /* Check against the last compiled regexp. */
105        if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
106            pm->op_pmregexp->prelen != len ||
107            memNE(pm->op_pmregexp->precomp, t, len))
108        {
109            if (pm->op_pmregexp) {
110                ReREFCNT_dec(pm->op_pmregexp);
111                pm->op_pmregexp = Null(REGEXP*);        /* crucial if regcomp aborts */
112            }
113            if (PL_op->op_flags & OPf_SPECIAL)
114                PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
115
116            pm->op_pmflags = pm->op_pmpermflags;        /* reset case sensitivity */
117            if (DO_UTF8(tmpstr))
118                pm->op_pmdynflags |= PMdf_UTF8;
119            pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
120            PL_reginterp_cnt = 0;               /* XXXX Be extra paranoid - needed
121                                           inside tie/overload accessors.  */
122        }
123    }
124
125#ifndef INCOMPLETE_TAINTS
126    if (PL_tainting) {
127        if (PL_tainted)
128            pm->op_pmdynflags |= PMdf_TAINTED;
129        else
130            pm->op_pmdynflags &= ~PMdf_TAINTED;
131    }
132#endif
133
134    if (!pm->op_pmregexp->prelen && PL_curpm)
135        pm = PL_curpm;
136    else if (strEQ("\\s+", pm->op_pmregexp->precomp))
137        pm->op_pmflags |= PMf_WHITE;
138
139    /* XXX runtime compiled output needs to move to the pad */
140    if (pm->op_pmflags & PMf_KEEP) {
141        pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
142#if !defined(USE_ITHREADS) && !defined(USE_THREADS)
143        /* XXX can't change the optree at runtime either */
144        cLOGOP->op_first->op_next = PL_op->op_next;
145#endif
146    }
147    RETURN;
148}
149
150PP(pp_substcont)
151{
152    dSP;
153    register PMOP *pm = (PMOP*) cLOGOP->op_other;
154    register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
155    register SV *dstr = cx->sb_dstr;
156    register char *s = cx->sb_s;
157    register char *m = cx->sb_m;
158    char *orig = cx->sb_orig;
159    register REGEXP *rx = cx->sb_rx;
160
161    rxres_restore(&cx->sb_rxres, rx);
162
163    if (cx->sb_iters++) {
164        if (cx->sb_iters > cx->sb_maxiters)
165            DIE(aTHX_ "Substitution loop");
166
167        if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
168            cx->sb_rxtainted |= 2;
169        sv_catsv(dstr, POPs);
170
171        /* Are we done */
172        if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
173                                     s == m, cx->sb_targ, NULL,
174                                     ((cx->sb_rflags & REXEC_COPY_STR)
175                                      ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
176                                      : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
177        {
178            SV *targ = cx->sb_targ;
179            bool isutf8;
180
181            sv_catpvn(dstr, s, cx->sb_strend - s);
182            cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
183
184            (void)SvOOK_off(targ);
185            Safefree(SvPVX(targ));
186            SvPVX(targ) = SvPVX(dstr);
187            SvCUR_set(targ, SvCUR(dstr));
188            SvLEN_set(targ, SvLEN(dstr));
189            isutf8 = DO_UTF8(dstr);
190            SvPVX(dstr) = 0;
191            sv_free(dstr);
192
193            TAINT_IF(cx->sb_rxtainted & 1);
194            PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
195
196            (void)SvPOK_only(targ);
197            if (isutf8)
198                SvUTF8_on(targ);
199            TAINT_IF(cx->sb_rxtainted);
200            SvSETMAGIC(targ);
201            SvTAINT(targ);
202
203            LEAVE_SCOPE(cx->sb_oldsave);
204            POPSUBST(cx);
205            RETURNOP(pm->op_next);
206        }
207    }
208    if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
209        m = s;
210        s = orig;
211        cx->sb_orig = orig = rx->subbeg;
212        s = orig + (m - s);
213        cx->sb_strend = s + (cx->sb_strend - m);
214    }
215    cx->sb_m = m = rx->startp[0] + orig;
216    sv_catpvn(dstr, s, m-s);
217    cx->sb_s = rx->endp[0] + orig;
218    { /* Update the pos() information. */
219        SV *sv = cx->sb_targ;
220        MAGIC *mg;
221        I32 i;
222        if (SvTYPE(sv) < SVt_PVMG)
223            SvUPGRADE(sv, SVt_PVMG);
224        if (!(mg = mg_find(sv, 'g'))) {
225            sv_magic(sv, Nullsv, 'g', Nullch, 0);
226            mg = mg_find(sv, 'g');
227        }
228        i = m - orig;
229        if (DO_UTF8(sv))
230            sv_pos_b2u(sv, &i);
231        mg->mg_len = i;
232    }
233    cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
234    rxres_save(&cx->sb_rxres, rx);
235    RETURNOP(pm->op_pmreplstart);
236}
237
238void
239Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
240{
241    UV *p = (UV*)*rsp;
242    U32 i;
243
244    if (!p || p[1] < rx->nparens) {
245        i = 6 + rx->nparens * 2;
246        if (!p)
247            New(501, p, i, UV);
248        else
249            Renew(p, i, UV);
250        *rsp = (void*)p;
251    }
252
253    *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
254    RX_MATCH_COPIED_off(rx);
255
256    *p++ = rx->nparens;
257
258    *p++ = PTR2UV(rx->subbeg);
259    *p++ = (UV)rx->sublen;
260    for (i = 0; i <= rx->nparens; ++i) {
261        *p++ = (UV)rx->startp[i];
262        *p++ = (UV)rx->endp[i];
263    }
264}
265
266void
267Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
268{
269    UV *p = (UV*)*rsp;
270    U32 i;
271
272    if (RX_MATCH_COPIED(rx))
273        Safefree(rx->subbeg);
274    RX_MATCH_COPIED_set(rx, *p);
275    *p++ = 0;
276
277    rx->nparens = *p++;
278
279    rx->subbeg = INT2PTR(char*,*p++);
280    rx->sublen = (I32)(*p++);
281    for (i = 0; i <= rx->nparens; ++i) {
282        rx->startp[i] = (I32)(*p++);
283        rx->endp[i] = (I32)(*p++);
284    }
285}
286
287void
288Perl_rxres_free(pTHX_ void **rsp)
289{
290    UV *p = (UV*)*rsp;
291
292    if (p) {
293        Safefree(INT2PTR(char*,*p));
294        Safefree(p);
295        *rsp = Null(void*);
296    }
297}
298
299PP(pp_formline)
300{
301    dSP; dMARK; dORIGMARK;
302    register SV *tmpForm = *++MARK;
303    register U16 *fpc;
304    register char *t;
305    register char *f;
306    register char *s;
307    register char *send;
308    register I32 arg;
309    register SV *sv;
310    char *item;
311    I32 itemsize;
312    I32 fieldsize;
313    I32 lines = 0;
314    bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
315    char *chophere;
316    char *linemark;
317    NV value;
318    bool gotsome;
319    STRLEN len;
320    STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
321    bool item_is_utf = FALSE;
322
323    if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
324        if (SvREADONLY(tmpForm)) {
325            SvREADONLY_off(tmpForm);
326            doparseform(tmpForm);
327            SvREADONLY_on(tmpForm);
328        }
329        else
330            doparseform(tmpForm);
331    }
332
333    SvPV_force(PL_formtarget, len);
334    t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
335    t += len;
336    f = SvPV(tmpForm, len);
337    /* need to jump to the next word */
338    s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
339
340    fpc = (U16*)s;
341
342    for (;;) {
343        DEBUG_f( {
344            char *name = "???";
345            arg = -1;
346            switch (*fpc) {
347            case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
348            case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
349            case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
350            case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
351            case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
352
353            case FF_CHECKNL:    name = "CHECKNL";       break;
354            case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
355            case FF_SPACE:      name = "SPACE";         break;
356            case FF_HALFSPACE:  name = "HALFSPACE";     break;
357            case FF_ITEM:       name = "ITEM";          break;
358            case FF_CHOP:       name = "CHOP";          break;
359            case FF_LINEGLOB:   name = "LINEGLOB";      break;
360            case FF_NEWLINE:    name = "NEWLINE";       break;
361            case FF_MORE:       name = "MORE";          break;
362            case FF_LINEMARK:   name = "LINEMARK";      break;
363            case FF_END:        name = "END";           break;
364            }
365            if (arg >= 0)
366                PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
367            else
368                PerlIO_printf(Perl_debug_log, "%-16s\n", name);
369        } )
370        switch (*fpc++) {
371        case FF_LINEMARK:
372            linemark = t;
373            lines++;
374            gotsome = FALSE;
375            break;
376
377        case FF_LITERAL:
378            arg = *fpc++;
379            while (arg--)
380                *t++ = *f++;
381            break;
382
383        case FF_SKIP:
384            f += *fpc++;
385            break;
386
387        case FF_FETCH:
388            arg = *fpc++;
389            f += arg;
390            fieldsize = arg;
391
392            if (MARK < SP)
393                sv = *++MARK;
394            else {
395                sv = &PL_sv_no;
396                if (ckWARN(WARN_SYNTAX))
397                    Perl_warner(aTHX_ WARN_SYNTAX, "Not enough format arguments");
398            }
399            break;
400
401        case FF_CHECKNL:
402            item = s = SvPV(sv, len);
403            itemsize = len;
404            if (DO_UTF8(sv)) {
405                itemsize = sv_len_utf8(sv);
406                if (itemsize != len) {
407                    I32 itembytes;
408                    if (itemsize > fieldsize) {
409                        itemsize = fieldsize;
410                        itembytes = itemsize;
411                        sv_pos_u2b(sv, &itembytes, 0);
412                    }
413                    else
414                        itembytes = len;
415                    send = chophere = s + itembytes;
416                    while (s < send) {
417                        if (*s & ~31)
418                            gotsome = TRUE;
419                        else if (*s == '\n')
420                            break;
421                        s++;
422                    }
423                    item_is_utf = TRUE;
424                    itemsize = s - item;
425                    sv_pos_b2u(sv, &itemsize);
426                    break;
427                }
428            }
429            item_is_utf = FALSE;
430            if (itemsize > fieldsize)
431                itemsize = fieldsize;
432            send = chophere = s + itemsize;
433            while (s < send) {
434                if (*s & ~31)
435                    gotsome = TRUE;
436                else if (*s == '\n')
437                    break;
438                s++;
439            }
440            itemsize = s - item;
441            break;
442
443        case FF_CHECKCHOP:
444            item = s = SvPV(sv, len);
445            itemsize = len;
446            if (DO_UTF8(sv)) {
447                itemsize = sv_len_utf8(sv);
448                if (itemsize != len) {
449                    I32 itembytes;
450                    if (itemsize <= fieldsize) {
451                        send = chophere = s + itemsize;
452                        while (s < send) {
453                            if (*s == '\r') {
454                                itemsize = s - item;
455                                break;
456                            }
457                            if (*s++ & ~31)
458                                gotsome = TRUE;
459                        }
460                    }
461                    else {
462                        itemsize = fieldsize;
463                        itembytes = itemsize;
464                        sv_pos_u2b(sv, &itembytes, 0);
465                        send = chophere = s + itembytes;
466                        while (s < send || (s == send && isSPACE(*s))) {
467                            if (isSPACE(*s)) {
468                                if (chopspace)
469                                    chophere = s;
470                                if (*s == '\r')
471                                    break;
472                            }
473                            else {
474                                if (*s & ~31)
475                                    gotsome = TRUE;
476                                if (strchr(PL_chopset, *s))
477                                    chophere = s + 1;
478                            }
479                            s++;
480                        }
481                        itemsize = chophere - item;
482                        sv_pos_b2u(sv, &itemsize);
483                    }
484                    item_is_utf = TRUE;
485                    break;
486                }
487            }
488            item_is_utf = FALSE;
489            if (itemsize <= fieldsize) {
490                send = chophere = s + itemsize;
491                while (s < send) {
492                    if (*s == '\r') {
493                        itemsize = s - item;
494                        break;
495                    }
496                    if (*s++ & ~31)
497                        gotsome = TRUE;
498                }
499            }
500            else {
501                itemsize = fieldsize;
502                send = chophere = s + itemsize;
503                while (s < send || (s == send && isSPACE(*s))) {
504                    if (isSPACE(*s)) {
505                        if (chopspace)
506                            chophere = s;
507                        if (*s == '\r')
508                            break;
509                    }
510                    else {
511                        if (*s & ~31)
512                            gotsome = TRUE;
513                        if (strchr(PL_chopset, *s))
514                            chophere = s + 1;
515                    }
516                    s++;
517                }
518                itemsize = chophere - item;
519            }
520            break;
521
522        case FF_SPACE:
523            arg = fieldsize - itemsize;
524            if (arg) {
525                fieldsize -= arg;
526                while (arg-- > 0)
527                    *t++ = ' ';
528            }
529            break;
530
531        case FF_HALFSPACE:
532            arg = fieldsize - itemsize;
533            if (arg) {
534                arg /= 2;
535                fieldsize -= arg;
536                while (arg-- > 0)
537                    *t++ = ' ';
538            }
539            break;
540
541        case FF_ITEM:
542            arg = itemsize;
543            s = item;
544            if (item_is_utf) {
545                while (arg--) {
546                    if (UTF8_IS_CONTINUED(*s)) {
547                        switch (UTF8SKIP(s)) {
548                        case 7: *t++ = *s++;
549                        case 6: *t++ = *s++;
550                        case 5: *t++ = *s++;
551                        case 4: *t++ = *s++;
552                        case 3: *t++ = *s++;
553                        case 2: *t++ = *s++;
554                        case 1: *t++ = *s++;
555                        }
556                    }
557                    else {
558                        if ( !((*t++ = *s++) & ~31) )
559                            t[-1] = ' ';
560                    }
561                }
562                break;
563            }
564            while (arg--) {
565#ifdef EBCDIC
566                int ch = *t++ = *s++;
567                if (iscntrl(ch))
568#else
569                if ( !((*t++ = *s++) & ~31) )
570#endif
571                    t[-1] = ' ';
572            }
573            break;
574
575        case FF_CHOP:
576            s = chophere;
577            if (chopspace) {
578                while (*s && isSPACE(*s))
579                    s++;
580            }
581            sv_chop(sv,s);
582            break;
583
584        case FF_LINEGLOB:
585            item = s = SvPV(sv, len);
586            itemsize = len;
587            item_is_utf = FALSE;                /* XXX is this correct? */
588            if (itemsize) {
589                gotsome = TRUE;
590                send = s + itemsize;
591                while (s < send) {
592                    if (*s++ == '\n') {
593                        if (s == send)
594                            itemsize--;
595                        else
596                            lines++;
597                    }
598                }
599                SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
600                sv_catpvn(PL_formtarget, item, itemsize);
601                SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
602                t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
603            }
604            break;
605
606        case FF_DECIMAL:
607            /* If the field is marked with ^ and the value is undefined,
608               blank it out. */
609            arg = *fpc++;
610            if ((arg & 512) && !SvOK(sv)) {
611                arg = fieldsize;
612                while (arg--)
613                    *t++ = ' ';
614                break;
615            }
616            gotsome = TRUE;
617            value = SvNV(sv);
618            /* Formats aren't yet marked for locales, so assume "yes". */
619            {
620                STORE_NUMERIC_STANDARD_SET_LOCAL();
621#if defined(USE_LONG_DOUBLE)
622                if (arg & 256) {
623                    sprintf(t, "%#*.*" PERL_PRIfldbl,
624                            (int) fieldsize, (int) arg & 255, value);
625                } else {
626                    sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
627                }
628#else
629                if (arg & 256) {
630                    sprintf(t, "%#*.*f",
631                            (int) fieldsize, (int) arg & 255, value);
632                } else {
633                    sprintf(t, "%*.0f",
634                            (int) fieldsize, value);
635                }
636#endif
637                RESTORE_NUMERIC_STANDARD();
638            }
639            t += fieldsize;
640            break;
641
642        case FF_NEWLINE:
643            f++;
644            while (t-- > linemark && *t == ' ') ;
645            t++;
646            *t++ = '\n';
647            break;
648
649        case FF_BLANK:
650            arg = *fpc++;
651            if (gotsome) {
652                if (arg) {              /* repeat until fields exhausted? */
653                    *t = '\0';
654                    SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
655                    lines += FmLINES(PL_formtarget);
656                    if (lines == 200) {
657                        arg = t - linemark;
658                        if (strnEQ(linemark, linemark - arg, arg))
659                            DIE(aTHX_ "Runaway format");
660                    }
661                    FmLINES(PL_formtarget) = lines;
662                    SP = ORIGMARK;
663                    RETURNOP(cLISTOP->op_first);
664                }
665            }
666            else {
667                t = linemark;
668                lines--;
669            }
670            break;
671
672        case FF_MORE:
673            s = chophere;
674            send = item + len;
675            if (chopspace) {
676                while (*s && isSPACE(*s) && s < send)
677                    s++;
678            }
679            if (s < send) {
680                arg = fieldsize - itemsize;
681                if (arg) {
682                    fieldsize -= arg;
683                    while (arg-- > 0)
684                        *t++ = ' ';
685                }
686                s = t - 3;
687                if (strnEQ(s,"   ",3)) {
688                    while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
689                        s--;
690                }
691                *s++ = '.';
692                *s++ = '.';
693                *s++ = '.';
694            }
695            break;
696
697        case FF_END:
698            *t = '\0';
699            SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
700            FmLINES(PL_formtarget) += lines;
701            SP = ORIGMARK;
702            RETPUSHYES;
703        }
704    }
705}
706
707PP(pp_grepstart)
708{
709    dSP;
710    SV *src;
711
712    if (PL_stack_base + *PL_markstack_ptr == SP) {
713        (void)POPMARK;
714        if (GIMME_V == G_SCALAR)
715            XPUSHs(sv_2mortal(newSViv(0)));
716        RETURNOP(PL_op->op_next->op_next);
717    }
718    PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
719    pp_pushmark();                              /* push dst */
720    pp_pushmark();                              /* push src */
721    ENTER;                                      /* enter outer scope */
722
723    SAVETMPS;
724    /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
725    SAVESPTR(DEFSV);
726    ENTER;                                      /* enter inner scope */
727    SAVEVPTR(PL_curpm);
728
729    src = PL_stack_base[*PL_markstack_ptr];
730    SvTEMP_off(src);
731    DEFSV = src;
732
733    PUTBACK;
734    if (PL_op->op_type == OP_MAPSTART)
735        pp_pushmark();                  /* push top */
736    return ((LOGOP*)PL_op->op_next)->op_other;
737}
738
739PP(pp_mapstart)
740{
741    DIE(aTHX_ "panic: mapstart");       /* uses grepstart */
742}
743
744PP(pp_mapwhile)
745{
746    dSP;
747    I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
748    I32 count;
749    I32 shift;
750    SV** src;
751    SV** dst;
752
753    /* first, move source pointer to the next item in the source list */
754    ++PL_markstack_ptr[-1];
755
756    /* if there are new items, push them into the destination list */
757    if (items) {
758        /* might need to make room back there first */
759        if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
760            /* XXX this implementation is very pessimal because the stack
761             * is repeatedly extended for every set of items.  Is possible
762             * to do this without any stack extension or copying at all
763             * by maintaining a separate list over which the map iterates
764             * (like foreach does). --gsar */
765
766            /* everything in the stack after the destination list moves
767             * towards the end the stack by the amount of room needed */
768            shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
769
770            /* items to shift up (accounting for the moved source pointer) */
771            count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
772
773            /* This optimization is by Ben Tilly and it does
774             * things differently from what Sarathy (gsar)
775             * is describing.  The downside of this optimization is
776             * that leaves "holes" (uninitialized and hopefully unused areas)
777             * to the Perl stack, but on the other hand this
778             * shouldn't be a problem.  If Sarathy's idea gets
779             * implemented, this optimization should become
780             * irrelevant.  --jhi */
781            if (shift < count)
782                shift = count; /* Avoid shifting too often --Ben Tilly */
783           
784            EXTEND(SP,shift);
785            src = SP;
786            dst = (SP += shift);
787            PL_markstack_ptr[-1] += shift;
788            *PL_markstack_ptr += shift;
789            while (count--)
790                *dst-- = *src--;
791        }
792        /* copy the new items down to the destination list */
793        dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
794        while (items--)
795            *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
796    }
797    LEAVE;                                      /* exit inner scope */
798
799    /* All done yet? */
800    if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
801        I32 gimme = GIMME_V;
802
803        (void)POPMARK;                          /* pop top */
804        LEAVE;                                  /* exit outer scope */
805        (void)POPMARK;                          /* pop src */
806        items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
807        (void)POPMARK;                          /* pop dst */
808        SP = PL_stack_base + POPMARK;           /* pop original mark */
809        if (gimme == G_SCALAR) {
810            dTARGET;
811            XPUSHi(items);
812        }
813        else if (gimme == G_ARRAY)
814            SP += items;
815        RETURN;
816    }
817    else {
818        SV *src;
819
820        ENTER;                                  /* enter inner scope */
821        SAVEVPTR(PL_curpm);
822
823        /* set $_ to the new source item */
824        src = PL_stack_base[PL_markstack_ptr[-1]];
825        SvTEMP_off(src);
826        DEFSV = src;
827
828        RETURNOP(cLOGOP->op_other);
829    }
830}
831
832PP(pp_sort)
833{
834    dSP; dMARK; dORIGMARK;
835    register SV **up;
836    SV **myorigmark = ORIGMARK;
837    register I32 max;
838    HV *stash;
839    GV *gv;
840    CV *cv;
841    I32 gimme = GIMME;
842    OP* nextop = PL_op->op_next;
843    I32 overloading = 0;
844    bool hasargs = FALSE;
845    I32 is_xsub = 0;
846
847    if (gimme != G_ARRAY) {
848        SP = MARK;
849        RETPUSHUNDEF;
850    }
851
852    ENTER;
853    SAVEVPTR(PL_sortcop);
854    if (PL_op->op_flags & OPf_STACKED) {
855        if (PL_op->op_flags & OPf_SPECIAL) {
856            OP *kid = cLISTOP->op_first->op_sibling;    /* pass pushmark */
857            kid = kUNOP->op_first;                      /* pass rv2gv */
858            kid = kUNOP->op_first;                      /* pass leave */
859            PL_sortcop = kid->op_next;
860            stash = CopSTASH(PL_curcop);
861        }
862        else {
863            cv = sv_2cv(*++MARK, &stash, &gv, 0);
864            if (cv && SvPOK(cv)) {
865                STRLEN n_a;
866                char *proto = SvPV((SV*)cv, n_a);
867                if (proto && strEQ(proto, "$$")) {
868                    hasargs = TRUE;
869                }
870            }
871            if (!(cv && CvROOT(cv))) {
872                if (cv && CvXSUB(cv)) {
873                    is_xsub = 1;
874                }
875                else if (gv) {
876                    SV *tmpstr = sv_newmortal();
877                    gv_efullname3(tmpstr, gv, Nullch);
878                    DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
879                        SvPVX(tmpstr));
880                }
881                else {
882                    DIE(aTHX_ "Undefined subroutine in sort");
883                }
884            }
885
886            if (is_xsub)
887                PL_sortcop = (OP*)cv;
888            else {
889                PL_sortcop = CvSTART(cv);
890                SAVEVPTR(CvROOT(cv)->op_ppaddr);
891                CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
892
893                SAVEVPTR(PL_curpad);
894                PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
895            }
896        }
897    }
898    else {
899        PL_sortcop = Nullop;
900        stash = CopSTASH(PL_curcop);
901    }
902
903    up = myorigmark + 1;
904    while (MARK < SP) { /* This may or may not shift down one here. */
905        /*SUPPRESS 560*/
906        if ((*up = *++MARK)) {                  /* Weed out nulls. */
907            SvTEMP_off(*up);
908            if (!PL_sortcop && !SvPOK(*up)) {
909                STRLEN n_a;
910                if (SvAMAGIC(*up))
911                    overloading = 1;
912                else
913                    (void)sv_2pv(*up, &n_a);
914            }
915            up++;
916        }
917    }
918    max = --up - myorigmark;
919    if (PL_sortcop) {
920        if (max > 1) {
921            PERL_CONTEXT *cx;
922            SV** newsp;
923            bool oldcatch = CATCH_GET;
924
925            SAVETMPS;
926            SAVEOP();
927
928            CATCH_SET(TRUE);
929            PUSHSTACKi(PERLSI_SORT);
930            if (!hasargs && !is_xsub) {
931                if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
932                    SAVESPTR(PL_firstgv);
933                    SAVESPTR(PL_secondgv);
934                    PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
935                    PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
936                    PL_sortstash = stash;
937                }
938#ifdef USE_THREADS
939                sv_lock((SV *)PL_firstgv);
940                sv_lock((SV *)PL_secondgv);
941#endif
942                SAVESPTR(GvSV(PL_firstgv));
943                SAVESPTR(GvSV(PL_secondgv));
944            }
945
946            PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
947            if (!(PL_op->op_flags & OPf_SPECIAL)) {
948                cx->cx_type = CXt_SUB;
949                cx->blk_gimme = G_SCALAR;
950                PUSHSUB(cx);
951                if (!CvDEPTH(cv))
952                    (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
953            }
954            PL_sortcxix = cxstack_ix;
955
956            if (hasargs && !is_xsub) {
957                /* This is mostly copied from pp_entersub */
958                AV *av = (AV*)PL_curpad[0];
959
960#ifndef USE_THREADS
961                cx->blk_sub.savearray = GvAV(PL_defgv);
962                GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
963#endif /* USE_THREADS */
964                cx->blk_sub.oldcurpad = PL_curpad;
965                cx->blk_sub.argarray = av;
966            }
967            qsortsv((myorigmark+1), max,
968                    is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
969
970            POPBLOCK(cx,PL_curpm);
971            PL_stack_sp = newsp;
972            POPSTACK;
973            CATCH_SET(oldcatch);
974        }
975    }
976    else {
977        if (max > 1) {
978            MEXTEND(SP, 20);    /* Can't afford stack realloc on signal. */
979            qsortsv(ORIGMARK+1, max,
980                    (PL_op->op_private & OPpSORT_NUMERIC)
981                        ? ( (PL_op->op_private & OPpSORT_INTEGER)
982                            ? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
983                            : ( overloading ? amagic_ncmp : sv_ncmp))
984                        : ( (PL_op->op_private & OPpLOCALE)
985                            ? ( overloading
986                                ? amagic_cmp_locale
987                                : sv_cmp_locale_static)
988                            : ( overloading ? amagic_cmp : sv_cmp_static)));
989            if (PL_op->op_private & OPpSORT_REVERSE) {
990                SV **p = ORIGMARK+1;
991                SV **q = ORIGMARK+max;
992                while (p < q) {
993                    SV *tmp = *p;
994                    *p++ = *q;
995                    *q-- = tmp;
996                }
997            }
998        }
999    }
1000    LEAVE;
1001    PL_stack_sp = ORIGMARK + max;
1002    return nextop;
1003}
1004
1005/* Range stuff. */
1006
1007PP(pp_range)
1008{
1009    if (GIMME == G_ARRAY)
1010        return NORMAL;
1011    if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1012        return cLOGOP->op_other;
1013    else
1014        return NORMAL;
1015}
1016
1017PP(pp_flip)
1018{
1019    dSP;
1020
1021    if (GIMME == G_ARRAY) {
1022        RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1023    }
1024    else {
1025        dTOPss;
1026        SV *targ = PAD_SV(PL_op->op_targ);
1027        int flip;
1028
1029        if (PL_op->op_private & OPpFLIP_LINENUM) {
1030            struct io *gp_io;
1031            flip = PL_last_in_gv
1032                && (gp_io = GvIOp(PL_last_in_gv))
1033                && SvIV(sv) == (IV)IoLINES(gp_io);
1034        } else {
1035            flip = SvTRUE(sv);
1036        }
1037        if (flip) {
1038            sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1039            if (PL_op->op_flags & OPf_SPECIAL) {
1040                sv_setiv(targ, 1);
1041                SETs(targ);
1042                RETURN;
1043            }
1044            else {
1045                sv_setiv(targ, 0);
1046                SP--;
1047                RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1048            }
1049        }
1050        sv_setpv(TARG, "");
1051        SETs(targ);
1052        RETURN;
1053    }
1054}
1055
1056PP(pp_flop)
1057{
1058    dSP;
1059
1060    if (GIMME == G_ARRAY) {
1061        dPOPPOPssrl;
1062        register I32 i, j;
1063        register SV *sv;
1064        I32 max;
1065
1066        if (SvGMAGICAL(left))
1067            mg_get(left);
1068        if (SvGMAGICAL(right))
1069            mg_get(right);
1070
1071        if (SvNIOKp(left) || !SvPOKp(left) ||
1072            SvNIOKp(right) || !SvPOKp(right) ||
1073            (looks_like_number(left) && *SvPVX(left) != '0' &&
1074             looks_like_number(right) && *SvPVX(right) != '0'))
1075        {
1076            if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1077                DIE(aTHX_ "Range iterator outside integer range");
1078            i = SvIV(left);
1079            max = SvIV(right);
1080            if (max >= i) {
1081                j = max - i + 1;
1082                EXTEND_MORTAL(j);
1083                EXTEND(SP, j);
1084            }
1085            else
1086                j = 0;
1087            while (j--) {
1088                sv = sv_2mortal(newSViv(i++));
1089                PUSHs(sv);
1090            }
1091        }
1092        else {
1093            SV *final = sv_mortalcopy(right);
1094            STRLEN len, n_a;
1095            char *tmps = SvPV(final, len);
1096
1097            sv = sv_mortalcopy(left);
1098            SvPV_force(sv,n_a);
1099            while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1100                XPUSHs(sv);
1101                if (strEQ(SvPVX(sv),tmps))
1102                    break;
1103                sv = sv_2mortal(newSVsv(sv));
1104                sv_inc(sv);
1105            }
1106        }
1107    }
1108    else {
1109        dTOPss;
1110        SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1111        sv_inc(targ);
1112        if ((PL_op->op_private & OPpFLIP_LINENUM)
1113          ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1114          : SvTRUE(sv) ) {
1115            sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1116            sv_catpv(targ, "E0");
1117        }
1118        SETs(targ);
1119    }
1120
1121    RETURN;
1122}
1123
1124/* Control. */
1125
1126STATIC I32
1127S_dopoptolabel(pTHX_ char *label)
1128{
1129    register I32 i;
1130    register PERL_CONTEXT *cx;
1131
1132    for (i = cxstack_ix; i >= 0; i--) {
1133        cx = &cxstack[i];
1134        switch (CxTYPE(cx)) {
1135        case CXt_SUBST:
1136            if (ckWARN(WARN_EXITING))
1137                Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1138                        PL_op_name[PL_op->op_type]);
1139            break;
1140        case CXt_SUB:
1141            if (ckWARN(WARN_EXITING))
1142                Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1143                        PL_op_name[PL_op->op_type]);
1144            break;
1145        case CXt_FORMAT:
1146            if (ckWARN(WARN_EXITING))
1147                Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1148                        PL_op_name[PL_op->op_type]);
1149            break;
1150        case CXt_EVAL:
1151            if (ckWARN(WARN_EXITING))
1152                Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1153                        PL_op_name[PL_op->op_type]);
1154            break;
1155        case CXt_NULL:
1156            if (ckWARN(WARN_EXITING))
1157                Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1158                        PL_op_name[PL_op->op_type]);
1159            return -1;
1160        case CXt_LOOP:
1161            if (!cx->blk_loop.label ||
1162              strNE(label, cx->blk_loop.label) ) {
1163                DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1164                        (long)i, cx->blk_loop.label));
1165                continue;
1166            }
1167            DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1168            return i;
1169        }
1170    }
1171    return i;
1172}
1173
1174I32
1175Perl_dowantarray(pTHX)
1176{
1177    I32 gimme = block_gimme();
1178    return (gimme == G_VOID) ? G_SCALAR : gimme;
1179}
1180
1181I32
1182Perl_block_gimme(pTHX)
1183{
1184    I32 cxix;
1185
1186    cxix = dopoptosub(cxstack_ix);
1187    if (cxix < 0)
1188        return G_VOID;
1189
1190    switch (cxstack[cxix].blk_gimme) {
1191    case G_VOID:
1192        return G_VOID;
1193    case G_SCALAR:
1194        return G_SCALAR;
1195    case G_ARRAY:
1196        return G_ARRAY;
1197    default:
1198        Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1199        /* NOTREACHED */
1200        return 0;
1201    }
1202}
1203
1204I32
1205Perl_is_lvalue_sub(pTHX)
1206{
1207    I32 cxix;
1208
1209    cxix = dopoptosub(cxstack_ix);
1210    assert(cxix >= 0);  /* We should only be called from inside subs */
1211
1212    if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1213        return cxstack[cxix].blk_sub.lval;
1214    else
1215        return 0;
1216}
1217
1218STATIC I32
1219S_dopoptosub(pTHX_ I32 startingblock)
1220{
1221    return dopoptosub_at(cxstack, startingblock);
1222}
1223
1224STATIC I32
1225S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1226{
1227    I32 i;
1228    register PERL_CONTEXT *cx;
1229    for (i = startingblock; i >= 0; i--) {
1230        cx = &cxstk[i];
1231        switch (CxTYPE(cx)) {
1232        default:
1233            continue;
1234        case CXt_EVAL:
1235        case CXt_SUB:
1236        case CXt_FORMAT:
1237            DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1238            return i;
1239        }
1240    }
1241    return i;
1242}
1243
1244STATIC I32
1245S_dopoptoeval(pTHX_ I32 startingblock)
1246{
1247    I32 i;
1248    register PERL_CONTEXT *cx;
1249    for (i = startingblock; i >= 0; i--) {
1250        cx = &cxstack[i];
1251        switch (CxTYPE(cx)) {
1252        default:
1253            continue;
1254        case CXt_EVAL:
1255            DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1256            return i;
1257        }
1258    }
1259    return i;
1260}
1261
1262STATIC I32
1263S_dopoptoloop(pTHX_ I32 startingblock)
1264{
1265    I32 i;
1266    register PERL_CONTEXT *cx;
1267    for (i = startingblock; i >= 0; i--) {
1268        cx = &cxstack[i];
1269        switch (CxTYPE(cx)) {
1270        case CXt_SUBST:
1271            if (ckWARN(WARN_EXITING))
1272                Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1273                        PL_op_name[PL_op->op_type]);
1274            break;
1275        case CXt_SUB:
1276            if (ckWARN(WARN_EXITING))
1277                Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1278                        PL_op_name[PL_op->op_type]);
1279            break;
1280        case CXt_FORMAT:
1281            if (ckWARN(WARN_EXITING))
1282                Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1283                        PL_op_name[PL_op->op_type]);
1284            break;
1285        case CXt_EVAL:
1286            if (ckWARN(WARN_EXITING))
1287                Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1288                        PL_op_name[PL_op->op_type]);
1289            break;
1290        case CXt_NULL:
1291            if (ckWARN(WARN_EXITING))
1292                Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1293                        PL_op_name[PL_op->op_type]);
1294            return -1;
1295        case CXt_LOOP:
1296            DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1297            return i;
1298        }
1299    }
1300    return i;
1301}
1302
1303void
1304Perl_dounwind(pTHX_ I32 cxix)
1305{
1306    register PERL_CONTEXT *cx;
1307    I32 optype;
1308
1309    while (cxstack_ix > cxix) {
1310        SV *sv;
1311        cx = &cxstack[cxstack_ix];
1312        DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1313                              (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1314        /* Note: we don't need to restore the base context info till the end. */
1315        switch (CxTYPE(cx)) {
1316        case CXt_SUBST:
1317            POPSUBST(cx);
1318            continue;  /* not break */
1319        case CXt_SUB:
1320            POPSUB(cx,sv);
1321            LEAVESUB(sv);
1322            break;
1323        case CXt_EVAL:
1324            POPEVAL(cx);
1325            break;
1326        case CXt_LOOP:
1327            POPLOOP(cx);
1328            break;
1329        case CXt_NULL:
1330            break;
1331        case CXt_FORMAT:
1332            POPFORMAT(cx);
1333            break;
1334        }
1335        cxstack_ix--;
1336    }
1337}
1338
1339void
1340Perl_qerror(pTHX_ SV *err)
1341{
1342    if (PL_in_eval)
1343        sv_catsv(ERRSV, err);
1344    else if (PL_errors)
1345        sv_catsv(PL_errors, err);
1346    else
1347        Perl_warn(aTHX_ "%"SVf, err);
1348    ++PL_error_count;
1349}
1350
1351OP *
1352Perl_die_where(pTHX_ char *message, STRLEN msglen)
1353{
1354    STRLEN n_a;
1355    if (PL_in_eval) {
1356        I32 cxix;
1357        register PERL_CONTEXT *cx;
1358        I32 gimme;
1359        SV **newsp;
1360
1361        if (message) {
1362            if (PL_in_eval & EVAL_KEEPERR) {
1363                static char prefix[] = "\t(in cleanup) ";
1364                SV *err = ERRSV;
1365                char *e = Nullch;
1366                if (!SvPOK(err))
1367                    sv_setpv(err,"");
1368                else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1369                    e = SvPV(err, n_a);
1370                    e += n_a - msglen;
1371                    if (*e != *message || strNE(e,message))
1372                        e = Nullch;
1373                }
1374                if (!e) {
1375                    SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1376                    sv_catpvn(err, prefix, sizeof(prefix)-1);
1377                    sv_catpvn(err, message, msglen);
1378                    if (ckWARN(WARN_MISC)) {
1379                        STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1380                        Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1381                    }
1382                }
1383            }
1384            else
1385                sv_setpvn(ERRSV, message, msglen);
1386        }
1387        else
1388            message = SvPVx(ERRSV, msglen);
1389
1390        while ((cxix = dopoptoeval(cxstack_ix)) < 0
1391               && PL_curstackinfo->si_prev)
1392        {
1393            dounwind(-1);
1394            POPSTACK;
1395        }
1396
1397        if (cxix >= 0) {
1398            I32 optype;
1399
1400            if (cxix < cxstack_ix)
1401                dounwind(cxix);
1402
1403            POPBLOCK(cx,PL_curpm);
1404            if (CxTYPE(cx) != CXt_EVAL) {
1405                PerlIO_write(Perl_error_log, "panic: die ", 11);
1406                PerlIO_write(Perl_error_log, message, msglen);
1407                my_exit(1);
1408            }
1409            POPEVAL(cx);
1410
1411            if (gimme == G_SCALAR)
1412                *++newsp = &PL_sv_undef;
1413            PL_stack_sp = newsp;
1414
1415            LEAVE;
1416
1417            /* LEAVE could clobber PL_curcop (see save_re_context())
1418             * XXX it might be better to find a way to avoid messing with
1419             * PL_curcop in save_re_context() instead, but this is a more
1420             * minimal fix --GSAR */
1421            PL_curcop = cx->blk_oldcop;
1422
1423            if (optype == OP_REQUIRE) {
1424                char* msg = SvPVx(ERRSV, n_a);
1425                DIE(aTHX_ "%sCompilation failed in require",
1426                    *msg ? msg : "Unknown error\n");
1427            }
1428            return pop_return();
1429        }
1430    }
1431    if (!message)
1432        message = SvPVx(ERRSV, msglen);
1433    {
1434#ifdef USE_SFIO
1435        /* SFIO can really mess with your errno */
1436        int e = errno;
1437#endif
1438        PerlIO *serr = Perl_error_log;
1439
1440        PerlIO_write(serr, message, msglen);
1441        (void)PerlIO_flush(serr);
1442#ifdef USE_SFIO
1443        errno = e;
1444#endif
1445    }
1446    my_failure_exit();
1447    /* NOTREACHED */
1448    return 0;
1449}
1450
1451PP(pp_xor)
1452{
1453    dSP; dPOPTOPssrl;
1454    if (SvTRUE(left) != SvTRUE(right))
1455        RETSETYES;
1456    else
1457        RETSETNO;
1458}
1459
1460PP(pp_andassign)
1461{
1462    dSP;
1463    if (!SvTRUE(TOPs))
1464        RETURN;
1465    else
1466        RETURNOP(cLOGOP->op_other);
1467}
1468
1469PP(pp_orassign)
1470{
1471    dSP;
1472    if (SvTRUE(TOPs))
1473        RETURN;
1474    else
1475        RETURNOP(cLOGOP->op_other);
1476}
1477       
1478PP(pp_caller)
1479{
1480    dSP;
1481    register I32 cxix = dopoptosub(cxstack_ix);
1482    register PERL_CONTEXT *cx;
1483    register PERL_CONTEXT *ccstack = cxstack;
1484    PERL_SI *top_si = PL_curstackinfo;
1485    I32 dbcxix;
1486    I32 gimme;
1487    char *stashname;
1488    SV *sv;
1489    I32 count = 0;
1490
1491    if (MAXARG)
1492        count = POPi;
1493    EXTEND(SP, 10);
1494    for (;;) {
1495        /* we may be in a higher stacklevel, so dig down deeper */
1496        while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1497            top_si = top_si->si_prev;
1498            ccstack = top_si->si_cxstack;
1499            cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1500        }
1501        if (cxix < 0) {
1502            if (GIMME != G_ARRAY)
1503                RETPUSHUNDEF;
1504            RETURN;
1505        }
1506        if (PL_DBsub && cxix >= 0 &&
1507                ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1508            count++;
1509        if (!count--)
1510            break;
1511        cxix = dopoptosub_at(ccstack, cxix - 1);
1512    }
1513
1514    cx = &ccstack[cxix];
1515    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1516        dbcxix = dopoptosub_at(ccstack, cxix - 1);
1517        /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1518           field below is defined for any cx. */
1519        if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1520            cx = &ccstack[dbcxix];
1521    }
1522
1523    stashname = CopSTASHPV(cx->blk_oldcop);
1524    if (GIMME != G_ARRAY) {
1525        if (!stashname)
1526            PUSHs(&PL_sv_undef);
1527        else {
1528            dTARGET;
1529            sv_setpv(TARG, stashname);
1530            PUSHs(TARG);
1531        }
1532        RETURN;
1533    }
1534
1535    if (!stashname)
1536        PUSHs(&PL_sv_undef);
1537    else
1538        PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1539    PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0)));
1540    PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1541    if (!MAXARG)
1542        RETURN;
1543    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1544        /* So is ccstack[dbcxix]. */
1545        sv = NEWSV(49, 0);
1546        gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1547        PUSHs(sv_2mortal(sv));
1548        PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1549    }
1550    else {
1551        PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1552        PUSHs(sv_2mortal(newSViv(0)));
1553    }
1554    gimme = (I32)cx->blk_gimme;
1555    if (gimme == G_VOID)
1556        PUSHs(&PL_sv_undef);
1557    else
1558        PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1559    if (CxTYPE(cx) == CXt_EVAL) {
1560        /* eval STRING */
1561        if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1562            PUSHs(cx->blk_eval.cur_text);
1563            PUSHs(&PL_sv_no);
1564        }
1565        /* require */
1566        else if (cx->blk_eval.old_namesv) {
1567            PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1568            PUSHs(&PL_sv_yes);
1569        }
1570        /* eval BLOCK (try blocks have old_namesv == 0) */
1571        else {
1572            PUSHs(&PL_sv_undef);
1573            PUSHs(&PL_sv_undef);
1574        }
1575    }
1576    else {
1577        PUSHs(&PL_sv_undef);
1578        PUSHs(&PL_sv_undef);
1579    }
1580    if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1581        && CopSTASH_eq(PL_curcop, PL_debstash))
1582    {
1583        AV *ary = cx->blk_sub.argarray;
1584        int off = AvARRAY(ary) - AvALLOC(ary);
1585
1586        if (!PL_dbargs) {
1587            GV* tmpgv;
1588            PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1589                                SVt_PVAV)));
1590            GvMULTI_on(tmpgv);
1591            AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1592        }
1593
1594        if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1595            av_extend(PL_dbargs, AvFILLp(ary) + off);
1596        Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1597        AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1598    }
1599    /* XXX only hints propagated via op_private are currently
1600     * visible (others are not easily accessible, since they
1601     * use the global PL_hints) */
1602    PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1603                             HINT_PRIVATE_MASK)));
1604    {
1605        SV * mask ;
1606        SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1607
1608        if  (old_warnings == pWARN_NONE ||
1609                (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1610            mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1611        else if (old_warnings == pWARN_ALL ||
1612                  (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1613            mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1614        else
1615            mask = newSVsv(old_warnings);
1616        PUSHs(sv_2mortal(mask));
1617    }
1618    RETURN;
1619}
1620
1621PP(pp_reset)
1622{
1623    dSP;
1624    char *tmps;
1625    STRLEN n_a;
1626
1627    if (MAXARG < 1)
1628        tmps = "";
1629    else
1630        tmps = POPpx;
1631    sv_reset(tmps, CopSTASH(PL_curcop));
1632    PUSHs(&PL_sv_yes);
1633    RETURN;
1634}
1635
1636PP(pp_lineseq)
1637{
1638    return NORMAL;
1639}
1640
1641PP(pp_dbstate)
1642{
1643    PL_curcop = (COP*)PL_op;
1644    TAINT_NOT;          /* Each statement is presumed innocent */
1645    PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1646    FREETMPS;
1647
1648    if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1649    {
1650        dSP;
1651        register CV *cv;
1652        register PERL_CONTEXT *cx;
1653        I32 gimme = G_ARRAY;
1654        I32 hasargs;
1655        GV *gv;
1656
1657        gv = PL_DBgv;
1658        cv = GvCV(gv);
1659        if (!cv)
1660            DIE(aTHX_ "No DB::DB routine defined");
1661
1662        if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1663            return NORMAL;
1664
1665        ENTER;
1666        SAVETMPS;
1667
1668        SAVEI32(PL_debug);
1669        SAVESTACK_POS();
1670        PL_debug = 0;
1671        hasargs = 0;
1672        SPAGAIN;
1673
1674        push_return(PL_op->op_next);
1675        PUSHBLOCK(cx, CXt_SUB, SP);
1676        PUSHSUB(cx);
1677        CvDEPTH(cv)++;
1678        (void)SvREFCNT_inc(cv);
1679        SAVEVPTR(PL_curpad);
1680        PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1681        RETURNOP(CvSTART(cv));
1682    }
1683    else
1684        return NORMAL;
1685}
1686
1687PP(pp_scope)
1688{
1689    return NORMAL;
1690}
1691
1692PP(pp_enteriter)
1693{
1694    dSP; dMARK;
1695    register PERL_CONTEXT *cx;
1696    I32 gimme = GIMME_V;
1697    SV **svp;
1698    U32 cxtype = CXt_LOOP;
1699#ifdef USE_ITHREADS
1700    void *iterdata;
1701#endif
1702
1703    ENTER;
1704    SAVETMPS;
1705
1706#ifdef USE_THREADS
1707    if (PL_op->op_flags & OPf_SPECIAL) {
1708        svp = &THREADSV(PL_op->op_targ);        /* per-thread variable */
1709        SAVEGENERICSV(*svp);
1710        *svp = NEWSV(0,0);
1711    }
1712    else
1713#endif /* USE_THREADS */
1714    if (PL_op->op_targ) {
1715#ifndef USE_ITHREADS
1716        svp = &PL_curpad[PL_op->op_targ];               /* "my" variable */
1717        SAVESPTR(*svp);
1718#else
1719        SAVEPADSV(PL_op->op_targ);
1720        iterdata = (void*)PL_op->op_targ;
1721        cxtype |= CXp_PADVAR;
1722#endif
1723    }
1724    else {
1725        GV *gv = (GV*)POPs;
1726        svp = &GvSV(gv);                        /* symbol table variable */
1727        SAVEGENERICSV(*svp);
1728        *svp = NEWSV(0,0);
1729#ifdef USE_ITHREADS
1730        iterdata = (void*)gv;
1731#endif
1732    }
1733
1734    ENTER;
1735
1736    PUSHBLOCK(cx, cxtype, SP);
1737#ifdef USE_ITHREADS
1738    PUSHLOOP(cx, iterdata, MARK);
1739#else
1740    PUSHLOOP(cx, svp, MARK);
1741#endif
1742    if (PL_op->op_flags & OPf_STACKED) {
1743        cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1744        if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1745            dPOPss;
1746            if (SvNIOKp(sv) || !SvPOKp(sv) ||
1747                SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1748                (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1749                 looks_like_number((SV*)cx->blk_loop.iterary) &&
1750                 *SvPVX(cx->blk_loop.iterary) != '0'))
1751            {
1752                 if (SvNV(sv) < IV_MIN ||
1753                     SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1754                     DIE(aTHX_ "Range iterator outside integer range");
1755                 cx->blk_loop.iterix = SvIV(sv);
1756                 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1757            }
1758            else
1759                cx->blk_loop.iterlval = newSVsv(sv);
1760        }
1761    }
1762    else {
1763        cx->blk_loop.iterary = PL_curstack;
1764        AvFILLp(PL_curstack) = SP - PL_stack_base;
1765        cx->blk_loop.iterix = MARK - PL_stack_base;
1766    }
1767
1768    RETURN;
1769}
1770
1771PP(pp_enterloop)
1772{
1773    dSP;
1774    register PERL_CONTEXT *cx;
1775    I32 gimme = GIMME_V;
1776
1777    ENTER;
1778    SAVETMPS;
1779    ENTER;
1780
1781    PUSHBLOCK(cx, CXt_LOOP, SP);
1782    PUSHLOOP(cx, 0, SP);
1783
1784    RETURN;
1785}
1786
1787PP(pp_leaveloop)
1788{
1789    dSP;
1790    register PERL_CONTEXT *cx;
1791    I32 gimme;
1792    SV **newsp;
1793    PMOP *newpm;
1794    SV **mark;
1795
1796    POPBLOCK(cx,newpm);
1797    mark = newsp;
1798    newsp = PL_stack_base + cx->blk_loop.resetsp;
1799
1800    TAINT_NOT;
1801    if (gimme == G_VOID)
1802        ; /* do nothing */
1803    else if (gimme == G_SCALAR) {
1804        if (mark < SP)
1805            *++newsp = sv_mortalcopy(*SP);
1806        else
1807            *++newsp = &PL_sv_undef;
1808    }
1809    else {
1810        while (mark < SP) {
1811            *++newsp = sv_mortalcopy(*++mark);
1812            TAINT_NOT;          /* Each item is independent */
1813        }
1814    }
1815    SP = newsp;
1816    PUTBACK;
1817
1818    POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1819    PL_curpm = newpm;   /* ... and pop $1 et al */
1820
1821    LEAVE;
1822    LEAVE;
1823
1824    return NORMAL;
1825}
1826
1827PP(pp_return)
1828{
1829    dSP; dMARK;
1830    I32 cxix;
1831    register PERL_CONTEXT *cx;
1832    bool popsub2 = FALSE;
1833    bool clear_errsv = FALSE;
1834    I32 gimme;
1835    SV **newsp;
1836    PMOP *newpm;
1837    I32 optype = 0;
1838    SV *sv;
1839
1840    if (PL_curstackinfo->si_type == PERLSI_SORT) {
1841        if (cxstack_ix == PL_sortcxix
1842            || dopoptosub(cxstack_ix) <= PL_sortcxix)
1843        {
1844            if (cxstack_ix > PL_sortcxix)
1845                dounwind(PL_sortcxix);
1846            AvARRAY(PL_curstack)[1] = *SP;
1847            PL_stack_sp = PL_stack_base + 1;
1848            return 0;
1849        }
1850    }
1851
1852    cxix = dopoptosub(cxstack_ix);
1853    if (cxix < 0)
1854        DIE(aTHX_ "Can't return outside a subroutine");
1855    if (cxix < cxstack_ix)
1856        dounwind(cxix);
1857
1858    POPBLOCK(cx,newpm);
1859    switch (CxTYPE(cx)) {
1860    case CXt_SUB:
1861        popsub2 = TRUE;
1862        break;
1863    case CXt_EVAL:
1864        if (!(PL_in_eval & EVAL_KEEPERR))
1865            clear_errsv = TRUE;
1866        POPEVAL(cx);
1867        if (CxTRYBLOCK(cx))
1868            break;
1869        lex_end();
1870        if (optype == OP_REQUIRE &&
1871            (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1872        {
1873            /* Unassume the success we assumed earlier. */
1874            SV *nsv = cx->blk_eval.old_namesv;
1875            (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1876            DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1877        }
1878        break;
1879    case CXt_FORMAT:
1880        POPFORMAT(cx);
1881        break;
1882    default:
1883        DIE(aTHX_ "panic: return");
1884    }
1885
1886    TAINT_NOT;
1887    if (gimme == G_SCALAR) {
1888        if (MARK < SP) {
1889            if (popsub2) {
1890                if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1891                    if (SvTEMP(TOPs)) {
1892                        *++newsp = SvREFCNT_inc(*SP);
1893                        FREETMPS;
1894                        sv_2mortal(*newsp);
1895                    }
1896                    else {
1897                        sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1898                        FREETMPS;
1899                        *++newsp = sv_mortalcopy(sv);
1900                        SvREFCNT_dec(sv);
1901                    }
1902                }
1903                else
1904                    *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1905            }
1906            else
1907                *++newsp = sv_mortalcopy(*SP);
1908        }
1909        else
1910            *++newsp = &PL_sv_undef;
1911    }
1912    else if (gimme == G_ARRAY) {
1913        while (++MARK <= SP) {
1914            *++newsp = (popsub2 && SvTEMP(*MARK))
1915                        ? *MARK : sv_mortalcopy(*MARK);
1916            TAINT_NOT;          /* Each item is independent */
1917        }
1918    }
1919    PL_stack_sp = newsp;
1920
1921    /* Stack values are safe: */
1922    if (popsub2) {
1923        POPSUB(cx,sv);  /* release CV and @_ ... */
1924    }
1925    else
1926        sv = Nullsv;
1927    PL_curpm = newpm;   /* ... and pop $1 et al */
1928
1929    LEAVE;
1930    LEAVESUB(sv);
1931    if (clear_errsv)
1932        sv_setpv(ERRSV,"");
1933    return pop_return();
1934}
1935
1936PP(pp_last)
1937{
1938    dSP;
1939    I32 cxix;
1940    register PERL_CONTEXT *cx;
1941    I32 pop2 = 0;
1942    I32 gimme;
1943    I32 optype;
1944    OP *nextop;
1945    SV **newsp;
1946    PMOP *newpm;
1947    SV **mark;
1948    SV *sv = Nullsv;
1949
1950    if (PL_op->op_flags & OPf_SPECIAL) {
1951        cxix = dopoptoloop(cxstack_ix);
1952        if (cxix < 0)
1953            DIE(aTHX_ "Can't \"last\" outside a loop block");
1954    }
1955    else {
1956        cxix = dopoptolabel(cPVOP->op_pv);
1957        if (cxix < 0)
1958            DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1959    }
1960    if (cxix < cxstack_ix)
1961        dounwind(cxix);
1962
1963    POPBLOCK(cx,newpm);
1964    mark = newsp;
1965    switch (CxTYPE(cx)) {
1966    case CXt_LOOP:
1967        pop2 = CXt_LOOP;
1968        newsp = PL_stack_base + cx->blk_loop.resetsp;
1969        nextop = cx->blk_loop.last_op->op_next;
1970        break;
1971    case CXt_SUB:
1972        pop2 = CXt_SUB;
1973        nextop = pop_return();
1974        break;
1975    case CXt_EVAL:
1976        POPEVAL(cx);
1977        nextop = pop_return();
1978        break;
1979    case CXt_FORMAT:
1980        POPFORMAT(cx);
1981        nextop = pop_return();
1982        break;
1983    default:
1984        DIE(aTHX_ "panic: last");
1985    }
1986
1987    TAINT_NOT;
1988    if (gimme == G_SCALAR) {
1989        if (MARK < SP)
1990            *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1991                        ? *SP : sv_mortalcopy(*SP);
1992        else
1993            *++newsp = &PL_sv_undef;
1994    }
1995    else if (gimme == G_ARRAY) {
1996        while (++MARK <= SP) {
1997            *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1998                        ? *MARK : sv_mortalcopy(*MARK);
1999            TAINT_NOT;          /* Each item is independent */
2000        }
2001    }
2002    SP = newsp;
2003    PUTBACK;
2004
2005    /* Stack values are safe: */
2006    switch (pop2) {
2007    case CXt_LOOP:
2008        POPLOOP(cx);    /* release loop vars ... */
2009        LEAVE;
2010        break;
2011    case CXt_SUB:
2012        POPSUB(cx,sv);  /* release CV and @_ ... */
2013        break;
2014    }
2015    PL_curpm = newpm;   /* ... and pop $1 et al */
2016
2017    LEAVE;
2018    LEAVESUB(sv);
2019    return nextop;
2020}
2021
2022PP(pp_next)
2023{
2024    I32 cxix;
2025    register PERL_CONTEXT *cx;
2026    I32 inner;
2027
2028    if (PL_op->op_flags & OPf_SPECIAL) {
2029        cxix = dopoptoloop(cxstack_ix);
2030        if (cxix < 0)
2031            DIE(aTHX_ "Can't \"next\" outside a loop block");
2032    }
2033    else {
2034        cxix = dopoptolabel(cPVOP->op_pv);
2035        if (cxix < 0)
2036            DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2037    }
2038    if (cxix < cxstack_ix)
2039        dounwind(cxix);
2040
2041    /* clear off anything above the scope we're re-entering, but
2042     * save the rest until after a possible continue block */
2043    inner = PL_scopestack_ix;
2044    TOPBLOCK(cx);
2045    if (PL_scopestack_ix < inner)
2046        leave_scope(PL_scopestack[PL_scopestack_ix]);
2047    return cx->blk_loop.next_op;
2048}
2049
2050PP(pp_redo)
2051{
2052    I32 cxix;
2053    register PERL_CONTEXT *cx;
2054    I32 oldsave;
2055
2056    if (PL_op->op_flags & OPf_SPECIAL) {
2057        cxix = dopoptoloop(cxstack_ix);
2058        if (cxix < 0)
2059            DIE(aTHX_ "Can't \"redo\" outside a loop block");
2060    }
2061    else {
2062        cxix = dopoptolabel(cPVOP->op_pv);
2063        if (cxix < 0)
2064            DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2065    }
2066    if (cxix < cxstack_ix)
2067        dounwind(cxix);
2068
2069    TOPBLOCK(cx);
2070    oldsave = PL_scopestack[PL_scopestack_ix - 1];
2071    LEAVE_SCOPE(oldsave);
2072    return cx->blk_loop.redo_op;
2073}
2074
2075STATIC OP *
2076S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2077{
2078    OP *kid;
2079    OP **ops = opstack;
2080    static char too_deep[] = "Target of goto is too deeply nested";
2081
2082    if (ops >= oplimit)
2083        Perl_croak(aTHX_ too_deep);
2084    if (o->op_type == OP_LEAVE ||
2085        o->op_type == OP_SCOPE ||
2086        o->op_type == OP_LEAVELOOP ||
2087        o->op_type == OP_LEAVETRY)
2088    {
2089        *ops++ = cUNOPo->op_first;
2090        if (ops >= oplimit)
2091            Perl_croak(aTHX_ too_deep);
2092    }
2093    *ops = 0;
2094    if (o->op_flags & OPf_KIDS) {
2095        /* First try all the kids at this level, since that's likeliest. */
2096        for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2097            if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2098                    kCOP->cop_label && strEQ(kCOP->cop_label, label))
2099                return kid;
2100        }
2101        for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2102            if (kid == PL_lastgotoprobe)
2103                continue;
2104            if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2105                (ops == opstack ||
2106                 (ops[-1]->op_type != OP_NEXTSTATE &&
2107                  ops[-1]->op_type != OP_DBSTATE)))
2108                *ops++ = kid;
2109            if ((o = dofindlabel(kid, label, ops, oplimit)))
2110                return o;
2111        }
2112    }
2113    *ops = 0;
2114    return 0;
2115}
2116
2117PP(pp_dump)
2118{
2119    return pp_goto();
2120    /*NOTREACHED*/
2121}
2122
2123PP(pp_goto)
2124{
2125    dSP;
2126    OP *retop = 0;
2127    I32 ix;
2128    register PERL_CONTEXT *cx;
2129#define GOTO_DEPTH 64
2130    OP *enterops[GOTO_DEPTH];
2131    char *label;
2132    int do_dump = (PL_op->op_type == OP_DUMP);
2133    static char must_have_label[] = "goto must have label";
2134
2135    label = 0;
2136    if (PL_op->op_flags & OPf_STACKED) {
2137        SV *sv = POPs;
2138        STRLEN n_a;
2139
2140        /* This egregious kludge implements goto &subroutine */
2141        if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2142            I32 cxix;
2143            register PERL_CONTEXT *cx;
2144            CV* cv = (CV*)SvRV(sv);
2145            SV** mark;
2146            I32 items = 0;
2147            I32 oldsave;
2148
2149        retry:
2150            if (!CvROOT(cv) && !CvXSUB(cv)) {
2151                GV *gv = CvGV(cv);
2152                GV *autogv;
2153                if (gv) {
2154                    SV *tmpstr;
2155                    /* autoloaded stub? */
2156                    if (cv != GvCV(gv) && (cv = GvCV(gv)))
2157                        goto retry;
2158                    autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2159                                          GvNAMELEN(gv), FALSE);
2160                    if (autogv && (cv = GvCV(autogv)))
2161                        goto retry;
2162                    tmpstr = sv_newmortal();
2163                    gv_efullname3(tmpstr, gv, Nullch);
2164                    DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2165                }
2166                DIE(aTHX_ "Goto undefined subroutine");
2167            }
2168
2169            /* First do some returnish stuff. */
2170            cxix = dopoptosub(cxstack_ix);
2171            if (cxix < 0)
2172                DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2173            if (cxix < cxstack_ix)
2174                dounwind(cxix);
2175            TOPBLOCK(cx);
2176            if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2177                DIE(aTHX_ "Can't goto subroutine from an eval-string");
2178            mark = PL_stack_sp;
2179            if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2180                /* put @_ back onto stack */
2181                AV* av = cx->blk_sub.argarray;
2182               
2183                items = AvFILLp(av) + 1;
2184                PL_stack_sp++;
2185                EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2186                Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2187                PL_stack_sp += items;
2188#ifndef USE_THREADS
2189                SvREFCNT_dec(GvAV(PL_defgv));
2190                GvAV(PL_defgv) = cx->blk_sub.savearray;
2191#endif /* USE_THREADS */
2192                /* abandon @_ if it got reified */
2193                if (AvREAL(av)) {
2194                    (void)sv_2mortal((SV*)av);  /* delay until return */
2195                    av = newAV();
2196                    av_extend(av, items-1);
2197                    AvFLAGS(av) = AVf_REIFY;
2198                    PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2199                }
2200            }
2201            else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2202                AV* av;
2203#ifdef USE_THREADS
2204                av = (AV*)PL_curpad[0];
2205#else
2206                av = GvAV(PL_defgv);
2207#endif
2208                items = AvFILLp(av) + 1;
2209                PL_stack_sp++;
2210                EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2211                Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2212                PL_stack_sp += items;
2213            }
2214            if (CxTYPE(cx) == CXt_SUB &&
2215                !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2216                SvREFCNT_dec(cx->blk_sub.cv);
2217            oldsave = PL_scopestack[PL_scopestack_ix - 1];
2218            LEAVE_SCOPE(oldsave);
2219
2220            /* Now do some callish stuff. */
2221            SAVETMPS;
2222            if (CvXSUB(cv)) {
2223#ifdef PERL_XSUB_OLDSTYLE
2224                if (CvOLDSTYLE(cv)) {
2225                    I32 (*fp3)(int,int,int);
2226                    while (SP > mark) {
2227                        SP[1] = SP[0];
2228                        SP--;
2229                    }
2230                    fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2231                    items = (*fp3)(CvXSUBANY(cv).any_i32,
2232                                   mark - PL_stack_base + 1,
2233                                   items);
2234                    SP = PL_stack_base + items;
2235                }
2236                else
2237#endif /* PERL_XSUB_OLDSTYLE */
2238                {
2239                    SV **newsp;
2240                    I32 gimme;
2241
2242                    PL_stack_sp--;              /* There is no cv arg. */
2243                    /* Push a mark for the start of arglist */
2244                    PUSHMARK(mark);
2245                    (void)(*CvXSUB(cv))(aTHXo_ cv);
2246                    /* Pop the current context like a decent sub should */
2247                    POPBLOCK(cx, PL_curpm);
2248                    /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2249                }
2250                LEAVE;
2251                return pop_return();
2252            }
2253            else {
2254                AV* padlist = CvPADLIST(cv);
2255                SV** svp = AvARRAY(padlist);
2256                if (CxTYPE(cx) == CXt_EVAL) {
2257                    PL_in_eval = cx->blk_eval.old_in_eval;
2258                    PL_eval_root = cx->blk_eval.old_eval_root;
2259                    cx->cx_type = CXt_SUB;
2260                    cx->blk_sub.hasargs = 0;
2261                }
2262                cx->blk_sub.cv = cv;
2263                cx->blk_sub.olddepth = CvDEPTH(cv);
2264                CvDEPTH(cv)++;
2265                if (CvDEPTH(cv) < 2)
2266                    (void)SvREFCNT_inc(cv);
2267                else {  /* save temporaries on recursion? */
2268                    if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2269                        sub_crush_depth(cv);
2270                    if (CvDEPTH(cv) > AvFILLp(padlist)) {
2271                        AV *newpad = newAV();
2272                        SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2273                        I32 ix = AvFILLp((AV*)svp[1]);
2274                        I32 names_fill = AvFILLp((AV*)svp[0]);
2275                        svp = AvARRAY(svp[0]);
2276                        for ( ;ix > 0; ix--) {
2277                            if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2278                                char *name = SvPVX(svp[ix]);
2279                                if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2280                                    || *name == '&')
2281                                {
2282                                    /* outer lexical or anon code */
2283                                    av_store(newpad, ix,
2284                                        SvREFCNT_inc(oldpad[ix]) );
2285                                }
2286                                else {          /* our own lexical */
2287                                    if (*name == '@')
2288                                        av_store(newpad, ix, sv = (SV*)newAV());
2289                                    else if (*name == '%')
2290                                        av_store(newpad, ix, sv = (SV*)newHV());
2291                                    else
2292                                        av_store(newpad, ix, sv = NEWSV(0,0));
2293                                    SvPADMY_on(sv);
2294                                }
2295                            }
2296                            else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2297                                av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2298                            }
2299                            else {
2300                                av_store(newpad, ix, sv = NEWSV(0,0));
2301                                SvPADTMP_on(sv);
2302                            }
2303                        }
2304                        if (cx->blk_sub.hasargs) {
2305                            AV* av = newAV();
2306                            av_extend(av, 0);
2307                            av_store(newpad, 0, (SV*)av);
2308                            AvFLAGS(av) = AVf_REIFY;
2309                        }
2310                        av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2311                        AvFILLp(padlist) = CvDEPTH(cv);
2312                        svp = AvARRAY(padlist);
2313                    }
2314                }
2315#ifdef USE_THREADS
2316                if (!cx->blk_sub.hasargs) {
2317                    AV* av = (AV*)PL_curpad[0];
2318                   
2319                    items = AvFILLp(av) + 1;
2320                    if (items) {
2321                        /* Mark is at the end of the stack. */
2322                        EXTEND(SP, items);
2323                        Copy(AvARRAY(av), SP + 1, items, SV*);
2324                        SP += items;
2325                        PUTBACK ;                   
2326                    }
2327                }
2328#endif /* USE_THREADS */               
2329                SAVEVPTR(PL_curpad);
2330                PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2331#ifndef USE_THREADS
2332                if (cx->blk_sub.hasargs)
2333#endif /* USE_THREADS */
2334                {
2335                    AV* av = (AV*)PL_curpad[0];
2336                    SV** ary;
2337
2338#ifndef USE_THREADS
2339                    cx->blk_sub.savearray = GvAV(PL_defgv);
2340                    GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2341#endif /* USE_THREADS */
2342                    cx->blk_sub.oldcurpad = PL_curpad;
2343                    cx->blk_sub.argarray = av;
2344                    ++mark;
2345
2346                    if (items >= AvMAX(av) + 1) {
2347                        ary = AvALLOC(av);
2348                        if (AvARRAY(av) != ary) {
2349                            AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2350                            SvPVX(av) = (char*)ary;
2351                        }
2352                        if (items >= AvMAX(av) + 1) {
2353                            AvMAX(av) = items - 1;
2354                            Renew(ary,items+1,SV*);
2355                            AvALLOC(av) = ary;
2356                            SvPVX(av) = (char*)ary;
2357                        }
2358                    }
2359                    Copy(mark,AvARRAY(av),items,SV*);
2360                    AvFILLp(av) = items - 1;
2361                    assert(!AvREAL(av));
2362                    while (items--) {
2363                        if (*mark)
2364                            SvTEMP_off(*mark);
2365                        mark++;
2366                    }
2367                }
2368                if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2369                    /*
2370                     * We do not care about using sv to call CV;
2371                     * it's for informational purposes only.
2372                     */
2373                    SV *sv = GvSV(PL_DBsub);
2374                    CV *gotocv;
2375                   
2376                    if (PERLDB_SUB_NN) {
2377                        SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2378                    } else {
2379                        save_item(sv);
2380                        gv_efullname3(sv, CvGV(cv), Nullch);
2381                    }
2382                    if (  PERLDB_GOTO
2383                          && (gotocv = get_cv("DB::goto", FALSE)) ) {
2384                        PUSHMARK( PL_stack_sp );
2385                        call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2386                        PL_stack_sp--;
2387                    }
2388                }
2389                RETURNOP(CvSTART(cv));
2390            }
2391        }
2392        else {
2393            label = SvPV(sv,n_a);
2394            if (!(do_dump || *label))
2395                DIE(aTHX_ must_have_label);
2396        }
2397    }
2398    else if (PL_op->op_flags & OPf_SPECIAL) {
2399        if (! do_dump)
2400            DIE(aTHX_ must_have_label);
2401    }
2402    else
2403        label = cPVOP->op_pv;
2404
2405    if (label && *label) {
2406        OP *gotoprobe = 0;
2407
2408        /* find label */
2409
2410        PL_lastgotoprobe = 0;
2411        *enterops = 0;
2412        for (ix = cxstack_ix; ix >= 0; ix--) {
2413            cx = &cxstack[ix];
2414            switch (CxTYPE(cx)) {
2415            case CXt_EVAL:
2416                gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2417                break;
2418            case CXt_LOOP:
2419                gotoprobe = cx->blk_oldcop->op_sibling;
2420                break;
2421            case CXt_SUBST:
2422                continue;
2423            case CXt_BLOCK:
2424                if (ix)
2425                    gotoprobe = cx->blk_oldcop->op_sibling;
2426                else
2427                    gotoprobe = PL_main_root;
2428                break;
2429            case CXt_SUB:
2430                if (CvDEPTH(cx->blk_sub.cv)) {
2431                    gotoprobe = CvROOT(cx->blk_sub.cv);
2432                    break;
2433                }
2434                /* FALL THROUGH */
2435            case CXt_FORMAT:
2436            case CXt_NULL:
2437                DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2438            default:
2439                if (ix)
2440                    DIE(aTHX_ "panic: goto");
2441                gotoprobe = PL_main_root;
2442                break;
2443            }
2444            if (gotoprobe) {
2445                retop = dofindlabel(gotoprobe, label,
2446                                    enterops, enterops + GOTO_DEPTH);
2447                if (retop)
2448                    break;
2449            }
2450            PL_lastgotoprobe = gotoprobe;
2451        }
2452        if (!retop)
2453            DIE(aTHX_ "Can't find label %s", label);
2454
2455        /* pop unwanted frames */
2456
2457        if (ix < cxstack_ix) {
2458            I32 oldsave;
2459
2460            if (ix < 0)
2461                ix = 0;
2462            dounwind(ix);
2463            TOPBLOCK(cx);
2464            oldsave = PL_scopestack[PL_scopestack_ix];
2465            LEAVE_SCOPE(oldsave);
2466        }
2467
2468        /* push wanted frames */
2469
2470        if (*enterops && enterops[1]) {
2471            OP *oldop = PL_op;
2472            for (ix = 1; enterops[ix]; ix++) {
2473                PL_op = enterops[ix];
2474                /* Eventually we may want to stack the needed arguments
2475                 * for each op.  For now, we punt on the hard ones. */
2476                if (PL_op->op_type == OP_ENTERITER)
2477                    DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2478                CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2479            }
2480            PL_op = oldop;
2481        }
2482    }
2483
2484    if (do_dump) {
2485#ifdef VMS
2486        if (!retop) retop = PL_main_start;
2487#endif
2488        PL_restartop = retop;
2489        PL_do_undump = TRUE;
2490
2491        my_unexec();
2492
2493        PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2494        PL_do_undump = FALSE;
2495    }
2496
2497    RETURNOP(retop);
2498}
2499
2500PP(pp_exit)
2501{
2502    dSP;
2503    I32 anum;
2504
2505    if (MAXARG < 1)
2506        anum = 0;
2507    else {
2508        anum = SvIVx(POPs);
2509#ifdef VMS
2510        if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2511            anum = 0;
2512#endif
2513    }
2514    PL_exit_flags |= PERL_EXIT_EXPECTED;
2515    my_exit(anum);
2516    PUSHs(&PL_sv_undef);
2517    RETURN;
2518}
2519
2520#ifdef NOTYET
2521PP(pp_nswitch)
2522{
2523    dSP;
2524    NV value = SvNVx(GvSV(cCOP->cop_gv));
2525    register I32 match = I_32(value);
2526
2527    if (value < 0.0) {
2528        if (((NV)match) > value)
2529            --match;            /* was fractional--truncate other way */
2530    }
2531    match -= cCOP->uop.scop.scop_offset;
2532    if (match < 0)
2533        match = 0;
2534    else if (match > cCOP->uop.scop.scop_max)
2535        match = cCOP->uop.scop.scop_max;
2536    PL_op = cCOP->uop.scop.scop_next[match];
2537    RETURNOP(PL_op);
2538}
2539
2540PP(pp_cswitch)
2541{
2542    dSP;
2543    register I32 match;
2544
2545    if (PL_multiline)
2546        PL_op = PL_op->op_next;                 /* can't assume anything */
2547    else {
2548        STRLEN n_a;
2549        match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2550        match -= cCOP->uop.scop.scop_offset;
2551        if (match < 0)
2552            match = 0;
2553        else if (match > cCOP->uop.scop.scop_max)
2554            match = cCOP->uop.scop.scop_max;
2555        PL_op = cCOP->uop.scop.scop_next[match];
2556    }
2557    RETURNOP(PL_op);
2558}
2559#endif
2560
2561/* Eval. */
2562
2563STATIC void
2564S_save_lines(pTHX_ AV *array, SV *sv)
2565{
2566    register char *s = SvPVX(sv);
2567    register char *send = SvPVX(sv) + SvCUR(sv);
2568    register char *t;
2569    register I32 line = 1;
2570
2571    while (s && s < send) {
2572        SV *tmpstr = NEWSV(85,0);
2573
2574        sv_upgrade(tmpstr, SVt_PVMG);
2575        t = strchr(s, '\n');
2576        if (t)
2577            t++;
2578        else
2579            t = send;
2580
2581        sv_setpvn(tmpstr, s, t - s);
2582        av_store(array, line++, tmpstr);
2583        s = t;
2584    }
2585}
2586
2587#ifdef PERL_FLEXIBLE_EXCEPTIONS
2588STATIC void *
2589S_docatch_body(pTHX_ va_list args)
2590{
2591    return docatch_body();
2592}
2593#endif
2594
2595STATIC void *
2596S_docatch_body(pTHX)
2597{
2598    CALLRUNOPS(aTHX);
2599    return NULL;
2600}
2601
2602STATIC OP *
2603S_docatch(pTHX_ OP *o)
2604{
2605    int ret;
2606    OP *oldop = PL_op;
2607    volatile PERL_SI *cursi = PL_curstackinfo;
2608    dJMPENV;
2609
2610#ifdef DEBUGGING
2611    assert(CATCH_GET == TRUE);
2612#endif
2613    PL_op = o;
2614#ifdef PERL_FLEXIBLE_EXCEPTIONS
2615 redo_body:
2616    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2617#else
2618    JMPENV_PUSH(ret);
2619#endif
2620    switch (ret) {
2621    case 0:
2622#ifndef PERL_FLEXIBLE_EXCEPTIONS
2623 redo_body:
2624        docatch_body();
2625#endif
2626        break;
2627    case 3:
2628        if (PL_restartop && cursi == PL_curstackinfo) {
2629            PL_op = PL_restartop;
2630            PL_restartop = 0;
2631            goto redo_body;
2632        }
2633        /* FALL THROUGH */
2634    default:
2635        JMPENV_POP;
2636        PL_op = oldop;
2637        JMPENV_JUMP(ret);
2638        /* NOTREACHED */
2639    }
2640    JMPENV_POP;
2641    PL_op = oldop;
2642    return Nullop;
2643}
2644
2645OP *
2646Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2647/* sv Text to convert to OP tree. */
2648/* startop op_free() this to undo. */
2649/* code Short string id of the caller. */
2650{
2651    dSP;                                /* Make POPBLOCK work. */
2652    PERL_CONTEXT *cx;
2653    SV **newsp;
2654    I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2655    I32 optype;
2656    OP dummy;
2657    OP *rop;
2658    char tbuf[TYPE_DIGITS(long) + 12 + 10];
2659    char *tmpbuf = tbuf;
2660    char *safestr;
2661
2662    ENTER;
2663    lex_start(sv);
2664    SAVETMPS;
2665    /* switch to eval mode */
2666
2667    if (PL_curcop == &PL_compiling) {
2668        SAVECOPSTASH_FREE(&PL_compiling);
2669        CopSTASH_set(&PL_compiling, PL_curstash);
2670    }
2671    if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2672        SV *sv = sv_newmortal();
2673        Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2674                       code, (unsigned long)++PL_evalseq,
2675                       CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2676        tmpbuf = SvPVX(sv);
2677    }
2678    else
2679        sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2680    SAVECOPFILE_FREE(&PL_compiling);
2681    CopFILE_set(&PL_compiling, tmpbuf+2);
2682    SAVECOPLINE(&PL_compiling);
2683    CopLINE_set(&PL_compiling, 1);
2684    /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2685       deleting the eval's FILEGV from the stash before gv_check() runs
2686       (i.e. before run-time proper). To work around the coredump that
2687       ensues, we always turn GvMULTI_on for any globals that were
2688       introduced within evals. See force_ident(). GSAR 96-10-12 */
2689    safestr = savepv(tmpbuf);
2690    SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2691    SAVEHINTS();
2692#ifdef OP_IN_REGISTER
2693    PL_opsave = op;
2694#else
2695    SAVEVPTR(PL_op);
2696#endif
2697    PL_hints = 0;
2698
2699    PL_op = &dummy;
2700    PL_op->op_type = OP_ENTEREVAL;
2701    PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2702    PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2703    PUSHEVAL(cx, 0, Nullgv);
2704    rop = doeval(G_SCALAR, startop);
2705    POPBLOCK(cx,PL_curpm);
2706    POPEVAL(cx);
2707
2708    (*startop)->op_type = OP_NULL;
2709    (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2710    lex_end();
2711    *avp = (AV*)SvREFCNT_inc(PL_comppad);
2712    LEAVE;
2713    if (PL_curcop == &PL_compiling)
2714        PL_compiling.op_private = PL_hints;
2715#ifdef OP_IN_REGISTER
2716    op = PL_opsave;
2717#endif
2718    return rop;
2719}
2720
2721/* With USE_THREADS, eval_owner must be held on entry to doeval */
2722STATIC OP *
2723S_doeval(pTHX_ int gimme, OP** startop)
2724{
2725    dSP;
2726    OP *saveop = PL_op;
2727    CV *caller;
2728    AV* comppadlist;
2729    I32 i;
2730
2731    PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2732                  ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2733                  : EVAL_INEVAL);
2734
2735    PUSHMARK(SP);
2736
2737    /* set up a scratch pad */
2738
2739    SAVEI32(PL_padix);
2740    SAVEVPTR(PL_curpad);
2741    SAVESPTR(PL_comppad);
2742    SAVESPTR(PL_comppad_name);
2743    SAVEI32(PL_comppad_name_fill);
2744    SAVEI32(PL_min_intro_pending);
2745    SAVEI32(PL_max_intro_pending);
2746
2747    caller = PL_compcv;
2748    for (i = cxstack_ix - 1; i >= 0; i--) {
2749        PERL_CONTEXT *cx = &cxstack[i];
2750        if (CxTYPE(cx) == CXt_EVAL)
2751            break;
2752        else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2753            caller = cx->blk_sub.cv;
2754            break;
2755        }
2756    }
2757
2758    SAVESPTR(PL_compcv);
2759    PL_compcv = (CV*)NEWSV(1104,0);
2760    sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2761    CvEVAL_on(PL_compcv);
2762#ifdef USE_THREADS
2763    CvOWNER(PL_compcv) = 0;
2764    New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2765    MUTEX_INIT(CvMUTEXP(PL_compcv));
2766#endif /* USE_THREADS */
2767
2768    PL_comppad = newAV();
2769    av_push(PL_comppad, Nullsv);
2770    PL_curpad = AvARRAY(PL_comppad);
2771    PL_comppad_name = newAV();
2772    PL_comppad_name_fill = 0;
2773    PL_min_intro_pending = 0;
2774    PL_padix = 0;
2775#ifdef USE_THREADS
2776    av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2777    PL_curpad[0] = (SV*)newAV();
2778    SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2779#endif /* USE_THREADS */
2780
2781    comppadlist = newAV();
2782    AvREAL_off(comppadlist);
2783    av_store(comppadlist, 0, (SV*)PL_comppad_name);
2784    av_store(comppadlist, 1, (SV*)PL_comppad);
2785    CvPADLIST(PL_compcv) = comppadlist;
2786
2787    if (!saveop ||
2788        (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2789    {
2790        CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2791    }
2792
2793    SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2794
2795    /* make sure we compile in the right package */
2796
2797    if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2798        SAVESPTR(PL_curstash);
2799        PL_curstash = CopSTASH(PL_curcop);
2800    }
2801    SAVESPTR(PL_beginav);
2802    PL_beginav = newAV();
2803    SAVEFREESV(PL_beginav);
2804    SAVEI32(PL_error_count);
2805
2806    /* try to compile it */
2807
2808    PL_eval_root = Nullop;
2809    PL_error_count = 0;
2810    PL_curcop = &PL_compiling;
2811    PL_curcop->cop_arybase = 0;
2812    SvREFCNT_dec(PL_rs);
2813    PL_rs = newSVpvn("\n", 1);
2814    if (saveop && saveop->op_flags & OPf_SPECIAL)
2815        PL_in_eval |= EVAL_KEEPERR;
2816    else
2817        sv_setpv(ERRSV,"");
2818    if (yyparse() || PL_error_count || !PL_eval_root) {
2819        SV **newsp;
2820        I32 gimme;
2821        PERL_CONTEXT *cx;
2822        I32 optype = 0;                 /* Might be reset by POPEVAL. */
2823        STRLEN n_a;
2824       
2825        PL_op = saveop;
2826        if (PL_eval_root) {
2827            op_free(PL_eval_root);
2828            PL_eval_root = Nullop;
2829        }
2830        SP = PL_stack_base + POPMARK;           /* pop original mark */
2831        if (!startop) {
2832            POPBLOCK(cx,PL_curpm);
2833            POPEVAL(cx);
2834            pop_return();
2835        }
2836        lex_end();
2837        LEAVE;
2838        if (optype == OP_REQUIRE) {
2839            char* msg = SvPVx(ERRSV, n_a);
2840            DIE(aTHX_ "%sCompilation failed in require",
2841                *msg ? msg : "Unknown error\n");
2842        }
2843        else if (startop) {
2844            char* msg = SvPVx(ERRSV, n_a);
2845
2846            POPBLOCK(cx,PL_curpm);
2847            POPEVAL(cx);
2848            Perl_croak(aTHX_ "%sCompilation failed in regexp",
2849                       (*msg ? msg : "Unknown error\n"));
2850        }
2851        SvREFCNT_dec(PL_rs);
2852        PL_rs = SvREFCNT_inc(PL_nrs);
2853#ifdef USE_THREADS
2854        MUTEX_LOCK(&PL_eval_mutex);
2855        PL_eval_owner = 0;
2856        COND_SIGNAL(&PL_eval_cond);
2857        MUTEX_UNLOCK(&PL_eval_mutex);
2858#endif /* USE_THREADS */
2859        RETPUSHUNDEF;
2860    }
2861    SvREFCNT_dec(PL_rs);
2862    PL_rs = SvREFCNT_inc(PL_nrs);
2863    CopLINE_set(&PL_compiling, 0);
2864    if (startop) {
2865        *startop = PL_eval_root;
2866        SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2867        CvOUTSIDE(PL_compcv) = Nullcv;
2868    } else
2869        SAVEFREEOP(PL_eval_root);
2870    if (gimme & G_VOID)
2871        scalarvoid(PL_eval_root);
2872    else if (gimme & G_ARRAY)
2873        list(PL_eval_root);
2874    else
2875        scalar(PL_eval_root);
2876
2877    DEBUG_x(dump_eval());
2878
2879    /* Register with debugger: */
2880    if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2881        CV *cv = get_cv("DB::postponed", FALSE);
2882        if (cv) {
2883            dSP;
2884            PUSHMARK(SP);
2885            XPUSHs((SV*)CopFILEGV(&PL_compiling));
2886            PUTBACK;
2887            call_sv((SV*)cv, G_DISCARD);
2888        }
2889    }
2890
2891    /* compiled okay, so do it */
2892
2893    CvDEPTH(PL_compcv) = 1;
2894    SP = PL_stack_base + POPMARK;               /* pop original mark */
2895    PL_op = saveop;                     /* The caller may need it. */
2896    PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2897#ifdef USE_THREADS
2898    MUTEX_LOCK(&PL_eval_mutex);
2899    PL_eval_owner = 0;
2900    COND_SIGNAL(&PL_eval_cond);
2901    MUTEX_UNLOCK(&PL_eval_mutex);
2902#endif /* USE_THREADS */
2903
2904    RETURNOP(PL_eval_start);
2905}
2906
2907STATIC PerlIO *
2908S_doopen_pmc(pTHX_ const char *name, const char *mode)
2909{
2910    STRLEN namelen = strlen(name);
2911    PerlIO *fp;
2912
2913    if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2914        SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2915        char *pmc = SvPV_nolen(pmcsv);
2916        Stat_t pmstat;
2917        Stat_t pmcstat;
2918        if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2919            fp = PerlIO_open(name, mode);
2920        }
2921        else {
2922            if (PerlLIO_stat(name, &pmstat) < 0 ||
2923                pmstat.st_mtime < pmcstat.st_mtime)
2924            {
2925                fp = PerlIO_open(pmc, mode);
2926            }
2927            else {
2928                fp = PerlIO_open(name, mode);
2929            }
2930        }
2931        SvREFCNT_dec(pmcsv);
2932    }
2933    else {
2934        fp = PerlIO_open(name, mode);
2935    }
2936    return fp;
2937}
2938
2939PP(pp_require)
2940{
2941    dSP;
2942    register PERL_CONTEXT *cx;
2943    SV *sv;
2944    char *name;
2945    STRLEN len;
2946    char *tryname;
2947    SV *namesv = Nullsv;
2948    SV** svp;
2949    I32 gimme = G_SCALAR;
2950    PerlIO *tryrsfp = 0;
2951    STRLEN n_a;
2952    int filter_has_file = 0;
2953    GV *filter_child_proc = 0;
2954    SV *filter_state = 0;
2955    SV *filter_sub = 0;
2956
2957    sv = POPs;
2958    if (SvNIOKp(sv)) {
2959        if (SvPOK(sv) && SvNOK(sv)) {           /* require v5.6.1 */
2960            UV rev = 0, ver = 0, sver = 0;
2961            STRLEN len;
2962            U8 *s = (U8*)SvPVX(sv);
2963            U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2964            if (s < end) {
2965                rev = utf8_to_uv(s, end - s, &len, 0);
2966                s += len;
2967                if (s < end) {
2968                    ver = utf8_to_uv(s, end - s, &len, 0);
2969                    s += len;
2970                    if (s < end)
2971                        sver = utf8_to_uv(s, end - s, &len, 0);
2972                }
2973            }
2974            if (PERL_REVISION < rev
2975                || (PERL_REVISION == rev
2976                    && (PERL_VERSION < ver
2977                        || (PERL_VERSION == ver
2978                            && PERL_SUBVERSION < sver))))
2979            {
2980                DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2981                    "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2982                    PERL_VERSION, PERL_SUBVERSION);
2983            }
2984            RETPUSHYES;
2985        }
2986        else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
2987            if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2988                + ((NV)PERL_SUBVERSION/(NV)1000000)
2989                + 0.00000099 < SvNV(sv))
2990            {
2991                NV nrev = SvNV(sv);
2992                UV rev = (UV)nrev;
2993                NV nver = (nrev - rev) * 1000;
2994                UV ver = (UV)(nver + 0.0009);
2995                NV nsver = (nver - ver) * 1000;
2996                UV sver = (UV)(nsver + 0.0009);
2997
2998                /* help out with the "use 5.6" confusion */
2999                if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3000                    DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3001                        "this is only v%d.%d.%d, stopped"
3002                        " (did you mean v%"UVuf".%"UVuf".0?)",
3003                        rev, ver, sver, PERL_REVISION, PERL_VERSION,
3004                        PERL_SUBVERSION, rev, ver/100);
3005                }
3006                else {
3007                    DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3008                        "this is only v%d.%d.%d, stopped",
3009                        rev, ver, sver, PERL_REVISION, PERL_VERSION,
3010                        PERL_SUBVERSION);
3011                }
3012            }
3013            RETPUSHYES;
3014        }
3015    }
3016    name = SvPV(sv, len);
3017    if (!(name && len > 0 && *name))
3018        DIE(aTHX_ "Null filename used");
3019    TAINT_PROPER("require");
3020    if (PL_op->op_type == OP_REQUIRE &&
3021      (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3022      *svp != &PL_sv_undef)
3023        RETPUSHYES;
3024
3025    /* prepare to compile file */
3026
3027#ifdef MACOS_TRADITIONAL
3028    if (PERL_FILE_IS_ABSOLUTE(name)
3029        || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3030    {
3031        tryname = name;
3032        tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3033        /* We consider paths of the form :a:b ambiguous and interpret them first
3034           as global then as local
3035        */
3036        if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
3037            goto trylocal;
3038    }
3039    else
3040trylocal: {
3041#else
3042    if (PERL_FILE_IS_ABSOLUTE(name)
3043        || (*name == '.' && (name[1] == '/' ||
3044                             (name[1] == '.' && name[2] == '/'))))
3045    {
3046        tryname = name;
3047        tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3048    }
3049    else {
3050#endif
3051        AV *ar = GvAVn(PL_incgv);
3052        I32 i;
3053#ifdef VMS
3054        char *unixname;
3055        if ((unixname = tounixspec(name, Nullch)) != Nullch)
3056#endif
3057        {
3058            namesv = NEWSV(806, 0);
3059            for (i = 0; i <= AvFILL(ar); i++) {
3060                SV *dirsv = *av_fetch(ar, i, TRUE);
3061
3062                if (SvROK(dirsv)) {
3063                    int count;
3064                    SV *loader = dirsv;
3065
3066                    if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
3067                        loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3068                    }
3069
3070                    Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3071                                   PTR2UV(SvANY(loader)), name);
3072                    tryname = SvPVX(namesv);
3073                    tryrsfp = 0;
3074
3075                    ENTER;
3076                    SAVETMPS;
3077                    EXTEND(SP, 2);
3078
3079                    PUSHMARK(SP);
3080                    PUSHs(dirsv);
3081                    PUSHs(sv);
3082                    PUTBACK;
3083                    if (sv_isobject(loader))
3084                        count = call_method("INC", G_ARRAY);
3085                    else
3086                        count = call_sv(loader, G_ARRAY);
3087                    SPAGAIN;
3088
3089                    if (count > 0) {
3090                        int i = 0;
3091                        SV *arg;
3092
3093                        SP -= count - 1;
3094                        arg = SP[i++];
3095
3096                        if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3097                            arg = SvRV(arg);
3098                        }
3099
3100                        if (SvTYPE(arg) == SVt_PVGV) {
3101                            IO *io = GvIO((GV *)arg);
3102
3103                            ++filter_has_file;
3104
3105                            if (io) {
3106                                tryrsfp = IoIFP(io);
3107                                if (IoTYPE(io) == IoTYPE_PIPE) {
3108                                    /* reading from a child process doesn't
3109                                       nest -- when returning from reading
3110                                       the inner module, the outer one is
3111                                       unreadable (closed?)  I've tried to
3112                                       save the gv to manage the lifespan of
3113                                       the pipe, but this didn't help. XXX */
3114                                    filter_child_proc = (GV *)arg;
3115                                    (void)SvREFCNT_inc(filter_child_proc);
3116                                }
3117                                else {
3118                                    if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3119                                        PerlIO_close(IoOFP(io));
3120                                    }
3121                                    IoIFP(io) = Nullfp;
3122                                    IoOFP(io) = Nullfp;
3123                                }
3124                            }
3125
3126                            if (i < count) {
3127                                arg = SP[i++];
3128                            }
3129                        }
3130
3131                        if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3132                            filter_sub = arg;
3133                            (void)SvREFCNT_inc(filter_sub);
3134
3135                            if (i < count) {
3136                                filter_state = SP[i];
3137                                (void)SvREFCNT_inc(filter_state);
3138                            }
3139
3140                            if (tryrsfp == 0) {
3141                                tryrsfp = PerlIO_open("/dev/null",
3142                                                      PERL_SCRIPT_MODE);
3143                            }
3144                        }
3145                    }
3146
3147                    PUTBACK;
3148                    FREETMPS;
3149                    LEAVE;
3150
3151                    if (tryrsfp) {
3152                        break;
3153                    }
3154
3155                    filter_has_file = 0;
3156                    if (filter_child_proc) {
3157                        SvREFCNT_dec(filter_child_proc);
3158                        filter_child_proc = 0;
3159                    }
3160                    if (filter_state) {
3161                        SvREFCNT_dec(filter_state);
3162                        filter_state = 0;
3163                    }
3164                    if (filter_sub) {
3165                        SvREFCNT_dec(filter_sub);
3166                        filter_sub = 0;
3167                    }
3168                }
3169                else {
3170                    char *dir = SvPVx(dirsv, n_a);
3171#ifdef MACOS_TRADITIONAL
3172                    char buf[256];
3173                    Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3174#else
3175#ifdef VMS
3176                    char *unixdir;
3177                    if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3178                        continue;
3179                    sv_setpv(namesv, unixdir);
3180                    sv_catpv(namesv, unixname);
3181#else
3182                    Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3183#endif
3184#endif
3185                    TAINT_PROPER("require");
3186                    tryname = SvPVX(namesv);
3187#ifdef MACOS_TRADITIONAL
3188                    {
3189                        /* Convert slashes in the name part, but not the directory part, to colons */
3190                        char * colon;
3191                        for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3192                            *colon++ = ':';
3193                    }
3194#endif
3195                    tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3196                    if (tryrsfp) {
3197                        if (tryname[0] == '.' && tryname[1] == '/')
3198                            tryname += 2;
3199                        break;
3200                    }
3201                }
3202            }
3203        }
3204    }
3205    SAVECOPFILE_FREE(&PL_compiling);
3206    CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3207    SvREFCNT_dec(namesv);
3208    if (!tryrsfp) {
3209        if (PL_op->op_type == OP_REQUIRE) {
3210            char *msgstr = name;
3211            if (namesv) {                       /* did we lookup @INC? */
3212                SV *msg = sv_2mortal(newSVpv(msgstr,0));
3213                SV *dirmsgsv = NEWSV(0, 0);
3214                AV *ar = GvAVn(PL_incgv);
3215                I32 i;
3216                sv_catpvn(msg, " in @INC", 8);
3217                if (instr(SvPVX(msg), ".h "))
3218                    sv_catpv(msg, " (change .h to .ph maybe?)");
3219                if (instr(SvPVX(msg), ".ph "))
3220                    sv_catpv(msg, " (did you run h2ph?)");
3221                sv_catpv(msg, " (@INC contains:");
3222                for (i = 0; i <= AvFILL(ar); i++) {
3223                    char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3224                    Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3225                    sv_catsv(msg, dirmsgsv);
3226                }
3227                sv_catpvn(msg, ")", 1);
3228                SvREFCNT_dec(dirmsgsv);
3229                msgstr = SvPV_nolen(msg);
3230            }
3231            DIE(aTHX_ "Can't locate %s", msgstr);
3232        }
3233
3234        RETPUSHUNDEF;
3235    }
3236    else
3237        SETERRNO(0, SS$_NORMAL);
3238
3239    /* Assume success here to prevent recursive requirement. */
3240    (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
3241                   newSVpv(CopFILE(&PL_compiling), 0), 0 );
3242
3243    ENTER;
3244    SAVETMPS;
3245    lex_start(sv_2mortal(newSVpvn("",0)));
3246    SAVEGENERICSV(PL_rsfp_filters);
3247    PL_rsfp_filters = Nullav;
3248
3249    PL_rsfp = tryrsfp;
3250    SAVEHINTS();
3251    PL_hints = 0;
3252    SAVESPTR(PL_compiling.cop_warnings);
3253    if (PL_dowarn & G_WARN_ALL_ON)
3254        PL_compiling.cop_warnings = pWARN_ALL ;
3255    else if (PL_dowarn & G_WARN_ALL_OFF)
3256        PL_compiling.cop_warnings = pWARN_NONE ;
3257    else
3258        PL_compiling.cop_warnings = pWARN_STD ;
3259
3260    if (filter_sub || filter_child_proc) {
3261        SV *datasv = filter_add(run_user_filter, Nullsv);
3262        IoLINES(datasv) = filter_has_file;
3263        IoFMT_GV(datasv) = (GV *)filter_child_proc;
3264        IoTOP_GV(datasv) = (GV *)filter_state;
3265        IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3266    }
3267
3268    /* switch to eval mode */
3269    push_return(PL_op->op_next);
3270    PUSHBLOCK(cx, CXt_EVAL, SP);
3271    PUSHEVAL(cx, name, Nullgv);
3272
3273    SAVECOPLINE(&PL_compiling);
3274    CopLINE_set(&PL_compiling, 0);
3275
3276    PUTBACK;
3277#ifdef USE_THREADS
3278    MUTEX_LOCK(&PL_eval_mutex);
3279    if (PL_eval_owner && PL_eval_owner != thr)
3280        while (PL_eval_owner)
3281            COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3282    PL_eval_owner = thr;
3283    MUTEX_UNLOCK(&PL_eval_mutex);
3284#endif /* USE_THREADS */
3285    return DOCATCH(doeval(G_SCALAR, NULL));
3286}
3287
3288PP(pp_dofile)
3289{
3290    return pp_require();
3291}
3292
3293PP(pp_entereval)
3294{
3295    dSP;
3296    register PERL_CONTEXT *cx;
3297    dPOPss;
3298    I32 gimme = GIMME_V, was = PL_sub_generation;
3299    char tbuf[TYPE_DIGITS(long) + 12];
3300    char *tmpbuf = tbuf;
3301    char *safestr;
3302    STRLEN len;
3303    OP *ret;
3304
3305    if (!SvPV(sv,len) || !len)
3306        RETPUSHUNDEF;
3307    TAINT_PROPER("eval");
3308
3309    ENTER;
3310    lex_start(sv);
3311    SAVETMPS;
3312 
3313    /* switch to eval mode */
3314
3315    if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3316        SV *sv = sv_newmortal();
3317        Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3318                       (unsigned long)++PL_evalseq,
3319                       CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3320        tmpbuf = SvPVX(sv);
3321    }
3322    else
3323        sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3324    SAVECOPFILE_FREE(&PL_compiling);
3325    CopFILE_set(&PL_compiling, tmpbuf+2);
3326    SAVECOPLINE(&PL_compiling);
3327    CopLINE_set(&PL_compiling, 1);
3328    /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3329       deleting the eval's FILEGV from the stash before gv_check() runs
3330       (i.e. before run-time proper). To work around the coredump that
3331       ensues, we always turn GvMULTI_on for any globals that were
3332       introduced within evals. See force_ident(). GSAR 96-10-12 */
3333    safestr = savepv(tmpbuf);
3334    SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3335    SAVEHINTS();
3336    PL_hints = PL_op->op_targ;
3337    SAVESPTR(PL_compiling.cop_warnings);
3338    if (specialWARN(PL_curcop->cop_warnings))
3339        PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3340    else {
3341        PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3342        SAVEFREESV(PL_compiling.cop_warnings);
3343    }
3344
3345    push_return(PL_op->op_next);
3346    PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3347    PUSHEVAL(cx, 0, Nullgv);
3348
3349    /* prepare to compile string */
3350
3351    if (PERLDB_LINE && PL_curstash != PL_debstash)
3352        save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3353    PUTBACK;
3354#ifdef USE_THREADS
3355    MUTEX_LOCK(&PL_eval_mutex);
3356    if (PL_eval_owner && PL_eval_owner != thr)
3357        while (PL_eval_owner)
3358            COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3359    PL_eval_owner = thr;
3360    MUTEX_UNLOCK(&PL_eval_mutex);
3361#endif /* USE_THREADS */
3362    ret = doeval(gimme, NULL);
3363    if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3364        && ret != PL_op->op_next) {     /* Successive compilation. */
3365        strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3366    }
3367    return DOCATCH(ret);
3368}
3369
3370PP(pp_leaveeval)
3371{
3372    dSP;
3373    register SV **mark;
3374    SV **newsp;
3375    PMOP *newpm;
3376    I32 gimme;
3377    register PERL_CONTEXT *cx;
3378    OP *retop;
3379    U8 save_flags = PL_op -> op_flags;
3380    I32 optype;
3381
3382    POPBLOCK(cx,newpm);
3383    POPEVAL(cx);
3384    retop = pop_return();
3385
3386    TAINT_NOT;
3387    if (gimme == G_VOID)
3388        MARK = newsp;
3389    else if (gimme == G_SCALAR) {
3390        MARK = newsp + 1;
3391        if (MARK <= SP) {
3392            if (SvFLAGS(TOPs) & SVs_TEMP)
3393                *MARK = TOPs;
3394            else
3395                *MARK = sv_mortalcopy(TOPs);
3396        }
3397        else {
3398            MEXTEND(mark,0);
3399            *MARK = &PL_sv_undef;
3400        }
3401        SP = MARK;
3402    }
3403    else {
3404        /* in case LEAVE wipes old return values */
3405        for (mark = newsp + 1; mark <= SP; mark++) {
3406            if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3407                *mark = sv_mortalcopy(*mark);
3408                TAINT_NOT;      /* Each item is independent */
3409            }
3410        }
3411    }
3412    PL_curpm = newpm;   /* Don't pop $1 et al till now */
3413
3414#ifdef DEBUGGING
3415    assert(CvDEPTH(PL_compcv) == 1);
3416#endif
3417    CvDEPTH(PL_compcv) = 0;
3418    lex_end();
3419
3420    if (optype == OP_REQUIRE &&
3421        !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3422    {
3423        /* Unassume the success we assumed earlier. */
3424        SV *nsv = cx->blk_eval.old_namesv;
3425        (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3426        retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3427        /* die_where() did LEAVE, or we won't be here */
3428    }
3429    else {
3430        LEAVE;
3431        if (!(save_flags & OPf_SPECIAL))
3432            sv_setpv(ERRSV,"");
3433    }
3434
3435    RETURNOP(retop);
3436}
3437
3438PP(pp_entertry)
3439{
3440    dSP;
3441    register PERL_CONTEXT *cx;
3442    I32 gimme = GIMME_V;
3443
3444    ENTER;
3445    SAVETMPS;
3446
3447    push_return(cLOGOP->op_other->op_next);
3448    PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3449    PUSHEVAL(cx, 0, 0);
3450    PL_eval_root = PL_op;               /* Only needed so that goto works right. */
3451
3452    PL_in_eval = EVAL_INEVAL;
3453    sv_setpv(ERRSV,"");
3454    PUTBACK;
3455    return DOCATCH(PL_op->op_next);
3456}
3457
3458PP(pp_leavetry)
3459{
3460    dSP;
3461    register SV **mark;
3462    SV **newsp;
3463    PMOP *newpm;
3464    I32 gimme;
3465    register PERL_CONTEXT *cx;
3466    I32 optype;
3467
3468    POPBLOCK(cx,newpm);
3469    POPEVAL(cx);
3470    pop_return();
3471
3472    TAINT_NOT;
3473    if (gimme == G_VOID)
3474        SP = newsp;
3475    else if (gimme == G_SCALAR) {
3476        MARK = newsp + 1;
3477        if (MARK <= SP) {
3478            if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3479                *MARK = TOPs;
3480            else
3481                *MARK = sv_mortalcopy(TOPs);
3482        }
3483        else {
3484            MEXTEND(mark,0);
3485            *MARK = &PL_sv_undef;
3486        }
3487        SP = MARK;
3488    }
3489    else {
3490        /* in case LEAVE wipes old return values */
3491        for (mark = newsp + 1; mark <= SP; mark++) {
3492            if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3493                *mark = sv_mortalcopy(*mark);
3494                TAINT_NOT;      /* Each item is independent */
3495            }
3496        }
3497    }
3498    PL_curpm = newpm;   /* Don't pop $1 et al till now */
3499
3500    LEAVE;
3501    sv_setpv(ERRSV,"");
3502    RETURN;
3503}
3504
3505STATIC void
3506S_doparseform(pTHX_ SV *sv)
3507{
3508    STRLEN len;
3509    register char *s = SvPV_force(sv, len);
3510    register char *send = s + len;
3511    register char *base;
3512    register I32 skipspaces = 0;
3513    bool noblank;
3514    bool repeat;
3515    bool postspace = FALSE;
3516    U16 *fops;
3517    register U16 *fpc;
3518    U16 *linepc;
3519    register I32 arg;
3520    bool ischop;
3521
3522    if (len == 0)
3523        Perl_croak(aTHX_ "Null picture in formline");
3524   
3525    New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3526    fpc = fops;
3527
3528    if (s < send) {
3529        linepc = fpc;
3530        *fpc++ = FF_LINEMARK;
3531        noblank = repeat = FALSE;
3532        base = s;
3533    }
3534
3535    while (s <= send) {
3536        switch (*s++) {
3537        default:
3538            skipspaces = 0;
3539            continue;
3540
3541        case '~':
3542            if (*s == '~') {
3543                repeat = TRUE;
3544                *s = ' ';
3545            }
3546            noblank = TRUE;
3547            s[-1] = ' ';
3548            /* FALL THROUGH */
3549        case ' ': case '\t':
3550            skipspaces++;
3551            continue;
3552           
3553        case '\n': case 0:
3554            arg = s - base;
3555            skipspaces++;
3556            arg -= skipspaces;
3557            if (arg) {
3558                if (postspace)
3559                    *fpc++ = FF_SPACE;
3560                *fpc++ = FF_LITERAL;
3561                *fpc++ = arg;
3562            }
3563            postspace = FALSE;
3564            if (s <= send)
3565                skipspaces--;
3566            if (skipspaces) {
3567                *fpc++ = FF_SKIP;
3568                *fpc++ = skipspaces;
3569            }
3570            skipspaces = 0;
3571            if (s <= send)
3572                *fpc++ = FF_NEWLINE;
3573            if (noblank) {
3574                *fpc++ = FF_BLANK;
3575                if (repeat)
3576                    arg = fpc - linepc + 1;
3577                else
3578                    arg = 0;
3579                *fpc++ = arg;
3580            }
3581            if (s < send) {
3582                linepc = fpc;
3583                *fpc++ = FF_LINEMARK;
3584                noblank = repeat = FALSE;
3585                base = s;
3586            }
3587            else
3588                s++;
3589            continue;
3590
3591        case '@':
3592        case '^':
3593            ischop = s[-1] == '^';
3594
3595            if (postspace) {
3596                *fpc++ = FF_SPACE;
3597                postspace = FALSE;
3598            }
3599            arg = (s - base) - 1;
3600            if (arg) {
3601                *fpc++ = FF_LITERAL;
3602                *fpc++ = arg;
3603            }
3604
3605            base = s - 1;
3606            *fpc++ = FF_FETCH;
3607            if (*s == '*') {
3608                s++;
3609                *fpc++ = 0;
3610                *fpc++ = FF_LINEGLOB;
3611            }
3612            else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3613                arg = ischop ? 512 : 0;
3614                base = s - 1;
3615                while (*s == '#')
3616                    s++;
3617                if (*s == '.') {
3618                    char *f;
3619                    s++;
3620                    f = s;
3621                    while (*s == '#')
3622                        s++;
3623                    arg |= 256 + (s - f);
3624                }
3625                *fpc++ = s - base;              /* fieldsize for FETCH */
3626                *fpc++ = FF_DECIMAL;
3627                *fpc++ = arg;
3628            }
3629            else {
3630                I32 prespace = 0;
3631                bool ismore = FALSE;
3632
3633                if (*s == '>') {
3634                    while (*++s == '>') ;
3635                    prespace = FF_SPACE;
3636                }
3637                else if (*s == '|') {
3638                    while (*++s == '|') ;
3639                    prespace = FF_HALFSPACE;
3640                    postspace = TRUE;
3641                }
3642                else {
3643                    if (*s == '<')
3644                        while (*++s == '<') ;
3645                    postspace = TRUE;
3646                }
3647                if (*s == '.' && s[1] == '.' && s[2] == '.') {
3648                    s += 3;
3649                    ismore = TRUE;
3650                }
3651                *fpc++ = s - base;              /* fieldsize for FETCH */
3652
3653                *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3654
3655                if (prespace)
3656                    *fpc++ = prespace;
3657                *fpc++ = FF_ITEM;
3658                if (ismore)
3659                    *fpc++ = FF_MORE;
3660                if (ischop)
3661                    *fpc++ = FF_CHOP;
3662            }
3663            base = s;
3664            skipspaces = 0;
3665            continue;
3666        }
3667    }
3668    *fpc++ = FF_END;
3669
3670    arg = fpc - fops;
3671    { /* need to jump to the next word */
3672        int z;
3673        z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3674        SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3675        s = SvPVX(sv) + SvCUR(sv) + z;
3676    }
3677    Copy(fops, s, arg, U16);
3678    Safefree(fops);
3679    sv_magic(sv, Nullsv, 'f', Nullch, 0);
3680    SvCOMPILED_on(sv);
3681}
3682
3683/*
3684 * The rest of this file was derived from source code contributed
3685 * by Tom Horsley.
3686 *
3687 * NOTE: this code was derived from Tom Horsley's qsort replacement
3688 * and should not be confused with the original code.
3689 */
3690
3691/* Copyright (C) Tom Horsley, 1997. All rights reserved.
3692
3693   Permission granted to distribute under the same terms as perl which are
3694   (briefly):
3695
3696    This program is free software; you can redistribute it and/or modify
3697    it under the terms of either:
3698
3699        a) the GNU General Public License as published by the Free
3700        Software Foundation; either version 1, or (at your option) any
3701        later version, or
3702
3703        b) the "Artistic License" which comes with this Kit.
3704
3705   Details on the perl license can be found in the perl source code which
3706   may be located via the www.perl.com web page.
3707
3708   This is the most wonderfulest possible qsort I can come up with (and
3709   still be mostly portable) My (limited) tests indicate it consistently
3710   does about 20% fewer calls to compare than does the qsort in the Visual
3711   C++ library, other vendors may vary.
3712
3713   Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3714   others I invented myself (or more likely re-invented since they seemed
3715   pretty obvious once I watched the algorithm operate for a while).
3716
3717   Most of this code was written while watching the Marlins sweep the Giants
3718   in the 1997 National League Playoffs - no Braves fans allowed to use this
3719   code (just kidding :-).
3720
3721   I realize that if I wanted to be true to the perl tradition, the only
3722   comment in this file would be something like:
3723
3724   ...they shuffled back towards the rear of the line. 'No, not at the
3725   rear!'  the slave-driver shouted. 'Three files up. And stay there...
3726
3727   However, I really needed to violate that tradition just so I could keep
3728   track of what happens myself, not to mention some poor fool trying to
3729   understand this years from now :-).
3730*/
3731
3732/* ********************************************************** Configuration */
3733
3734#ifndef QSORT_ORDER_GUESS
3735#define QSORT_ORDER_GUESS 2     /* Select doubling version of the netBSD trick */
3736#endif
3737
3738/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3739   future processing - a good max upper bound is log base 2 of memory size
3740   (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3741   safely be smaller than that since the program is taking up some space and
3742   most operating systems only let you grab some subset of contiguous
3743   memory (not to mention that you are normally sorting data larger than
3744   1 byte element size :-).
3745*/
3746#ifndef QSORT_MAX_STACK
3747#define QSORT_MAX_STACK 32
3748#endif
3749
3750/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3751   Anything bigger and we use qsort. If you make this too small, the qsort
3752   will probably break (or become less efficient), because it doesn't expect
3753   the middle element of a partition to be the same as the right or left -
3754   you have been warned).
3755*/
3756#ifndef QSORT_BREAK_EVEN
3757#define QSORT_BREAK_EVEN 6
3758#endif
3759
3760/* ************************************************************* Data Types */
3761
3762/* hold left and right index values of a partition waiting to be sorted (the
3763   partition includes both left and right - right is NOT one past the end or
3764   anything like that).
3765*/
3766struct partition_stack_entry {
3767   int left;
3768   int right;
3769#ifdef QSORT_ORDER_GUESS
3770   int qsort_break_even;
3771#endif
3772};
3773
3774/* ******************************************************* Shorthand Macros */
3775
3776/* Note that these macros will be used from inside the qsort function where
3777   we happen to know that the variable 'elt_size' contains the size of an
3778   array element and the variable 'temp' points to enough space to hold a
3779   temp element and the variable 'array' points to the array being sorted
3780   and 'compare' is the pointer to the compare routine.
3781
3782   Also note that there are very many highly architecture specific ways
3783   these might be sped up, but this is simply the most generally portable
3784   code I could think of.
3785*/
3786
3787/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3788*/
3789#define qsort_cmp(elt1, elt2) \
3790   ((*compare)(aTHXo_ array[elt1], array[elt2]))
3791
3792#ifdef QSORT_ORDER_GUESS
3793#define QSORT_NOTICE_SWAP swapped++;
3794#else
3795#define QSORT_NOTICE_SWAP
3796#endif
3797
3798/* swaps contents of array elements elt1, elt2.
3799*/
3800#define qsort_swap(elt1, elt2) \
3801   STMT_START { \
3802      QSORT_NOTICE_SWAP \
3803      temp = array[elt1]; \
3804      array[elt1] = array[elt2]; \
3805      array[elt2] = temp; \
3806   } STMT_END
3807
3808/* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3809   elt3 and elt3 gets elt1.
3810*/
3811#define qsort_rotate(elt1, elt2, elt3) \
3812   STMT_START { \
3813      QSORT_NOTICE_SWAP \
3814      temp = array[elt1]; \
3815      array[elt1] = array[elt2]; \
3816      array[elt2] = array[elt3]; \
3817      array[elt3] = temp; \
3818   } STMT_END
3819
3820/* ************************************************************ Debug stuff */
3821
3822#ifdef QSORT_DEBUG
3823
3824static void
3825break_here()
3826{
3827   return; /* good place to set a breakpoint */
3828}
3829
3830#define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3831
3832static void
3833doqsort_all_asserts(
3834   void * array,
3835   size_t num_elts,
3836   size_t elt_size,
3837   int (*compare)(const void * elt1, const void * elt2),
3838   int pc_left, int pc_right, int u_left, int u_right)
3839{
3840   int i;
3841
3842   qsort_assert(pc_left <= pc_right);
3843   qsort_assert(u_right < pc_left);
3844   qsort_assert(pc_right < u_left);
3845   for (i = u_right + 1; i < pc_left; ++i) {
3846      qsort_assert(qsort_cmp(i, pc_left) < 0);
3847   }
3848   for (i = pc_left; i < pc_right; ++i) {
3849      qsort_assert(qsort_cmp(i, pc_right) == 0);
3850   }
3851   for (i = pc_right + 1; i < u_left; ++i) {
3852      qsort_assert(qsort_cmp(pc_right, i) < 0);
3853   }
3854}
3855
3856#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3857   doqsort_all_asserts(array, num_elts, elt_size, compare, \
3858                 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3859
3860#else
3861
3862#define qsort_assert(t) ((void)0)
3863
3864#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3865
3866#endif
3867
3868/* ****************************************************************** qsort */
3869
3870STATIC void
3871S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
3872{
3873   register SV * temp;
3874
3875   struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3876   int next_stack_entry = 0;
3877
3878   int part_left;
3879   int part_right;
3880#ifdef QSORT_ORDER_GUESS
3881   int qsort_break_even;
3882   int swapped;
3883#endif
3884
3885   /* Make sure we actually have work to do.
3886   */
3887   if (num_elts <= 1) {
3888      return;
3889   }
3890
3891   /* Setup the initial partition definition and fall into the sorting loop
3892   */
3893   part_left = 0;
3894   part_right = (int)(num_elts - 1);
3895#ifdef QSORT_ORDER_GUESS
3896   qsort_break_even = QSORT_BREAK_EVEN;
3897#else
3898#define qsort_break_even QSORT_BREAK_EVEN
3899#endif
3900   for ( ; ; ) {
3901      if ((part_right - part_left) >= qsort_break_even) {
3902         /* OK, this is gonna get hairy, so lets try to document all the
3903            concepts and abbreviations and variables and what they keep
3904            track of:
3905
3906            pc: pivot chunk - the set of array elements we accumulate in the
3907                middle of the partition, all equal in value to the original
3908                pivot element selected. The pc is defined by:
3909
3910                pc_left - the leftmost array index of the pc
3911                pc_right - the rightmost array index of the pc
3912
3913                we start with pc_left == pc_right and only one element
3914                in the pivot chunk (but it can grow during the scan).
3915
3916            u:  uncompared elements - the set of elements in the partition
3917                we have not yet compared to the pivot value. There are two
3918                uncompared sets during the scan - one to the left of the pc
3919                and one to the right.
3920
3921                u_right - the rightmost index of the left side's uncompared set
3922                u_left - the leftmost index of the right side's uncompared set
3923
3924                The leftmost index of the left sides's uncompared set
3925                doesn't need its own variable because it is always defined
3926                by the leftmost edge of the whole partition (part_left). The
3927                same goes for the rightmost edge of the right partition
3928                (part_right).
3929
3930                We know there are no uncompared elements on the left once we
3931                get u_right < part_left and no uncompared elements on the
3932                right once u_left > part_right. When both these conditions
3933                are met, we have completed the scan of the partition.
3934
3935                Any elements which are between the pivot chunk and the
3936                uncompared elements should be less than the pivot value on
3937                the left side and greater than the pivot value on the right
3938                side (in fact, the goal of the whole algorithm is to arrange
3939                for that to be true and make the groups of less-than and
3940                greater-then elements into new partitions to sort again).
3941
3942            As you marvel at the complexity of the code and wonder why it
3943            has to be so confusing. Consider some of the things this level
3944            of confusion brings:
3945
3946            Once I do a compare, I squeeze every ounce of juice out of it. I
3947            never do compare calls I don't have to do, and I certainly never
3948            do redundant calls.
3949
3950            I also never swap any elements unless I can prove there is a
3951            good reason. Many sort algorithms will swap a known value with
3952            an uncompared value just to get things in the right place (or
3953            avoid complexity :-), but that uncompared value, once it gets
3954            compared, may then have to be swapped again. A lot of the
3955            complexity of this code is due to the fact that it never swaps
3956            anything except compared values, and it only swaps them when the
3957            compare shows they are out of position.
3958         */
3959         int pc_left, pc_right;
3960         int u_right, u_left;
3961
3962         int s;
3963
3964         pc_left = ((part_left + part_right) / 2);
3965         pc_right = pc_left;
3966         u_right = pc_left - 1;
3967         u_left = pc_right + 1;
3968
3969         /* Qsort works best when the pivot value is also the median value
3970            in the partition (unfortunately you can't find the median value
3971            without first sorting :-), so to give the algorithm a helping
3972            hand, we pick 3 elements and sort them and use the median value
3973            of that tiny set as the pivot value.
3974
3975            Some versions of qsort like to use the left middle and right as
3976            the 3 elements to sort so they can insure the ends of the
3977            partition will contain values which will stop the scan in the
3978            compare loop, but when you have to call an arbitrarily complex
3979            routine to do a compare, its really better to just keep track of
3980            array index values to know when you hit the edge of the
3981            partition and avoid the extra compare. An even better reason to
3982            avoid using a compare call is the fact that you can drop off the
3983            edge of the array if someone foolishly provides you with an
3984            unstable compare function that doesn't always provide consistent
3985            results.
3986
3987            So, since it is simpler for us to compare the three adjacent
3988            elements in the middle of the partition, those are the ones we
3989            pick here (conveniently pointed at by u_right, pc_left, and
3990            u_left). The values of the left, center, and right elements
3991            are refered to as l c and r in the following comments.
3992         */
3993
3994#ifdef QSORT_ORDER_GUESS
3995         swapped = 0;
3996#endif
3997         s = qsort_cmp(u_right, pc_left);
3998         if (s < 0) {
3999            /* l < c */
4000            s = qsort_cmp(pc_left, u_left);
4001            /* if l < c, c < r - already in order - nothing to do */
4002            if (s == 0) {
4003               /* l < c, c == r - already in order, pc grows */
4004               ++pc_right;
4005               qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4006            } else if (s > 0) {
4007               /* l < c, c > r - need to know more */
4008               s = qsort_cmp(u_right, u_left);
4009               if (s < 0) {
4010                  /* l < c, c > r, l < r - swap c & r to get ordered */
4011                  qsort_swap(pc_left, u_left);
4012                  qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4013               } else if (s == 0) {
4014                  /* l < c, c > r, l == r - swap c&r, grow pc */
4015                  qsort_swap(pc_left, u_left);
4016                  --pc_left;
4017                  qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4018               } else {
4019                  /* l < c, c > r, l > r - make lcr into rlc to get ordered */
4020                  qsort_rotate(pc_left, u_right, u_left);
4021                  qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4022               }
4023            }
4024         } else if (s == 0) {
4025            /* l == c */
4026            s = qsort_cmp(pc_left, u_left);
4027            if (s < 0) {
4028               /* l == c, c < r - already in order, grow pc */
4029               --pc_left;
4030               qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4031            } else if (s == 0) {
4032               /* l == c, c == r - already in order, grow pc both ways */
4033               --pc_left;
4034               ++pc_right;
4035               qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4036            } else {
4037               /* l == c, c > r - swap l & r, grow pc */
4038               qsort_swap(u_right, u_left);
4039               ++pc_right;
4040               qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4041            }
4042         } else {
4043            /* l > c */
4044            s = qsort_cmp(pc_left, u_left);
4045            if (s < 0) {
4046               /* l > c, c < r - need to know more */
4047               s = qsort_cmp(u_right, u_left);
4048               if (s < 0) {
4049                  /* l > c, c < r, l < r - swap l & c to get ordered */
4050                  qsort_swap(u_right, pc_left);
4051                  qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4052               } else if (s == 0) {
4053                  /* l > c, c < r, l == r - swap l & c, grow pc */
4054                  qsort_swap(u_right, pc_left);
4055                  ++pc_right;
4056                  qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4057               } else {
4058                  /* l > c, c < r, l > r - rotate lcr into crl to order */
4059                  qsort_rotate(u_right, pc_left, u_left);
4060                  qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4061               }
4062            } else if (s == 0) {
4063               /* l > c, c == r - swap ends, grow pc */
4064               qsort_swap(u_right, u_left);
4065               --pc_left;
4066               qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4067            } else {
4068               /* l > c, c > r - swap ends to get in order */
4069               qsort_swap(u_right, u_left);
4070               qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
4071            }
4072         }
4073         /* We now know the 3 middle elements have been compared and
4074            arranged in the desired order, so we can shrink the uncompared
4075            sets on both sides
4076         */
4077         --u_right;
4078         ++u_left;
4079         qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4080
4081         /* The above massive nested if was the simple part :-). We now have
4082            the middle 3 elements ordered and we need to scan through the
4083            uncompared sets on either side, swapping elements that are on
4084            the wrong side or simply shuffling equal elements around to get
4085            all equal elements into the pivot chunk.
4086         */
4087
4088         for ( ; ; ) {
4089            int still_work_on_left;
4090            int still_work_on_right;
4091
4092            /* Scan the uncompared values on the left. If I find a value
4093               equal to the pivot value, move it over so it is adjacent to
4094               the pivot chunk and expand the pivot chunk. If I find a value
4095               less than the pivot value, then just leave it - its already
4096               on the correct side of the partition. If I find a greater
4097               value, then stop the scan.
4098            */
4099            while ((still_work_on_left = (u_right >= part_left))) {
4100               s = qsort_cmp(u_right, pc_left);
4101               if (s < 0) {
4102                  --u_right;
4103               } else if (s == 0) {
4104                  --pc_left;
4105                  if (pc_left != u_right) {
4106                     qsort_swap(u_right, pc_left);
4107                  }
4108                  --u_right;
4109               } else {
4110                  break;
4111               }
4112               qsort_assert(u_right < pc_left);
4113               qsort_assert(pc_left <= pc_right);
4114               qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
4115               qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4116            }
4117
4118            /* Do a mirror image scan of uncompared values on the right
4119            */
4120            while ((still_work_on_right = (u_left <= part_right))) {
4121               s = qsort_cmp(pc_right, u_left);
4122               if (s < 0) {
4123                  ++u_left;
4124               } else if (s == 0) {
4125                  ++pc_right;
4126                  if (pc_right != u_left) {
4127                     qsort_swap(pc_right, u_left);
4128                  }
4129                  ++u_left;
4130               } else {
4131                  break;
4132               }
4133               qsort_assert(u_left > pc_right);
4134               qsort_assert(pc_left <= pc_right);
4135               qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
4136               qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4137            }
4138
4139            if (still_work_on_left) {
4140               /* I know I have a value on the left side which needs to be
4141                  on the right side, but I need to know more to decide
4142                  exactly the best thing to do with it.
4143               */
4144               if (still_work_on_right) {
4145                  /* I know I have values on both side which are out of
4146                     position. This is a big win because I kill two birds
4147                     with one swap (so to speak). I can advance the
4148                     uncompared pointers on both sides after swapping both
4149                     of them into the right place.
4150                  */
4151                  qsort_swap(u_right, u_left);
4152                  --u_right;
4153                  ++u_left;
4154                  qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4155               } else {
4156                  /* I have an out of position value on the left, but the
4157                     right is fully scanned, so I "slide" the pivot chunk
4158                     and any less-than values left one to make room for the
4159                     greater value over on the right. If the out of position
4160                     value is immediately adjacent to the pivot chunk (there
4161                     are no less-than values), I can do that with a swap,
4162                     otherwise, I have to rotate one of the less than values
4163                     into the former position of the out of position value
4164                     and the right end of the pivot chunk into the left end
4165                     (got all that?).
4166                  */
4167                  --pc_left;
4168                  if (pc_left == u_right) {
4169                     qsort_swap(u_right, pc_right);
4170                     qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4171                  } else {
4172                     qsort_rotate(u_right, pc_left, pc_right);
4173                     qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4174                  }
4175                  --pc_right;
4176                  --u_right;
4177               }
4178            } else if (still_work_on_right) {
4179               /* Mirror image of complex case above: I have an out of
4180                  position value on the right, but the left is fully
4181                  scanned, so I need to shuffle things around to make room
4182                  for the right value on the left.
4183               */
4184               ++pc_right;
4185               if (pc_right == u_left) {
4186                  qsort_swap(u_left, pc_left);
4187                  qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4188               } else {
4189                  qsort_rotate(pc_right, pc_left, u_left);
4190                  qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4191               }
4192               ++pc_left;
4193               ++u_left;
4194            } else {
4195               /* No more scanning required on either side of partition,
4196                  break out of loop and figure out next set of partitions
4197               */
4198               break;
4199            }
4200         }
4201
4202         /* The elements in the pivot chunk are now in the right place. They
4203            will never move or be compared again. All I have to do is decide
4204            what to do with the stuff to the left and right of the pivot
4205            chunk.
4206
4207            Notes on the QSORT_ORDER_GUESS ifdef code:
4208
4209            1. If I just built these partitions without swapping any (or
4210               very many) elements, there is a chance that the elements are
4211               already ordered properly (being properly ordered will
4212               certainly result in no swapping, but the converse can't be
4213               proved :-).
4214
4215            2. A (properly written) insertion sort will run faster on
4216               already ordered data than qsort will.
4217
4218            3. Perhaps there is some way to make a good guess about
4219               switching to an insertion sort earlier than partition size 6
4220               (for instance - we could save the partition size on the stack
4221               and increase the size each time we find we didn't swap, thus
4222               switching to insertion sort earlier for partitions with a
4223               history of not swapping).
4224
4225            4. Naturally, if I just switch right away, it will make
4226               artificial benchmarks with pure ascending (or descending)
4227               data look really good, but is that a good reason in general?
4228               Hard to say...
4229         */
4230
4231#ifdef QSORT_ORDER_GUESS
4232         if (swapped < 3) {
4233#if QSORT_ORDER_GUESS == 1
4234            qsort_break_even = (part_right - part_left) + 1;
4235#endif
4236#if QSORT_ORDER_GUESS == 2
4237            qsort_break_even *= 2;
4238#endif
4239#if QSORT_ORDER_GUESS == 3
4240            int prev_break = qsort_break_even;
4241            qsort_break_even *= qsort_break_even;
4242            if (qsort_break_even < prev_break) {
4243               qsort_break_even = (part_right - part_left) + 1;
4244            }
4245#endif
4246         } else {
4247            qsort_break_even = QSORT_BREAK_EVEN;
4248         }
4249#endif
4250
4251         if (part_left < pc_left) {
4252            /* There are elements on the left which need more processing.
4253               Check the right as well before deciding what to do.
4254            */
4255            if (pc_right < part_right) {
4256               /* We have two partitions to be sorted. Stack the biggest one
4257                  and process the smallest one on the next iteration. This
4258                  minimizes the stack height by insuring that any additional
4259                  stack entries must come from the smallest partition which
4260                  (because it is smallest) will have the fewest
4261                  opportunities to generate additional stack entries.
4262               */
4263               if ((part_right - pc_right) > (pc_left - part_left)) {
4264                  /* stack the right partition, process the left */
4265                  partition_stack[next_stack_entry].left = pc_right + 1;
4266                  partition_stack[next_stack_entry].right = part_right;
4267#ifdef QSORT_ORDER_GUESS
4268                  partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4269#endif
4270                  part_right = pc_left - 1;
4271               } else {
4272                  /* stack the left partition, process the right */
4273                  partition_stack[next_stack_entry].left = part_left;
4274                  partition_stack[next_stack_entry].right = pc_left - 1;
4275#ifdef QSORT_ORDER_GUESS
4276                  partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4277#endif
4278                  part_left = pc_right + 1;
4279               }
4280               qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4281               ++next_stack_entry;
4282            } else {
4283               /* The elements on the left are the only remaining elements
4284                  that need sorting, arrange for them to be processed as the
4285                  next partition.
4286               */
4287               part_right = pc_left - 1;
4288            }
4289         } else if (pc_right < part_right) {
4290            /* There is only one chunk on the right to be sorted, make it
4291               the new partition and loop back around.
4292            */
4293            part_left = pc_right + 1;
4294         } else {
4295            /* This whole partition wound up in the pivot chunk, so
4296               we need to get a new partition off the stack.
4297            */
4298            if (next_stack_entry == 0) {
4299               /* the stack is empty - we are done */
4300               break;
4301            }
4302            --next_stack_entry;
4303            part_left = partition_stack[next_stack_entry].left;
4304            part_right = partition_stack[next_stack_entry].right;
4305#ifdef QSORT_ORDER_GUESS
4306            qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4307#endif
4308         }
4309      } else {
4310         /* This partition is too small to fool with qsort complexity, just
4311            do an ordinary insertion sort to minimize overhead.
4312         */
4313         int i;
4314         /* Assume 1st element is in right place already, and start checking
4315            at 2nd element to see where it should be inserted.
4316         */
4317         for (i = part_left + 1; i <= part_right; ++i) {
4318            int j;
4319            /* Scan (backwards - just in case 'i' is already in right place)
4320               through the elements already sorted to see if the ith element
4321               belongs ahead of one of them.
4322            */
4323            for (j = i - 1; j >= part_left; --j) {
4324               if (qsort_cmp(i, j) >= 0) {
4325                  /* i belongs right after j
4326                  */
4327                  break;
4328               }
4329            }
4330            ++j;
4331            if (j != i) {
4332               /* Looks like we really need to move some things
4333               */
4334               int k;
4335               temp = array[i];
4336               for (k = i - 1; k >= j; --k)
4337                  array[k + 1] = array[k];
4338               array[j] = temp;
4339            }
4340         }
4341
4342         /* That partition is now sorted, grab the next one, or get out
4343            of the loop if there aren't any more.
4344         */
4345
4346         if (next_stack_entry == 0) {
4347            /* the stack is empty - we are done */
4348            break;
4349         }
4350         --next_stack_entry;
4351         part_left = partition_stack[next_stack_entry].left;
4352         part_right = partition_stack[next_stack_entry].right;
4353#ifdef QSORT_ORDER_GUESS
4354         qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4355#endif
4356      }
4357   }
4358
4359   /* Believe it or not, the array is sorted at this point! */
4360}
4361
4362
4363#ifdef PERL_OBJECT
4364#undef this
4365#define this pPerl
4366#include "XSUB.h"
4367#endif
4368
4369
4370static I32
4371sortcv(pTHXo_ SV *a, SV *b)
4372{
4373    I32 oldsaveix = PL_savestack_ix;
4374    I32 oldscopeix = PL_scopestack_ix;
4375    I32 result;
4376    GvSV(PL_firstgv) = a;
4377    GvSV(PL_secondgv) = b;
4378    PL_stack_sp = PL_stack_base;
4379    PL_op = PL_sortcop;
4380    CALLRUNOPS(aTHX);
4381    if (PL_stack_sp != PL_stack_base + 1)
4382        Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4383    if (!SvNIOKp(*PL_stack_sp))
4384        Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4385    result = SvIV(*PL_stack_sp);
4386    while (PL_scopestack_ix > oldscopeix) {
4387        LEAVE;
4388    }
4389    leave_scope(oldsaveix);
4390    return result;
4391}
4392
4393static I32
4394sortcv_stacked(pTHXo_ SV *a, SV *b)
4395{
4396    I32 oldsaveix = PL_savestack_ix;
4397    I32 oldscopeix = PL_scopestack_ix;
4398    I32 result;
4399    AV *av;
4400
4401#ifdef USE_THREADS
4402    av = (AV*)PL_curpad[0];
4403#else
4404    av = GvAV(PL_defgv);
4405#endif
4406
4407    if (AvMAX(av) < 1) {
4408        SV** ary = AvALLOC(av);
4409        if (AvARRAY(av) != ary) {
4410            AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4411            SvPVX(av) = (char*)ary;
4412        }
4413        if (AvMAX(av) < 1) {
4414            AvMAX(av) = 1;
4415            Renew(ary,2,SV*);
4416            SvPVX(av) = (char*)ary;
4417        }
4418    }
4419    AvFILLp(av) = 1;
4420
4421    AvARRAY(av)[0] = a;
4422    AvARRAY(av)[1] = b;
4423    PL_stack_sp = PL_stack_base;
4424    PL_op = PL_sortcop;
4425    CALLRUNOPS(aTHX);
4426    if (PL_stack_sp != PL_stack_base + 1)
4427        Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4428    if (!SvNIOKp(*PL_stack_sp))
4429        Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4430    result = SvIV(*PL_stack_sp);
4431    while (PL_scopestack_ix > oldscopeix) {
4432        LEAVE;
4433    }
4434    leave_scope(oldsaveix);
4435    return result;
4436}
4437
4438static I32
4439sortcv_xsub(pTHXo_ SV *a, SV *b)
4440{
4441    dSP;
4442    I32 oldsaveix = PL_savestack_ix;
4443    I32 oldscopeix = PL_scopestack_ix;
4444    I32 result;
4445    CV *cv=(CV*)PL_sortcop;
4446
4447    SP = PL_stack_base;
4448    PUSHMARK(SP);
4449    EXTEND(SP, 2);
4450    *++SP = a;
4451    *++SP = b;
4452    PUTBACK;
4453    (void)(*CvXSUB(cv))(aTHXo_ cv);
4454    if (PL_stack_sp != PL_stack_base + 1)
4455        Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4456    if (!SvNIOKp(*PL_stack_sp))
4457        Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4458    result = SvIV(*PL_stack_sp);
4459    while (PL_scopestack_ix > oldscopeix) {
4460        LEAVE;
4461    }
4462    leave_scope(oldsaveix);
4463    return result;
4464}
4465
4466
4467static I32
4468sv_ncmp(pTHXo_ SV *a, SV *b)
4469{
4470    NV nv1 = SvNV(a);
4471    NV nv2 = SvNV(b);
4472    return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4473}
4474
4475static I32
4476sv_i_ncmp(pTHXo_ SV *a, SV *b)
4477{
4478    IV iv1 = SvIV(a);
4479    IV iv2 = SvIV(b);
4480    return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4481}
4482#define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4483          *svp = Nullsv;                                \
4484          if (PL_amagic_generation) { \
4485            if (SvAMAGIC(left)||SvAMAGIC(right))\
4486                *svp = amagic_call(left, \
4487                                   right, \
4488                                   CAT2(meth,_amg), \
4489                                   0); \
4490          } \
4491        } STMT_END
4492
4493static I32
4494amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4495{
4496    SV *tmpsv;
4497    tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4498    if (tmpsv) {
4499        NV d;
4500       
4501        if (SvIOK(tmpsv)) {
4502            I32 i = SvIVX(tmpsv);
4503            if (i > 0)
4504               return 1;
4505            return i? -1 : 0;
4506        }
4507        d = SvNV(tmpsv);
4508        if (d > 0)
4509           return 1;
4510        return d? -1 : 0;
4511     }
4512     return sv_ncmp(aTHXo_ a, b);
4513}
4514
4515static I32
4516amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4517{
4518    SV *tmpsv;
4519    tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4520    if (tmpsv) {
4521        NV d;
4522       
4523        if (SvIOK(tmpsv)) {
4524            I32 i = SvIVX(tmpsv);
4525            if (i > 0)
4526               return 1;
4527            return i? -1 : 0;
4528        }
4529        d = SvNV(tmpsv);
4530        if (d > 0)
4531           return 1;
4532        return d? -1 : 0;
4533    }
4534    return sv_i_ncmp(aTHXo_ a, b);
4535}
4536
4537static I32
4538amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4539{
4540    SV *tmpsv;
4541    tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4542    if (tmpsv) {
4543        NV d;
4544       
4545        if (SvIOK(tmpsv)) {
4546            I32 i = SvIVX(tmpsv);
4547            if (i > 0)
4548               return 1;
4549            return i? -1 : 0;
4550        }
4551        d = SvNV(tmpsv);
4552        if (d > 0)
4553           return 1;
4554        return d? -1 : 0;
4555    }
4556    return sv_cmp(str1, str2);
4557}
4558
4559static I32
4560amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4561{
4562    SV *tmpsv;
4563    tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4564    if (tmpsv) {
4565        NV d;
4566       
4567        if (SvIOK(tmpsv)) {
4568            I32 i = SvIVX(tmpsv);
4569            if (i > 0)
4570               return 1;
4571            return i? -1 : 0;
4572        }
4573        d = SvNV(tmpsv);
4574        if (d > 0)
4575           return 1;
4576        return d? -1 : 0;
4577    }
4578    return sv_cmp_locale(str1, str2);
4579}
4580
4581static I32
4582run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4583{
4584    SV *datasv = FILTER_DATA(idx);
4585    int filter_has_file = IoLINES(datasv);
4586    GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4587    SV *filter_state = (SV *)IoTOP_GV(datasv);
4588    SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4589    int len = 0;
4590
4591    /* I was having segfault trouble under Linux 2.2.5 after a
4592       parse error occured.  (Had to hack around it with a test
4593       for PL_error_count == 0.)  Solaris doesn't segfault --
4594       not sure where the trouble is yet.  XXX */
4595
4596    if (filter_has_file) {
4597        len = FILTER_READ(idx+1, buf_sv, maxlen);
4598    }
4599
4600    if (filter_sub && len >= 0) {
4601        dSP;
4602        int count;
4603
4604        ENTER;
4605        SAVE_DEFSV;
4606        SAVETMPS;
4607        EXTEND(SP, 2);
4608
4609        DEFSV = buf_sv;
4610        PUSHMARK(SP);
4611        PUSHs(sv_2mortal(newSViv(maxlen)));
4612        if (filter_state) {
4613            PUSHs(filter_state);
4614        }
4615        PUTBACK;
4616        count = call_sv(filter_sub, G_SCALAR);
4617        SPAGAIN;
4618
4619        if (count > 0) {
4620            SV *out = POPs;
4621            if (SvOK(out)) {
4622                len = SvIV(out);
4623            }
4624        }
4625
4626        PUTBACK;
4627        FREETMPS;
4628        LEAVE;
4629    }
4630
4631    if (len <= 0) {
4632        IoLINES(datasv) = 0;
4633        if (filter_child_proc) {
4634            SvREFCNT_dec(filter_child_proc);
4635            IoFMT_GV(datasv) = Nullgv;
4636        }
4637        if (filter_state) {
4638            SvREFCNT_dec(filter_state);
4639            IoTOP_GV(datasv) = Nullgv;
4640        }
4641        if (filter_sub) {
4642            SvREFCNT_dec(filter_sub);
4643            IoBOTTOM_GV(datasv) = Nullgv;
4644        }
4645        filter_del(run_user_filter);
4646    }
4647
4648    return len;
4649}
4650
4651#ifdef PERL_OBJECT
4652
4653static I32
4654sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4655{
4656    return sv_cmp_locale(str1, str2);
4657}
4658
4659static I32
4660sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4661{
4662    return sv_cmp(str1, str2);
4663}
4664
4665#endif /* PERL_OBJECT */
Note: See TracBrowser for help on using the repository browser.