This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
71afbda0cb7bcacddff94ccb92c8f19bab95af2a
[perl5.git] / pp_ctl.c
1 /*    pp_ctl.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * Now far ahead the Road has gone,
13  * And I must follow, if I can,
14  * Pursuing it with eager feet,
15  * Until it joins some larger way
16  * Where many paths and errands meet.
17  * And whither then?  I cannot say.
18  */
19
20 /* This file contains control-oriented pp ("push/pop") functions that
21  * execute the opcodes that make up a perl program. A typical pp function
22  * expects to find its arguments on the stack, and usually pushes its
23  * results onto the stack, hence the 'pp' terminology. Each OP structure
24  * contains a pointer to the relevant pp_foo() function.
25  *
26  * Control-oriented means things like pp_enteriter() and pp_next(), which
27  * alter the flow of control of the program.
28  */
29
30
31 #include "EXTERN.h"
32 #define PERL_IN_PP_CTL_C
33 #include "perl.h"
34
35 #ifndef WORD_ALIGN
36 #define WORD_ALIGN sizeof(U32)
37 #endif
38
39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
40
41 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
42
43 PP(pp_wantarray)
44 {
45     dSP;
46     I32 cxix;
47     EXTEND(SP, 1);
48
49     cxix = dopoptosub(cxstack_ix);
50     if (cxix < 0)
51         RETPUSHUNDEF;
52
53     switch (cxstack[cxix].blk_gimme) {
54     case G_ARRAY:
55         RETPUSHYES;
56     case G_SCALAR:
57         RETPUSHNO;
58     default:
59         RETPUSHUNDEF;
60     }
61 }
62
63 PP(pp_regcreset)
64 {
65     /* XXXX Should store the old value to allow for tie/overload - and
66        restore in regcomp, where marked with XXXX. */
67     PL_reginterp_cnt = 0;
68     TAINT_NOT;
69     return NORMAL;
70 }
71
72 PP(pp_regcomp)
73 {
74     dSP;
75     register PMOP *pm = (PMOP*)cLOGOP->op_other;
76     SV *tmpstr;
77     MAGIC *mg = Null(MAGIC*);
78
79     /* prevent recompiling under /o and ithreads. */
80 #if defined(USE_ITHREADS)
81     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
82         if (PL_op->op_flags & OPf_STACKED) {
83             dMARK;
84             SP = MARK;
85         }
86         else
87             (void)POPs;
88         RETURN;
89     }
90 #endif
91     if (PL_op->op_flags & OPf_STACKED) {
92         /* multiple args; concatentate them */
93         dMARK; dORIGMARK;
94         tmpstr = PAD_SV(ARGTARG);
95         sv_setpvn(tmpstr, "", 0);
96         while (++MARK <= SP) {
97             if (PL_amagic_generation) {
98                 SV *sv;
99                 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
100                     (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
101                 {
102                    sv_setsv(tmpstr, sv);
103                    continue;
104                 }
105             }
106             sv_catsv(tmpstr, *MARK);
107         }
108         SvSETMAGIC(tmpstr);
109         SP = ORIGMARK;
110     }
111     else
112         tmpstr = POPs;
113
114     if (SvROK(tmpstr)) {
115         SV *sv = SvRV(tmpstr);
116         if(SvMAGICAL(sv))
117             mg = mg_find(sv, PERL_MAGIC_qr);
118     }
119     if (mg) {
120         regexp * const re = (regexp *)mg->mg_obj;
121         ReREFCNT_dec(PM_GETRE(pm));
122         PM_SETRE(pm, ReREFCNT_inc(re));
123     }
124     else {
125         STRLEN len;
126         const char *t = SvPV_const(tmpstr, len);
127
128         /* Check against the last compiled regexp. */
129         if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
130             PM_GETRE(pm)->prelen != (I32)len ||
131             memNE(PM_GETRE(pm)->precomp, t, len))
132         {
133             if (PM_GETRE(pm)) {
134                 ReREFCNT_dec(PM_GETRE(pm));
135                 PM_SETRE(pm, Null(REGEXP*));    /* crucial if regcomp aborts */
136             }
137             if (PL_op->op_flags & OPf_SPECIAL)
138                 PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
139
140             pm->op_pmflags = pm->op_pmpermflags;        /* reset case sensitivity */
141             if (DO_UTF8(tmpstr))
142                 pm->op_pmdynflags |= PMdf_DYN_UTF8;
143             else {
144                 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
145                 if (pm->op_pmdynflags & PMdf_UTF8)
146                     t = (char*)bytes_to_utf8((U8*)t, &len);
147             }
148             PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
149             if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
150                 Safefree(t);
151             PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
152                                            inside tie/overload accessors.  */
153         }
154     }
155
156 #ifndef INCOMPLETE_TAINTS
157     if (PL_tainting) {
158         if (PL_tainted)
159             pm->op_pmdynflags |= PMdf_TAINTED;
160         else
161             pm->op_pmdynflags &= ~PMdf_TAINTED;
162     }
163 #endif
164
165     if (!PM_GETRE(pm)->prelen && PL_curpm)
166         pm = PL_curpm;
167     else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
168         pm->op_pmflags |= PMf_WHITE;
169     else
170         pm->op_pmflags &= ~PMf_WHITE;
171
172     /* XXX runtime compiled output needs to move to the pad */
173     if (pm->op_pmflags & PMf_KEEP) {
174         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
175 #if !defined(USE_ITHREADS)
176         /* XXX can't change the optree at runtime either */
177         cLOGOP->op_first->op_next = PL_op->op_next;
178 #endif
179     }
180     RETURN;
181 }
182
183 PP(pp_substcont)
184 {
185     dSP;
186     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
187     register PMOP * const pm = (PMOP*) cLOGOP->op_other;
188     register SV * const dstr = cx->sb_dstr;
189     register char *s = cx->sb_s;
190     register char *m = cx->sb_m;
191     char *orig = cx->sb_orig;
192     register REGEXP * const rx = cx->sb_rx;
193     SV *nsv = Nullsv;
194     REGEXP *old = PM_GETRE(pm);
195     if(old != rx) {
196         if(old)
197             ReREFCNT_dec(old);
198         PM_SETRE(pm,rx);
199     }
200
201     rxres_restore(&cx->sb_rxres, rx);
202     RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
203
204     if (cx->sb_iters++) {
205         const I32 saviters = cx->sb_iters;
206         if (cx->sb_iters > cx->sb_maxiters)
207             DIE(aTHX_ "Substitution loop");
208
209         if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
210             cx->sb_rxtainted |= 2;
211         sv_catsv(dstr, POPs);
212
213         /* Are we done */
214         if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
215                                      s == m, cx->sb_targ, NULL,
216                                      ((cx->sb_rflags & REXEC_COPY_STR)
217                                       ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
218                                       : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
219         {
220             SV * const targ = cx->sb_targ;
221
222             assert(cx->sb_strend >= s);
223             if(cx->sb_strend > s) {
224                  if (DO_UTF8(dstr) && !SvUTF8(targ))
225                       sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
226                  else
227                       sv_catpvn(dstr, s, cx->sb_strend - s);
228             }
229             cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
230
231 #ifdef PERL_OLD_COPY_ON_WRITE
232             if (SvIsCOW(targ)) {
233                 sv_force_normal_flags(targ, SV_COW_DROP_PV);
234             } else
235 #endif
236             {
237                 SvPV_free(targ);
238             }
239             SvPV_set(targ, SvPVX(dstr));
240             SvCUR_set(targ, SvCUR(dstr));
241             SvLEN_set(targ, SvLEN(dstr));
242             if (DO_UTF8(dstr))
243                 SvUTF8_on(targ);
244             SvPV_set(dstr, (char*)0);
245             sv_free(dstr);
246
247             TAINT_IF(cx->sb_rxtainted & 1);
248             PUSHs(sv_2mortal(newSViv(saviters - 1)));
249
250             (void)SvPOK_only_UTF8(targ);
251             TAINT_IF(cx->sb_rxtainted);
252             SvSETMAGIC(targ);
253             SvTAINT(targ);
254
255             LEAVE_SCOPE(cx->sb_oldsave);
256             ReREFCNT_dec(rx);
257             POPSUBST(cx);
258             RETURNOP(pm->op_next);
259         }
260         cx->sb_iters = saviters;
261     }
262     if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
263         m = s;
264         s = orig;
265         cx->sb_orig = orig = rx->subbeg;
266         s = orig + (m - s);
267         cx->sb_strend = s + (cx->sb_strend - m);
268     }
269     cx->sb_m = m = rx->startp[0] + orig;
270     if (m > s) {
271         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
272             sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
273         else
274             sv_catpvn(dstr, s, m-s);
275     }
276     cx->sb_s = rx->endp[0] + orig;
277     { /* Update the pos() information. */
278         SV * const sv = cx->sb_targ;
279         MAGIC *mg;
280         I32 i;
281         if (SvTYPE(sv) < SVt_PVMG)
282             SvUPGRADE(sv, SVt_PVMG);
283         if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
284             sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
285             mg = mg_find(sv, PERL_MAGIC_regex_global);
286         }
287         i = m - orig;
288         if (DO_UTF8(sv))
289             sv_pos_b2u(sv, &i);
290         mg->mg_len = i;
291     }
292     if (old != rx)
293         (void)ReREFCNT_inc(rx);
294     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
295     rxres_save(&cx->sb_rxres, rx);
296     RETURNOP(pm->op_pmreplstart);
297 }
298
299 void
300 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
301 {
302     UV *p = (UV*)*rsp;
303     U32 i;
304
305     if (!p || p[1] < rx->nparens) {
306 #ifdef PERL_OLD_COPY_ON_WRITE
307         i = 7 + rx->nparens * 2;
308 #else
309         i = 6 + rx->nparens * 2;
310 #endif
311         if (!p)
312             Newx(p, i, UV);
313         else
314             Renew(p, i, UV);
315         *rsp = (void*)p;
316     }
317
318     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
319     RX_MATCH_COPIED_off(rx);
320
321 #ifdef PERL_OLD_COPY_ON_WRITE
322     *p++ = PTR2UV(rx->saved_copy);
323     rx->saved_copy = Nullsv;
324 #endif
325
326     *p++ = rx->nparens;
327
328     *p++ = PTR2UV(rx->subbeg);
329     *p++ = (UV)rx->sublen;
330     for (i = 0; i <= rx->nparens; ++i) {
331         *p++ = (UV)rx->startp[i];
332         *p++ = (UV)rx->endp[i];
333     }
334 }
335
336 void
337 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
338 {
339     UV *p = (UV*)*rsp;
340     U32 i;
341
342     RX_MATCH_COPY_FREE(rx);
343     RX_MATCH_COPIED_set(rx, *p);
344     *p++ = 0;
345
346 #ifdef PERL_OLD_COPY_ON_WRITE
347     if (rx->saved_copy)
348         SvREFCNT_dec (rx->saved_copy);
349     rx->saved_copy = INT2PTR(SV*,*p);
350     *p++ = 0;
351 #endif
352
353     rx->nparens = *p++;
354
355     rx->subbeg = INT2PTR(char*,*p++);
356     rx->sublen = (I32)(*p++);
357     for (i = 0; i <= rx->nparens; ++i) {
358         rx->startp[i] = (I32)(*p++);
359         rx->endp[i] = (I32)(*p++);
360     }
361 }
362
363 void
364 Perl_rxres_free(pTHX_ void **rsp)
365 {
366     UV * const p = (UV*)*rsp;
367
368     if (p) {
369 #ifdef PERL_POISON
370         void *tmp = INT2PTR(char*,*p);
371         Safefree(tmp);
372         if (*p)
373             Poison(*p, 1, sizeof(*p));
374 #else
375         Safefree(INT2PTR(char*,*p));
376 #endif
377 #ifdef PERL_OLD_COPY_ON_WRITE
378         if (p[1]) {
379             SvREFCNT_dec (INT2PTR(SV*,p[1]));
380         }
381 #endif
382         Safefree(p);
383         *rsp = Null(void*);
384     }
385 }
386
387 PP(pp_formline)
388 {
389     dSP; dMARK; dORIGMARK;
390     register SV * const tmpForm = *++MARK;
391     register U32 *fpc;
392     register char *t;
393     const char *f;
394     register I32 arg;
395     register SV *sv = Nullsv;
396     const char *item = Nullch;
397     I32 itemsize  = 0;
398     I32 fieldsize = 0;
399     I32 lines = 0;
400     bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
401     const char *chophere = Nullch;
402     char *linemark = Nullch;
403     NV value;
404     bool gotsome = FALSE;
405     STRLEN len;
406     const STRLEN fudge = SvPOK(tmpForm)
407                         ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
408     bool item_is_utf8 = FALSE;
409     bool targ_is_utf8 = FALSE;
410     SV * nsv = Nullsv;
411     OP * parseres = 0;
412     const char *fmt;
413     bool oneline;
414
415     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
416         if (SvREADONLY(tmpForm)) {
417             SvREADONLY_off(tmpForm);
418             parseres = doparseform(tmpForm);
419             SvREADONLY_on(tmpForm);
420         }
421         else
422             parseres = doparseform(tmpForm);
423         if (parseres)
424             return parseres;
425     }
426     SvPV_force(PL_formtarget, len);
427     if (DO_UTF8(PL_formtarget))
428         targ_is_utf8 = TRUE;
429     t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
430     t += len;
431     f = SvPV_const(tmpForm, len);
432     /* need to jump to the next word */
433     fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
434
435     for (;;) {
436         DEBUG_f( {
437             const char *name = "???";
438             arg = -1;
439             switch (*fpc) {
440             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
441             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
442             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
443             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
444             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
445
446             case FF_CHECKNL:    name = "CHECKNL";       break;
447             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
448             case FF_SPACE:      name = "SPACE";         break;
449             case FF_HALFSPACE:  name = "HALFSPACE";     break;
450             case FF_ITEM:       name = "ITEM";          break;
451             case FF_CHOP:       name = "CHOP";          break;
452             case FF_LINEGLOB:   name = "LINEGLOB";      break;
453             case FF_NEWLINE:    name = "NEWLINE";       break;
454             case FF_MORE:       name = "MORE";          break;
455             case FF_LINEMARK:   name = "LINEMARK";      break;
456             case FF_END:        name = "END";           break;
457             case FF_0DECIMAL:   name = "0DECIMAL";      break;
458             case FF_LINESNGL:   name = "LINESNGL";      break;
459             }
460             if (arg >= 0)
461                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
462             else
463                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
464         } );
465         switch (*fpc++) {
466         case FF_LINEMARK:
467             linemark = t;
468             lines++;
469             gotsome = FALSE;
470             break;
471
472         case FF_LITERAL:
473             arg = *fpc++;
474             if (targ_is_utf8 && !SvUTF8(tmpForm)) {
475                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
476                 *t = '\0';
477                 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
478                 t = SvEND(PL_formtarget);
479                 break;
480             }
481             if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
482                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
483                 *t = '\0';
484                 sv_utf8_upgrade(PL_formtarget);
485                 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
486                 t = SvEND(PL_formtarget);
487                 targ_is_utf8 = TRUE;
488             }
489             while (arg--)
490                 *t++ = *f++;
491             break;
492
493         case FF_SKIP:
494             f += *fpc++;
495             break;
496
497         case FF_FETCH:
498             arg = *fpc++;
499             f += arg;
500             fieldsize = arg;
501
502             if (MARK < SP)
503                 sv = *++MARK;
504             else {
505                 sv = &PL_sv_no;
506                 if (ckWARN(WARN_SYNTAX))
507                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
508             }
509             break;
510
511         case FF_CHECKNL:
512             {
513                 const char *send;
514                 const char *s = item = SvPV_const(sv, len);
515                 itemsize = len;
516                 if (DO_UTF8(sv)) {
517                     itemsize = sv_len_utf8(sv);
518                     if (itemsize != (I32)len) {
519                         I32 itembytes;
520                         if (itemsize > fieldsize) {
521                             itemsize = fieldsize;
522                             itembytes = itemsize;
523                             sv_pos_u2b(sv, &itembytes, 0);
524                         }
525                         else
526                             itembytes = len;
527                         send = chophere = s + itembytes;
528                         while (s < send) {
529                             if (*s & ~31)
530                                 gotsome = TRUE;
531                             else if (*s == '\n')
532                                 break;
533                             s++;
534                         }
535                         item_is_utf8 = TRUE;
536                         itemsize = s - item;
537                         sv_pos_b2u(sv, &itemsize);
538                         break;
539                     }
540                 }
541                 item_is_utf8 = FALSE;
542                 if (itemsize > fieldsize)
543                     itemsize = fieldsize;
544                 send = chophere = s + itemsize;
545                 while (s < send) {
546                     if (*s & ~31)
547                         gotsome = TRUE;
548                     else if (*s == '\n')
549                         break;
550                     s++;
551                 }
552                 itemsize = s - item;
553                 break;
554             }
555
556         case FF_CHECKCHOP:
557             {
558                 const char *s = item = SvPV_const(sv, len);
559                 itemsize = len;
560                 if (DO_UTF8(sv)) {
561                     itemsize = sv_len_utf8(sv);
562                     if (itemsize != (I32)len) {
563                         I32 itembytes;
564                         if (itemsize <= fieldsize) {
565                             const char *send = chophere = s + itemsize;
566                             while (s < send) {
567                                 if (*s == '\r') {
568                                     itemsize = s - item;
569                                     chophere = s;
570                                     break;
571                                 }
572                                 if (*s++ & ~31)
573                                     gotsome = TRUE;
574                             }
575                         }
576                         else {
577                             const char *send;
578                             itemsize = fieldsize;
579                             itembytes = itemsize;
580                             sv_pos_u2b(sv, &itembytes, 0);
581                             send = chophere = s + itembytes;
582                             while (s < send || (s == send && isSPACE(*s))) {
583                                 if (isSPACE(*s)) {
584                                     if (chopspace)
585                                         chophere = s;
586                                     if (*s == '\r')
587                                         break;
588                                 }
589                                 else {
590                                     if (*s & ~31)
591                                         gotsome = TRUE;
592                                     if (strchr(PL_chopset, *s))
593                                         chophere = s + 1;
594                                 }
595                                 s++;
596                             }
597                             itemsize = chophere - item;
598                             sv_pos_b2u(sv, &itemsize);
599                         }
600                         item_is_utf8 = TRUE;
601                         break;
602                     }
603                 }
604                 item_is_utf8 = FALSE;
605                 if (itemsize <= fieldsize) {
606                     const char *const send = chophere = s + itemsize;
607                     while (s < send) {
608                         if (*s == '\r') {
609                             itemsize = s - item;
610                             chophere = s;
611                             break;
612                         }
613                         if (*s++ & ~31)
614                             gotsome = TRUE;
615                     }
616                 }
617                 else {
618                     const char *send;
619                     itemsize = fieldsize;
620                     send = chophere = s + itemsize;
621                     while (s < send || (s == send && isSPACE(*s))) {
622                         if (isSPACE(*s)) {
623                             if (chopspace)
624                                 chophere = s;
625                             if (*s == '\r')
626                                 break;
627                         }
628                         else {
629                             if (*s & ~31)
630                                 gotsome = TRUE;
631                             if (strchr(PL_chopset, *s))
632                                 chophere = s + 1;
633                         }
634                         s++;
635                     }
636                     itemsize = chophere - item;
637                 }
638                 break;
639             }
640
641         case FF_SPACE:
642             arg = fieldsize - itemsize;
643             if (arg) {
644                 fieldsize -= arg;
645                 while (arg-- > 0)
646                     *t++ = ' ';
647             }
648             break;
649
650         case FF_HALFSPACE:
651             arg = fieldsize - itemsize;
652             if (arg) {
653                 arg /= 2;
654                 fieldsize -= arg;
655                 while (arg-- > 0)
656                     *t++ = ' ';
657             }
658             break;
659
660         case FF_ITEM:
661             {
662                 const char *s = item;
663                 arg = itemsize;
664                 if (item_is_utf8) {
665                     if (!targ_is_utf8) {
666                         SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
667                         *t = '\0';
668                         sv_utf8_upgrade(PL_formtarget);
669                         SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
670                         t = SvEND(PL_formtarget);
671                         targ_is_utf8 = TRUE;
672                     }
673                     while (arg--) {
674                         if (UTF8_IS_CONTINUED(*s)) {
675                             STRLEN skip = UTF8SKIP(s);
676                             switch (skip) {
677                             default:
678                                 Move(s,t,skip,char);
679                                 s += skip;
680                                 t += skip;
681                                 break;
682                             case 7: *t++ = *s++;
683                             case 6: *t++ = *s++;
684                             case 5: *t++ = *s++;
685                             case 4: *t++ = *s++;
686                             case 3: *t++ = *s++;
687                             case 2: *t++ = *s++;
688                             case 1: *t++ = *s++;
689                             }
690                         }
691                         else {
692                             if ( !((*t++ = *s++) & ~31) )
693                                 t[-1] = ' ';
694                         }
695                     }
696                     break;
697                 }
698                 if (targ_is_utf8 && !item_is_utf8) {
699                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
700                     *t = '\0';
701                     sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
702                     for (; t < SvEND(PL_formtarget); t++) {
703 #ifdef EBCDIC
704                         const int ch = *t;
705                         if (iscntrl(ch))
706 #else
707                             if (!(*t & ~31))
708 #endif
709                                 *t = ' ';
710                     }
711                     break;
712                 }
713                 while (arg--) {
714 #ifdef EBCDIC
715                     const int ch = *t++ = *s++;
716                     if (iscntrl(ch))
717 #else
718                         if ( !((*t++ = *s++) & ~31) )
719 #endif
720                             t[-1] = ' ';
721                 }
722                 break;
723             }
724
725         case FF_CHOP:
726             {
727                 const char *s = chophere;
728                 if (chopspace) {
729                     while (*s && isSPACE(*s))
730                         s++;
731                 }
732                 sv_chop(sv,s);
733                 SvSETMAGIC(sv);
734                 break;
735             }
736
737         case FF_LINESNGL:
738             chopspace = 0;
739             oneline = TRUE;
740             goto ff_line;
741         case FF_LINEGLOB:
742             oneline = FALSE;
743         ff_line:
744             {
745                 const char *s = item = SvPV_const(sv, len);
746                 itemsize = len;
747                 if ((item_is_utf8 = DO_UTF8(sv)))
748                     itemsize = sv_len_utf8(sv);
749                 if (itemsize) {
750                     bool chopped = FALSE;
751                     const char *const send = s + len;
752                     gotsome = TRUE;
753                     chophere = s + itemsize;
754                     while (s < send) {
755                         if (*s++ == '\n') {
756                             if (oneline) {
757                                 chopped = TRUE;
758                                 chophere = s;
759                                 break;
760                             } else {
761                                 if (s == send) {
762                                     itemsize--;
763                                     chopped = TRUE;
764                                 } else
765                                     lines++;
766                             }
767                         }
768                     }
769                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
770                     if (targ_is_utf8)
771                         SvUTF8_on(PL_formtarget);
772                     if (oneline) {
773                         SvCUR_set(sv, chophere - item);
774                         sv_catsv(PL_formtarget, sv);
775                         SvCUR_set(sv, itemsize);
776                     } else
777                         sv_catsv(PL_formtarget, sv);
778                     if (chopped)
779                         SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
780                     SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
781                     t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
782                     if (item_is_utf8)
783                         targ_is_utf8 = TRUE;
784                 }
785                 break;
786             }
787
788         case FF_0DECIMAL:
789             arg = *fpc++;
790 #if defined(USE_LONG_DOUBLE)
791             fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
792 #else
793             fmt = (arg & 256) ? "%#0*.*f"              : "%0*.*f";
794 #endif
795             goto ff_dec;
796         case FF_DECIMAL:
797             arg = *fpc++;
798 #if defined(USE_LONG_DOUBLE)
799             fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
800 #else
801             fmt = (arg & 256) ? "%#*.*f"              : "%*.*f";
802 #endif
803         ff_dec:
804             /* If the field is marked with ^ and the value is undefined,
805                blank it out. */
806             if ((arg & 512) && !SvOK(sv)) {
807                 arg = fieldsize;
808                 while (arg--)
809                     *t++ = ' ';
810                 break;
811             }
812             gotsome = TRUE;
813             value = SvNV(sv);
814             /* overflow evidence */
815             if (num_overflow(value, fieldsize, arg)) {
816                 arg = fieldsize;
817                 while (arg--)
818                     *t++ = '#';
819                 break;
820             }
821             /* Formats aren't yet marked for locales, so assume "yes". */
822             {
823                 STORE_NUMERIC_STANDARD_SET_LOCAL();
824                 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
825                 RESTORE_NUMERIC_STANDARD();
826             }
827             t += fieldsize;
828             break;
829
830         case FF_NEWLINE:
831             f++;
832             while (t-- > linemark && *t == ' ') ;
833             t++;
834             *t++ = '\n';
835             break;
836
837         case FF_BLANK:
838             arg = *fpc++;
839             if (gotsome) {
840                 if (arg) {              /* repeat until fields exhausted? */
841                     *t = '\0';
842                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
843                     lines += FmLINES(PL_formtarget);
844                     if (lines == 200) {
845                         arg = t - linemark;
846                         if (strnEQ(linemark, linemark - arg, arg))
847                             DIE(aTHX_ "Runaway format");
848                     }
849                     if (targ_is_utf8)
850                         SvUTF8_on(PL_formtarget);
851                     FmLINES(PL_formtarget) = lines;
852                     SP = ORIGMARK;
853                     RETURNOP(cLISTOP->op_first);
854                 }
855             }
856             else {
857                 t = linemark;
858                 lines--;
859             }
860             break;
861
862         case FF_MORE:
863             {
864                 const char *s = chophere;
865                 const char *send = item + len;
866                 if (chopspace) {
867                     while (*s && isSPACE(*s) && s < send)
868                         s++;
869                 }
870                 if (s < send) {
871                     char *s1;
872                     arg = fieldsize - itemsize;
873                     if (arg) {
874                         fieldsize -= arg;
875                         while (arg-- > 0)
876                             *t++ = ' ';
877                     }
878                     s1 = t - 3;
879                     if (strnEQ(s1,"   ",3)) {
880                         while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
881                             s1--;
882                     }
883                     *s1++ = '.';
884                     *s1++ = '.';
885                     *s1++ = '.';
886                 }
887                 break;
888             }
889         case FF_END:
890             *t = '\0';
891             SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
892             if (targ_is_utf8)
893                 SvUTF8_on(PL_formtarget);
894             FmLINES(PL_formtarget) += lines;
895             SP = ORIGMARK;
896             RETPUSHYES;
897         }
898     }
899 }
900
901 PP(pp_grepstart)
902 {
903     dVAR; dSP;
904     SV *src;
905
906     if (PL_stack_base + *PL_markstack_ptr == SP) {
907         (void)POPMARK;
908         if (GIMME_V == G_SCALAR)
909             XPUSHs(sv_2mortal(newSViv(0)));
910         RETURNOP(PL_op->op_next->op_next);
911     }
912     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
913     pp_pushmark();                              /* push dst */
914     pp_pushmark();                              /* push src */
915     ENTER;                                      /* enter outer scope */
916
917     SAVETMPS;
918     if (PL_op->op_private & OPpGREP_LEX)
919         SAVESPTR(PAD_SVl(PL_op->op_targ));
920     else
921         SAVE_DEFSV;
922     ENTER;                                      /* enter inner scope */
923     SAVEVPTR(PL_curpm);
924
925     src = PL_stack_base[*PL_markstack_ptr];
926     SvTEMP_off(src);
927     if (PL_op->op_private & OPpGREP_LEX)
928         PAD_SVl(PL_op->op_targ) = src;
929     else
930         DEFSV = src;
931
932     PUTBACK;
933     if (PL_op->op_type == OP_MAPSTART)
934         pp_pushmark();                  /* push top */
935     return ((LOGOP*)PL_op->op_next)->op_other;
936 }
937
938 PP(pp_mapwhile)
939 {
940     dVAR; dSP;
941     const I32 gimme = GIMME_V;
942     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
943     I32 count;
944     I32 shift;
945     SV** src;
946     SV** dst;
947
948     /* first, move source pointer to the next item in the source list */
949     ++PL_markstack_ptr[-1];
950
951     /* if there are new items, push them into the destination list */
952     if (items && gimme != G_VOID) {
953         /* might need to make room back there first */
954         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
955             /* XXX this implementation is very pessimal because the stack
956              * is repeatedly extended for every set of items.  Is possible
957              * to do this without any stack extension or copying at all
958              * by maintaining a separate list over which the map iterates
959              * (like foreach does). --gsar */
960
961             /* everything in the stack after the destination list moves
962              * towards the end the stack by the amount of room needed */
963             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
964
965             /* items to shift up (accounting for the moved source pointer) */
966             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
967
968             /* This optimization is by Ben Tilly and it does
969              * things differently from what Sarathy (gsar)
970              * is describing.  The downside of this optimization is
971              * that leaves "holes" (uninitialized and hopefully unused areas)
972              * to the Perl stack, but on the other hand this
973              * shouldn't be a problem.  If Sarathy's idea gets
974              * implemented, this optimization should become
975              * irrelevant.  --jhi */
976             if (shift < count)
977                 shift = count; /* Avoid shifting too often --Ben Tilly */
978
979             EXTEND(SP,shift);
980             src = SP;
981             dst = (SP += shift);
982             PL_markstack_ptr[-1] += shift;
983             *PL_markstack_ptr += shift;
984             while (count--)
985                 *dst-- = *src--;
986         }
987         /* copy the new items down to the destination list */
988         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
989         if (gimme == G_ARRAY) {
990             while (items-- > 0)
991                 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
992         }
993         else {
994             /* scalar context: we don't care about which values map returns
995              * (we use undef here). And so we certainly don't want to do mortal
996              * copies of meaningless values. */
997             while (items-- > 0) {
998                 (void)POPs;
999                 *dst-- = &PL_sv_undef;
1000             }
1001         }
1002     }
1003     LEAVE;                                      /* exit inner scope */
1004
1005     /* All done yet? */
1006     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1007
1008         (void)POPMARK;                          /* pop top */
1009         LEAVE;                                  /* exit outer scope */
1010         (void)POPMARK;                          /* pop src */
1011         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1012         (void)POPMARK;                          /* pop dst */
1013         SP = PL_stack_base + POPMARK;           /* pop original mark */
1014         if (gimme == G_SCALAR) {
1015             if (PL_op->op_private & OPpGREP_LEX) {
1016                 SV* sv = sv_newmortal();
1017                 sv_setiv(sv, items);
1018                 PUSHs(sv);
1019             }
1020             else {
1021                 dTARGET;
1022                 XPUSHi(items);
1023             }
1024         }
1025         else if (gimme == G_ARRAY)
1026             SP += items;
1027         RETURN;
1028     }
1029     else {
1030         SV *src;
1031
1032         ENTER;                                  /* enter inner scope */
1033         SAVEVPTR(PL_curpm);
1034
1035         /* set $_ to the new source item */
1036         src = PL_stack_base[PL_markstack_ptr[-1]];
1037         SvTEMP_off(src);
1038         if (PL_op->op_private & OPpGREP_LEX)
1039             PAD_SVl(PL_op->op_targ) = src;
1040         else
1041             DEFSV = src;
1042
1043         RETURNOP(cLOGOP->op_other);
1044     }
1045 }
1046
1047 /* Range stuff. */
1048
1049 PP(pp_range)
1050 {
1051     if (GIMME == G_ARRAY)
1052         return NORMAL;
1053     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1054         return cLOGOP->op_other;
1055     else
1056         return NORMAL;
1057 }
1058
1059 PP(pp_flip)
1060 {
1061     dSP;
1062
1063     if (GIMME == G_ARRAY) {
1064         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1065     }
1066     else {
1067         dTOPss;
1068         SV * const targ = PAD_SV(PL_op->op_targ);
1069         int flip = 0;
1070
1071         if (PL_op->op_private & OPpFLIP_LINENUM) {
1072             if (GvIO(PL_last_in_gv)) {
1073                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1074             }
1075             else {
1076                 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1077                 if (gv && GvSV(gv))
1078                     flip = SvIV(sv) == SvIV(GvSV(gv));
1079             }
1080         } else {
1081             flip = SvTRUE(sv);
1082         }
1083         if (flip) {
1084             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1085             if (PL_op->op_flags & OPf_SPECIAL) {
1086                 sv_setiv(targ, 1);
1087                 SETs(targ);
1088                 RETURN;
1089             }
1090             else {
1091                 sv_setiv(targ, 0);
1092                 SP--;
1093                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1094             }
1095         }
1096         sv_setpvn(TARG, "", 0);
1097         SETs(targ);
1098         RETURN;
1099     }
1100 }
1101
1102 /* This code tries to decide if "$left .. $right" should use the
1103    magical string increment, or if the range is numeric (we make
1104    an exception for .."0" [#18165]). AMS 20021031. */
1105
1106 #define RANGE_IS_NUMERIC(left,right) ( \
1107         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1108         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1109         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1110           looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1111          && (!SvOK(right) || looks_like_number(right))))
1112
1113 PP(pp_flop)
1114 {
1115     dSP;
1116
1117     if (GIMME == G_ARRAY) {
1118         dPOPPOPssrl;
1119
1120         SvGETMAGIC(left);
1121         SvGETMAGIC(right);
1122
1123         if (RANGE_IS_NUMERIC(left,right)) {
1124             register IV i, j;
1125             IV max;
1126             if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1127                 (SvOK(right) && SvNV(right) > IV_MAX))
1128                 DIE(aTHX_ "Range iterator outside integer range");
1129             i = SvIV(left);
1130             max = SvIV(right);
1131             if (max >= i) {
1132                 j = max - i + 1;
1133                 EXTEND_MORTAL(j);
1134                 EXTEND(SP, j);
1135             }
1136             else
1137                 j = 0;
1138             while (j--) {
1139                 SV * const sv = sv_2mortal(newSViv(i++));
1140                 PUSHs(sv);
1141             }
1142         }
1143         else {
1144             SV * const final = sv_mortalcopy(right);
1145             STRLEN len;
1146             const char * const tmps = SvPV_const(final, len);
1147
1148             SV *sv = sv_mortalcopy(left);
1149             SvPV_force_nolen(sv);
1150             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1151                 XPUSHs(sv);
1152                 if (strEQ(SvPVX_const(sv),tmps))
1153                     break;
1154                 sv = sv_2mortal(newSVsv(sv));
1155                 sv_inc(sv);
1156             }
1157         }
1158     }
1159     else {
1160         dTOPss;
1161         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1162         int flop = 0;
1163         sv_inc(targ);
1164
1165         if (PL_op->op_private & OPpFLIP_LINENUM) {
1166             if (GvIO(PL_last_in_gv)) {
1167                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1168             }
1169             else {
1170                 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1171                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1172             }
1173         }
1174         else {
1175             flop = SvTRUE(sv);
1176         }
1177
1178         if (flop) {
1179             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1180             sv_catpvn(targ, "E0", 2);
1181         }
1182         SETs(targ);
1183     }
1184
1185     RETURN;
1186 }
1187
1188 /* Control. */
1189
1190 static const char * const context_name[] = {
1191     "pseudo-block",
1192     "subroutine",
1193     "eval",
1194     "loop",
1195     "substitution",
1196     "block",
1197     "format"
1198 };
1199
1200 STATIC I32
1201 S_dopoptolabel(pTHX_ const char *label)
1202 {
1203     register I32 i;
1204
1205     for (i = cxstack_ix; i >= 0; i--) {
1206         register const PERL_CONTEXT * const cx = &cxstack[i];
1207         switch (CxTYPE(cx)) {
1208         case CXt_SUBST:
1209         case CXt_SUB:
1210         case CXt_FORMAT:
1211         case CXt_EVAL:
1212         case CXt_NULL:
1213             if (ckWARN(WARN_EXITING))
1214                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1215                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1216             if (CxTYPE(cx) == CXt_NULL)
1217                 return -1;
1218             break;
1219         case CXt_LOOP:
1220             if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1221                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1222                         (long)i, cx->blk_loop.label));
1223                 continue;
1224             }
1225             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1226             return i;
1227         }
1228     }
1229     return i;
1230 }
1231
1232 I32
1233 Perl_dowantarray(pTHX)
1234 {
1235     const I32 gimme = block_gimme();
1236     return (gimme == G_VOID) ? G_SCALAR : gimme;
1237 }
1238
1239 I32
1240 Perl_block_gimme(pTHX)
1241 {
1242     const I32 cxix = dopoptosub(cxstack_ix);
1243     if (cxix < 0)
1244         return G_VOID;
1245
1246     switch (cxstack[cxix].blk_gimme) {
1247     case G_VOID:
1248         return G_VOID;
1249     case G_SCALAR:
1250         return G_SCALAR;
1251     case G_ARRAY:
1252         return G_ARRAY;
1253     default:
1254         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1255         /* NOTREACHED */
1256         return 0;
1257     }
1258 }
1259
1260 I32
1261 Perl_is_lvalue_sub(pTHX)
1262 {
1263     const I32 cxix = dopoptosub(cxstack_ix);
1264     assert(cxix >= 0);  /* We should only be called from inside subs */
1265
1266     if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1267         return cxstack[cxix].blk_sub.lval;
1268     else
1269         return 0;
1270 }
1271
1272 STATIC I32
1273 S_dopoptosub(pTHX_ I32 startingblock)
1274 {
1275     return dopoptosub_at(cxstack, startingblock);
1276 }
1277
1278 STATIC I32
1279 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1280 {
1281     I32 i;
1282     for (i = startingblock; i >= 0; i--) {
1283         register const PERL_CONTEXT * const cx = &cxstk[i];
1284         switch (CxTYPE(cx)) {
1285         default:
1286             continue;
1287         case CXt_EVAL:
1288         case CXt_SUB:
1289         case CXt_FORMAT:
1290             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1291             return i;
1292         }
1293     }
1294     return i;
1295 }
1296
1297 STATIC I32
1298 S_dopoptoeval(pTHX_ I32 startingblock)
1299 {
1300     I32 i;
1301     for (i = startingblock; i >= 0; i--) {
1302         register const PERL_CONTEXT *cx = &cxstack[i];
1303         switch (CxTYPE(cx)) {
1304         default:
1305             continue;
1306         case CXt_EVAL:
1307             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1308             return i;
1309         }
1310     }
1311     return i;
1312 }
1313
1314 STATIC I32
1315 S_dopoptoloop(pTHX_ I32 startingblock)
1316 {
1317     I32 i;
1318     for (i = startingblock; i >= 0; i--) {
1319         register const PERL_CONTEXT * const cx = &cxstack[i];
1320         switch (CxTYPE(cx)) {
1321         case CXt_SUBST:
1322         case CXt_SUB:
1323         case CXt_FORMAT:
1324         case CXt_EVAL:
1325         case CXt_NULL:
1326             if (ckWARN(WARN_EXITING))
1327                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1328                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1329             if ((CxTYPE(cx)) == CXt_NULL)
1330                 return -1;
1331             break;
1332         case CXt_LOOP:
1333             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1334             return i;
1335         }
1336     }
1337     return i;
1338 }
1339
1340 void
1341 Perl_dounwind(pTHX_ I32 cxix)
1342 {
1343     I32 optype;
1344
1345     while (cxstack_ix > cxix) {
1346         SV *sv;
1347         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1348         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1349                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1350         /* Note: we don't need to restore the base context info till the end. */
1351         switch (CxTYPE(cx)) {
1352         case CXt_SUBST:
1353             POPSUBST(cx);
1354             continue;  /* not break */
1355         case CXt_SUB:
1356             POPSUB(cx,sv);
1357             LEAVESUB(sv);
1358             break;
1359         case CXt_EVAL:
1360             POPEVAL(cx);
1361             break;
1362         case CXt_LOOP:
1363             POPLOOP(cx);
1364             break;
1365         case CXt_NULL:
1366             break;
1367         case CXt_FORMAT:
1368             POPFORMAT(cx);
1369             break;
1370         }
1371         cxstack_ix--;
1372     }
1373     PERL_UNUSED_VAR(optype);
1374 }
1375
1376 void
1377 Perl_qerror(pTHX_ SV *err)
1378 {
1379     if (PL_in_eval)
1380         sv_catsv(ERRSV, err);
1381     else if (PL_errors)
1382         sv_catsv(PL_errors, err);
1383     else
1384         Perl_warn(aTHX_ "%"SVf, err);
1385     ++PL_error_count;
1386 }
1387
1388 OP *
1389 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1390 {
1391     dVAR;
1392
1393     if (PL_in_eval) {
1394         I32 cxix;
1395         I32 gimme;
1396
1397         if (message) {
1398             if (PL_in_eval & EVAL_KEEPERR) {
1399                 static const char prefix[] = "\t(in cleanup) ";
1400                 SV * const err = ERRSV;
1401                 const char *e = Nullch;
1402                 if (!SvPOK(err))
1403                     sv_setpvn(err,"",0);
1404                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1405                     STRLEN len;
1406                     e = SvPV_const(err, len);
1407                     e += len - msglen;
1408                     if (*e != *message || strNE(e,message))
1409                         e = Nullch;
1410                 }
1411                 if (!e) {
1412                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1413                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1414                     sv_catpvn(err, message, msglen);
1415                     if (ckWARN(WARN_MISC)) {
1416                         const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1417                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1418                     }
1419                 }
1420             }
1421             else {
1422                 sv_setpvn(ERRSV, message, msglen);
1423             }
1424         }
1425
1426         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1427                && PL_curstackinfo->si_prev)
1428         {
1429             dounwind(-1);
1430             POPSTACK;
1431         }
1432
1433         if (cxix >= 0) {
1434             I32 optype;
1435             register PERL_CONTEXT *cx;
1436             SV **newsp;
1437
1438             if (cxix < cxstack_ix)
1439                 dounwind(cxix);
1440
1441             POPBLOCK(cx,PL_curpm);
1442             if (CxTYPE(cx) != CXt_EVAL) {
1443                 if (!message)
1444                     message = SvPVx_const(ERRSV, msglen);
1445                 PerlIO_write(Perl_error_log, "panic: die ", 11);
1446                 PerlIO_write(Perl_error_log, message, msglen);
1447                 my_exit(1);
1448             }
1449             POPEVAL(cx);
1450
1451             if (gimme == G_SCALAR)
1452                 *++newsp = &PL_sv_undef;
1453             PL_stack_sp = newsp;
1454
1455             LEAVE;
1456
1457             /* LEAVE could clobber PL_curcop (see save_re_context())
1458              * XXX it might be better to find a way to avoid messing with
1459              * PL_curcop in save_re_context() instead, but this is a more
1460              * minimal fix --GSAR */
1461             PL_curcop = cx->blk_oldcop;
1462
1463             if (optype == OP_REQUIRE) {
1464                 const char* const msg = SvPVx_nolen_const(ERRSV);
1465                 SV * const nsv = cx->blk_eval.old_namesv;
1466                 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1467                                &PL_sv_undef, 0);
1468                 DIE(aTHX_ "%sCompilation failed in require",
1469                     *msg ? msg : "Unknown error\n");
1470             }
1471             assert(CxTYPE(cx) == CXt_EVAL);
1472             return cx->blk_eval.retop;
1473         }
1474     }
1475     if (!message)
1476         message = SvPVx_const(ERRSV, msglen);
1477
1478     write_to_stderr(message, msglen);
1479     my_failure_exit();
1480     /* NOTREACHED */
1481     return 0;
1482 }
1483
1484 PP(pp_xor)
1485 {
1486     dSP; dPOPTOPssrl;
1487     if (SvTRUE(left) != SvTRUE(right))
1488         RETSETYES;
1489     else
1490         RETSETNO;
1491 }
1492
1493 PP(pp_caller)
1494 {
1495     dSP;
1496     register I32 cxix = dopoptosub(cxstack_ix);
1497     register const PERL_CONTEXT *cx;
1498     register const PERL_CONTEXT *ccstack = cxstack;
1499     const PERL_SI *top_si = PL_curstackinfo;
1500     I32 gimme;
1501     const char *stashname;
1502     I32 count = 0;
1503
1504     if (MAXARG)
1505         count = POPi;
1506
1507     for (;;) {
1508         /* we may be in a higher stacklevel, so dig down deeper */
1509         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1510             top_si = top_si->si_prev;
1511             ccstack = top_si->si_cxstack;
1512             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1513         }
1514         if (cxix < 0) {
1515             if (GIMME != G_ARRAY) {
1516                 EXTEND(SP, 1);
1517                 RETPUSHUNDEF;
1518             }
1519             RETURN;
1520         }
1521         /* caller() should not report the automatic calls to &DB::sub */
1522         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1523                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1524             count++;
1525         if (!count--)
1526             break;
1527         cxix = dopoptosub_at(ccstack, cxix - 1);
1528     }
1529
1530     cx = &ccstack[cxix];
1531     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1532         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1533         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1534            field below is defined for any cx. */
1535         /* caller() should not report the automatic calls to &DB::sub */
1536         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1537             cx = &ccstack[dbcxix];
1538     }
1539
1540     stashname = CopSTASHPV(cx->blk_oldcop);
1541     if (GIMME != G_ARRAY) {
1542         EXTEND(SP, 1);
1543         if (!stashname)
1544             PUSHs(&PL_sv_undef);
1545         else {
1546             dTARGET;
1547             sv_setpv(TARG, stashname);
1548             PUSHs(TARG);
1549         }
1550         RETURN;
1551     }
1552
1553     EXTEND(SP, 10);
1554
1555     if (!stashname)
1556         PUSHs(&PL_sv_undef);
1557     else
1558         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1559     PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1560     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1561     if (!MAXARG)
1562         RETURN;
1563     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1564         GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1565         /* So is ccstack[dbcxix]. */
1566         if (isGV(cvgv)) {
1567             SV * const sv = NEWSV(49, 0);
1568             gv_efullname3(sv, cvgv, Nullch);
1569             PUSHs(sv_2mortal(sv));
1570             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1571         }
1572         else {
1573             PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1574             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1575         }
1576     }
1577     else {
1578         PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1579         PUSHs(sv_2mortal(newSViv(0)));
1580     }
1581     gimme = (I32)cx->blk_gimme;
1582     if (gimme == G_VOID)
1583         PUSHs(&PL_sv_undef);
1584     else
1585         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1586     if (CxTYPE(cx) == CXt_EVAL) {
1587         /* eval STRING */
1588         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1589             PUSHs(cx->blk_eval.cur_text);
1590             PUSHs(&PL_sv_no);
1591         }
1592         /* require */
1593         else if (cx->blk_eval.old_namesv) {
1594             PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1595             PUSHs(&PL_sv_yes);
1596         }
1597         /* eval BLOCK (try blocks have old_namesv == 0) */
1598         else {
1599             PUSHs(&PL_sv_undef);
1600             PUSHs(&PL_sv_undef);
1601         }
1602     }
1603     else {
1604         PUSHs(&PL_sv_undef);
1605         PUSHs(&PL_sv_undef);
1606     }
1607     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1608         && CopSTASH_eq(PL_curcop, PL_debstash))
1609     {
1610         AV * const ary = cx->blk_sub.argarray;
1611         const int off = AvARRAY(ary) - AvALLOC(ary);
1612
1613         if (!PL_dbargs) {
1614             GV* tmpgv;
1615             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1616                                 SVt_PVAV)));
1617             GvMULTI_on(tmpgv);
1618             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1619         }
1620
1621         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1622             av_extend(PL_dbargs, AvFILLp(ary) + off);
1623         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1624         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1625     }
1626     /* XXX only hints propagated via op_private are currently
1627      * visible (others are not easily accessible, since they
1628      * use the global PL_hints) */
1629     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1630                              HINT_PRIVATE_MASK)));
1631     {
1632         SV * mask ;
1633         SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1634
1635         if  (old_warnings == pWARN_NONE ||
1636                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1637             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1638         else if (old_warnings == pWARN_ALL ||
1639                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1640             /* Get the bit mask for $warnings::Bits{all}, because
1641              * it could have been extended by warnings::register */
1642             SV **bits_all;
1643             HV *bits = get_hv("warnings::Bits", FALSE);
1644             if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1645                 mask = newSVsv(*bits_all);
1646             }
1647             else {
1648                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1649             }
1650         }
1651         else
1652             mask = newSVsv(old_warnings);
1653         PUSHs(sv_2mortal(mask));
1654     }
1655     RETURN;
1656 }
1657
1658 PP(pp_reset)
1659 {
1660     dSP;
1661     const char *tmps;
1662
1663     if (MAXARG < 1)
1664         tmps = "";
1665     else
1666         tmps = POPpconstx;
1667     sv_reset(tmps, CopSTASH(PL_curcop));
1668     PUSHs(&PL_sv_yes);
1669     RETURN;
1670 }
1671
1672 /* like pp_nextstate, but used instead when the debugger is active */
1673
1674 PP(pp_dbstate)
1675 {
1676     dVAR;
1677     PL_curcop = (COP*)PL_op;
1678     TAINT_NOT;          /* Each statement is presumed innocent */
1679     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1680     FREETMPS;
1681
1682     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1683             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1684     {
1685         dSP;
1686         register CV *cv;
1687         register PERL_CONTEXT *cx;
1688         const I32 gimme = G_ARRAY;
1689         U8 hasargs;
1690         GV *gv;
1691
1692         gv = PL_DBgv;
1693         cv = GvCV(gv);
1694         if (!cv)
1695             DIE(aTHX_ "No DB::DB routine defined");
1696
1697         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1698             /* don't do recursive DB::DB call */
1699             return NORMAL;
1700
1701         ENTER;
1702         SAVETMPS;
1703
1704         SAVEI32(PL_debug);
1705         SAVESTACK_POS();
1706         PL_debug = 0;
1707         hasargs = 0;
1708         SPAGAIN;
1709
1710         if (CvXSUB(cv)) {
1711             CvDEPTH(cv)++;
1712             PUSHMARK(SP);
1713             (void)(*CvXSUB(cv))(aTHX_ cv);
1714             CvDEPTH(cv)--;
1715             FREETMPS;
1716             LEAVE;
1717             return NORMAL;
1718         }
1719         else {
1720             PUSHBLOCK(cx, CXt_SUB, SP);
1721             PUSHSUB_DB(cx);
1722             cx->blk_sub.retop = PL_op->op_next;
1723             CvDEPTH(cv)++;
1724             SAVECOMPPAD();
1725             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1726             RETURNOP(CvSTART(cv));
1727         }
1728     }
1729     else
1730         return NORMAL;
1731 }
1732
1733 PP(pp_enteriter)
1734 {
1735     dVAR; dSP; dMARK;
1736     register PERL_CONTEXT *cx;
1737     const I32 gimme = GIMME_V;
1738     SV **svp;
1739     U32 cxtype = CXt_LOOP;
1740 #ifdef USE_ITHREADS
1741     void *iterdata;
1742 #endif
1743
1744     ENTER;
1745     SAVETMPS;
1746
1747     if (PL_op->op_targ) {
1748         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1749             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1750             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1751                     SVs_PADSTALE, SVs_PADSTALE);
1752         }
1753 #ifndef USE_ITHREADS
1754         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1755         SAVESPTR(*svp);
1756 #else
1757         SAVEPADSV(PL_op->op_targ);
1758         iterdata = INT2PTR(void*, PL_op->op_targ);
1759         cxtype |= CXp_PADVAR;
1760 #endif
1761     }
1762     else {
1763         GV *gv = (GV*)POPs;
1764         svp = &GvSV(gv);                        /* symbol table variable */
1765         SAVEGENERICSV(*svp);
1766         *svp = NEWSV(0,0);
1767 #ifdef USE_ITHREADS
1768         iterdata = (void*)gv;
1769 #endif
1770     }
1771
1772     ENTER;
1773
1774     PUSHBLOCK(cx, cxtype, SP);
1775 #ifdef USE_ITHREADS
1776     PUSHLOOP(cx, iterdata, MARK);
1777 #else
1778     PUSHLOOP(cx, svp, MARK);
1779 #endif
1780     if (PL_op->op_flags & OPf_STACKED) {
1781         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1782         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1783             dPOPss;
1784             SV *right = (SV*)cx->blk_loop.iterary;
1785             SvGETMAGIC(sv);
1786             SvGETMAGIC(right);
1787             if (RANGE_IS_NUMERIC(sv,right)) {
1788                 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1789                     (SvOK(right) && SvNV(right) >= IV_MAX))
1790                     DIE(aTHX_ "Range iterator outside integer range");
1791                 cx->blk_loop.iterix = SvIV(sv);
1792                 cx->blk_loop.itermax = SvIV(right);
1793 #ifdef DEBUGGING
1794                 /* for correct -Dstv display */
1795                 cx->blk_oldsp = sp - PL_stack_base;
1796 #endif
1797             }
1798             else {
1799                 cx->blk_loop.iterlval = newSVsv(sv);
1800                 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1801                 (void) SvPV_nolen_const(right);
1802             }
1803         }
1804         else if (PL_op->op_private & OPpITER_REVERSED) {
1805             cx->blk_loop.itermax = -1;
1806             cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1807
1808         }
1809     }
1810     else {
1811         cx->blk_loop.iterary = PL_curstack;
1812         AvFILLp(PL_curstack) = SP - PL_stack_base;
1813         if (PL_op->op_private & OPpITER_REVERSED) {
1814             cx->blk_loop.itermax = MARK - PL_stack_base;
1815             cx->blk_loop.iterix = cx->blk_oldsp;
1816         }
1817         else {
1818             cx->blk_loop.iterix = MARK - PL_stack_base;
1819         }
1820     }
1821
1822     RETURN;
1823 }
1824
1825 PP(pp_enterloop)
1826 {
1827     dVAR; dSP;
1828     register PERL_CONTEXT *cx;
1829     const I32 gimme = GIMME_V;
1830
1831     ENTER;
1832     SAVETMPS;
1833     ENTER;
1834
1835     PUSHBLOCK(cx, CXt_LOOP, SP);
1836     PUSHLOOP(cx, 0, SP);
1837
1838     RETURN;
1839 }
1840
1841 PP(pp_leaveloop)
1842 {
1843     dVAR; dSP;
1844     register PERL_CONTEXT *cx;
1845     I32 gimme;
1846     SV **newsp;
1847     PMOP *newpm;
1848     SV **mark;
1849
1850     POPBLOCK(cx,newpm);
1851     assert(CxTYPE(cx) == CXt_LOOP);
1852     mark = newsp;
1853     newsp = PL_stack_base + cx->blk_loop.resetsp;
1854
1855     TAINT_NOT;
1856     if (gimme == G_VOID)
1857         ; /* do nothing */
1858     else if (gimme == G_SCALAR) {
1859         if (mark < SP)
1860             *++newsp = sv_mortalcopy(*SP);
1861         else
1862             *++newsp = &PL_sv_undef;
1863     }
1864     else {
1865         while (mark < SP) {
1866             *++newsp = sv_mortalcopy(*++mark);
1867             TAINT_NOT;          /* Each item is independent */
1868         }
1869     }
1870     SP = newsp;
1871     PUTBACK;
1872
1873     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1874     PL_curpm = newpm;   /* ... and pop $1 et al */
1875
1876     LEAVE;
1877     LEAVE;
1878
1879     return NORMAL;
1880 }
1881
1882 PP(pp_return)
1883 {
1884     dVAR; dSP; dMARK;
1885     I32 cxix;
1886     register PERL_CONTEXT *cx;
1887     bool popsub2 = FALSE;
1888     bool clear_errsv = FALSE;
1889     I32 gimme;
1890     SV **newsp;
1891     PMOP *newpm;
1892     I32 optype = 0;
1893     SV *sv;
1894     OP *retop;
1895
1896     cxix = dopoptosub(cxstack_ix);
1897     if (cxix < 0) {
1898         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1899                                      * sort block, which is a CXt_NULL
1900                                      * not a CXt_SUB */
1901             dounwind(0);
1902             PL_stack_base[1] = *PL_stack_sp;
1903             PL_stack_sp = PL_stack_base + 1;
1904             return 0;
1905         }
1906         else
1907             DIE(aTHX_ "Can't return outside a subroutine");
1908     }
1909     if (cxix < cxstack_ix)
1910         dounwind(cxix);
1911
1912     if (CxMULTICALL(&cxstack[cxix])) {
1913         gimme = cxstack[cxix].blk_gimme;
1914         if (gimme == G_VOID)
1915             PL_stack_sp = PL_stack_base;
1916         else if (gimme == G_SCALAR) {
1917             PL_stack_base[1] = *PL_stack_sp;
1918             PL_stack_sp = PL_stack_base + 1;
1919         }
1920         return 0;
1921     }
1922
1923     POPBLOCK(cx,newpm);
1924     switch (CxTYPE(cx)) {
1925     case CXt_SUB:
1926         popsub2 = TRUE;
1927         retop = cx->blk_sub.retop;
1928         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1929         break;
1930     case CXt_EVAL:
1931         if (!(PL_in_eval & EVAL_KEEPERR))
1932             clear_errsv = TRUE;
1933         POPEVAL(cx);
1934         retop = cx->blk_eval.retop;
1935         if (CxTRYBLOCK(cx))
1936             break;
1937         lex_end();
1938         if (optype == OP_REQUIRE &&
1939             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1940         {
1941             /* Unassume the success we assumed earlier. */
1942             SV * const nsv = cx->blk_eval.old_namesv;
1943             (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
1944             DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1945         }
1946         break;
1947     case CXt_FORMAT:
1948         POPFORMAT(cx);
1949         retop = cx->blk_sub.retop;
1950         break;
1951     default:
1952         DIE(aTHX_ "panic: return");
1953     }
1954
1955     TAINT_NOT;
1956     if (gimme == G_SCALAR) {
1957         if (MARK < SP) {
1958             if (popsub2) {
1959                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1960                     if (SvTEMP(TOPs)) {
1961                         *++newsp = SvREFCNT_inc(*SP);
1962                         FREETMPS;
1963                         sv_2mortal(*newsp);
1964                     }
1965                     else {
1966                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1967                         FREETMPS;
1968                         *++newsp = sv_mortalcopy(sv);
1969                         SvREFCNT_dec(sv);
1970                     }
1971                 }
1972                 else
1973                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1974             }
1975             else
1976                 *++newsp = sv_mortalcopy(*SP);
1977         }
1978         else
1979             *++newsp = &PL_sv_undef;
1980     }
1981     else if (gimme == G_ARRAY) {
1982         while (++MARK <= SP) {
1983             *++newsp = (popsub2 && SvTEMP(*MARK))
1984                         ? *MARK : sv_mortalcopy(*MARK);
1985             TAINT_NOT;          /* Each item is independent */
1986         }
1987     }
1988     PL_stack_sp = newsp;
1989
1990     LEAVE;
1991     /* Stack values are safe: */
1992     if (popsub2) {
1993         cxstack_ix--;
1994         POPSUB(cx,sv);  /* release CV and @_ ... */
1995     }
1996     else
1997         sv = Nullsv;
1998     PL_curpm = newpm;   /* ... and pop $1 et al */
1999
2000     LEAVESUB(sv);
2001     if (clear_errsv)
2002         sv_setpvn(ERRSV,"",0);
2003     return retop;
2004 }
2005
2006 PP(pp_last)
2007 {
2008     dVAR; dSP;
2009     I32 cxix;
2010     register PERL_CONTEXT *cx;
2011     I32 pop2 = 0;
2012     I32 gimme;
2013     I32 optype;
2014     OP *nextop;
2015     SV **newsp;
2016     PMOP *newpm;
2017     SV **mark;
2018     SV *sv = Nullsv;
2019
2020
2021     if (PL_op->op_flags & OPf_SPECIAL) {
2022         cxix = dopoptoloop(cxstack_ix);
2023         if (cxix < 0)
2024             DIE(aTHX_ "Can't \"last\" outside a loop block");
2025     }
2026     else {
2027         cxix = dopoptolabel(cPVOP->op_pv);
2028         if (cxix < 0)
2029             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2030     }
2031     if (cxix < cxstack_ix)
2032         dounwind(cxix);
2033
2034     POPBLOCK(cx,newpm);
2035     cxstack_ix++; /* temporarily protect top context */
2036     mark = newsp;
2037     switch (CxTYPE(cx)) {
2038     case CXt_LOOP:
2039         pop2 = CXt_LOOP;
2040         newsp = PL_stack_base + cx->blk_loop.resetsp;
2041         nextop = cx->blk_loop.last_op->op_next;
2042         break;
2043     case CXt_SUB:
2044         pop2 = CXt_SUB;
2045         nextop = cx->blk_sub.retop;
2046         break;
2047     case CXt_EVAL:
2048         POPEVAL(cx);
2049         nextop = cx->blk_eval.retop;
2050         break;
2051     case CXt_FORMAT:
2052         POPFORMAT(cx);
2053         nextop = cx->blk_sub.retop;
2054         break;
2055     default:
2056         DIE(aTHX_ "panic: last");
2057     }
2058
2059     TAINT_NOT;
2060     if (gimme == G_SCALAR) {
2061         if (MARK < SP)
2062             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2063                         ? *SP : sv_mortalcopy(*SP);
2064         else
2065             *++newsp = &PL_sv_undef;
2066     }
2067     else if (gimme == G_ARRAY) {
2068         while (++MARK <= SP) {
2069             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2070                         ? *MARK : sv_mortalcopy(*MARK);
2071             TAINT_NOT;          /* Each item is independent */
2072         }
2073     }
2074     SP = newsp;
2075     PUTBACK;
2076
2077     LEAVE;
2078     cxstack_ix--;
2079     /* Stack values are safe: */
2080     switch (pop2) {
2081     case CXt_LOOP:
2082         POPLOOP(cx);    /* release loop vars ... */
2083         LEAVE;
2084         break;
2085     case CXt_SUB:
2086         POPSUB(cx,sv);  /* release CV and @_ ... */
2087         break;
2088     }
2089     PL_curpm = newpm;   /* ... and pop $1 et al */
2090
2091     LEAVESUB(sv);
2092     PERL_UNUSED_VAR(optype);
2093     PERL_UNUSED_VAR(gimme);
2094     return nextop;
2095 }
2096
2097 PP(pp_next)
2098 {
2099     dVAR;
2100     I32 cxix;
2101     register PERL_CONTEXT *cx;
2102     I32 inner;
2103
2104     if (PL_op->op_flags & OPf_SPECIAL) {
2105         cxix = dopoptoloop(cxstack_ix);
2106         if (cxix < 0)
2107             DIE(aTHX_ "Can't \"next\" outside a loop block");
2108     }
2109     else {
2110         cxix = dopoptolabel(cPVOP->op_pv);
2111         if (cxix < 0)
2112             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2113     }
2114     if (cxix < cxstack_ix)
2115         dounwind(cxix);
2116
2117     /* clear off anything above the scope we're re-entering, but
2118      * save the rest until after a possible continue block */
2119     inner = PL_scopestack_ix;
2120     TOPBLOCK(cx);
2121     if (PL_scopestack_ix < inner)
2122         leave_scope(PL_scopestack[PL_scopestack_ix]);
2123     PL_curcop = cx->blk_oldcop;
2124     return cx->blk_loop.next_op;
2125 }
2126
2127 PP(pp_redo)
2128 {
2129     dVAR;
2130     I32 cxix;
2131     register PERL_CONTEXT *cx;
2132     I32 oldsave;
2133     OP* redo_op;
2134
2135     if (PL_op->op_flags & OPf_SPECIAL) {
2136         cxix = dopoptoloop(cxstack_ix);
2137         if (cxix < 0)
2138             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2139     }
2140     else {
2141         cxix = dopoptolabel(cPVOP->op_pv);
2142         if (cxix < 0)
2143             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2144     }
2145     if (cxix < cxstack_ix)
2146         dounwind(cxix);
2147
2148     redo_op = cxstack[cxix].blk_loop.redo_op;
2149     if (redo_op->op_type == OP_ENTER) {
2150         /* pop one less context to avoid $x being freed in while (my $x..) */
2151         cxstack_ix++;
2152         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2153         redo_op = redo_op->op_next;
2154     }
2155
2156     TOPBLOCK(cx);
2157     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2158     LEAVE_SCOPE(oldsave);
2159     FREETMPS;
2160     PL_curcop = cx->blk_oldcop;
2161     return redo_op;
2162 }
2163
2164 STATIC OP *
2165 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2166 {
2167     OP **ops = opstack;
2168     static const char too_deep[] = "Target of goto is too deeply nested";
2169
2170     if (ops >= oplimit)
2171         Perl_croak(aTHX_ too_deep);
2172     if (o->op_type == OP_LEAVE ||
2173         o->op_type == OP_SCOPE ||
2174         o->op_type == OP_LEAVELOOP ||
2175         o->op_type == OP_LEAVESUB ||
2176         o->op_type == OP_LEAVETRY)
2177     {
2178         *ops++ = cUNOPo->op_first;
2179         if (ops >= oplimit)
2180             Perl_croak(aTHX_ too_deep);
2181     }
2182     *ops = 0;
2183     if (o->op_flags & OPf_KIDS) {
2184         OP *kid;
2185         /* First try all the kids at this level, since that's likeliest. */
2186         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2187             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2188                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2189                 return kid;
2190         }
2191         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2192             if (kid == PL_lastgotoprobe)
2193                 continue;
2194             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2195                 if (ops == opstack)
2196                     *ops++ = kid;
2197                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2198                          ops[-1]->op_type == OP_DBSTATE)
2199                     ops[-1] = kid;
2200                 else
2201                     *ops++ = kid;
2202             }
2203             if ((o = dofindlabel(kid, label, ops, oplimit)))
2204                 return o;
2205         }
2206     }
2207     *ops = 0;
2208     return 0;
2209 }
2210
2211 PP(pp_goto)
2212 {
2213     dVAR; dSP;
2214     OP *retop = 0;
2215     I32 ix;
2216     register PERL_CONTEXT *cx;
2217 #define GOTO_DEPTH 64
2218     OP *enterops[GOTO_DEPTH];
2219     const char *label = 0;
2220     const bool do_dump = (PL_op->op_type == OP_DUMP);
2221     static const char must_have_label[] = "goto must have label";
2222
2223     if (PL_op->op_flags & OPf_STACKED) {
2224         SV * const sv = POPs;
2225
2226         /* This egregious kludge implements goto &subroutine */
2227         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2228             I32 cxix;
2229             register PERL_CONTEXT *cx;
2230             CV* cv = (CV*)SvRV(sv);
2231             SV** mark;
2232             I32 items = 0;
2233             I32 oldsave;
2234             bool reified = 0;
2235
2236         retry:
2237             if (!CvROOT(cv) && !CvXSUB(cv)) {
2238                 const GV * const gv = CvGV(cv);
2239                 if (gv) {
2240                     GV *autogv;
2241                     SV *tmpstr;
2242                     /* autoloaded stub? */
2243                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2244                         goto retry;
2245                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2246                                           GvNAMELEN(gv), FALSE);
2247                     if (autogv && (cv = GvCV(autogv)))
2248                         goto retry;
2249                     tmpstr = sv_newmortal();
2250                     gv_efullname3(tmpstr, gv, Nullch);
2251                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2252                 }
2253                 DIE(aTHX_ "Goto undefined subroutine");
2254             }
2255
2256             /* First do some returnish stuff. */
2257             (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2258             FREETMPS;
2259             cxix = dopoptosub(cxstack_ix);
2260             if (cxix < 0)
2261                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2262             if (cxix < cxstack_ix)
2263                 dounwind(cxix);
2264             TOPBLOCK(cx);
2265             SPAGAIN;
2266             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2267             if (CxTYPE(cx) == CXt_EVAL) {
2268                 if (CxREALEVAL(cx))
2269                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2270                 else
2271                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2272             }
2273             else if (CxMULTICALL(cx))
2274                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2275             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2276                 /* put @_ back onto stack */
2277                 AV* av = cx->blk_sub.argarray;
2278
2279                 items = AvFILLp(av) + 1;
2280                 EXTEND(SP, items+1); /* @_ could have been extended. */
2281                 Copy(AvARRAY(av), SP + 1, items, SV*);
2282                 SvREFCNT_dec(GvAV(PL_defgv));
2283                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2284                 CLEAR_ARGARRAY(av);
2285                 /* abandon @_ if it got reified */
2286                 if (AvREAL(av)) {
2287                     reified = 1;
2288                     SvREFCNT_dec(av);
2289                     av = newAV();
2290                     av_extend(av, items-1);
2291                     AvREIFY_only(av);
2292                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2293                 }
2294             }
2295             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2296                 AV* const av = GvAV(PL_defgv);
2297                 items = AvFILLp(av) + 1;
2298                 EXTEND(SP, items+1); /* @_ could have been extended. */
2299                 Copy(AvARRAY(av), SP + 1, items, SV*);
2300             }
2301             mark = SP;
2302             SP += items;
2303             if (CxTYPE(cx) == CXt_SUB &&
2304                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2305                 SvREFCNT_dec(cx->blk_sub.cv);
2306             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2307             LEAVE_SCOPE(oldsave);
2308
2309             /* Now do some callish stuff. */
2310             SAVETMPS;
2311             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2312             if (CvXSUB(cv)) {
2313                 OP* retop = cx->blk_sub.retop;
2314                 if (reified) {
2315                     I32 index;
2316                     for (index=0; index<items; index++)
2317                         sv_2mortal(SP[-index]);
2318                 }
2319 #ifdef PERL_XSUB_OLDSTYLE
2320                 if (CvOLDSTYLE(cv)) {
2321                     I32 (*fp3)(int,int,int);
2322                     while (SP > mark) {
2323                         SP[1] = SP[0];
2324                         SP--;
2325                     }
2326                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2327                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2328                                    mark - PL_stack_base + 1,
2329                                    items);
2330                     SP = PL_stack_base + items;
2331                 }
2332                 else
2333 #endif /* PERL_XSUB_OLDSTYLE */
2334                 {
2335                     SV **newsp;
2336                     I32 gimme;
2337
2338                     /* XS subs don't have a CxSUB, so pop it */
2339                     POPBLOCK(cx, PL_curpm);
2340                     /* Push a mark for the start of arglist */
2341                     PUSHMARK(mark);
2342                     PUTBACK;
2343                     (void)(*CvXSUB(cv))(aTHX_ cv);
2344                     /* Put these at the bottom since the vars are set but not used */
2345                     PERL_UNUSED_VAR(newsp);
2346                     PERL_UNUSED_VAR(gimme);
2347                 }
2348                 LEAVE;
2349                 return retop;
2350             }
2351             else {
2352                 AV* padlist = CvPADLIST(cv);
2353                 if (CxTYPE(cx) == CXt_EVAL) {
2354                     PL_in_eval = cx->blk_eval.old_in_eval;
2355                     PL_eval_root = cx->blk_eval.old_eval_root;
2356                     cx->cx_type = CXt_SUB;
2357                     cx->blk_sub.hasargs = 0;
2358                 }
2359                 cx->blk_sub.cv = cv;
2360                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2361
2362                 CvDEPTH(cv)++;
2363                 if (CvDEPTH(cv) < 2)
2364                     (void)SvREFCNT_inc(cv);
2365                 else {
2366                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2367                         sub_crush_depth(cv);
2368                     pad_push(padlist, CvDEPTH(cv));
2369                 }
2370                 SAVECOMPPAD();
2371                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2372                 if (cx->blk_sub.hasargs)
2373                 {
2374                     AV* av = (AV*)PAD_SVl(0);
2375                     SV** ary;
2376
2377                     cx->blk_sub.savearray = GvAV(PL_defgv);
2378                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2379                     CX_CURPAD_SAVE(cx->blk_sub);
2380                     cx->blk_sub.argarray = av;
2381
2382                     if (items >= AvMAX(av) + 1) {
2383                         ary = AvALLOC(av);
2384                         if (AvARRAY(av) != ary) {
2385                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2386                             SvPV_set(av, (char*)ary);
2387                         }
2388                         if (items >= AvMAX(av) + 1) {
2389                             AvMAX(av) = items - 1;
2390                             Renew(ary,items+1,SV*);
2391                             AvALLOC(av) = ary;
2392                             SvPV_set(av, (char*)ary);
2393                         }
2394                     }
2395                     ++mark;
2396                     Copy(mark,AvARRAY(av),items,SV*);
2397                     AvFILLp(av) = items - 1;
2398                     assert(!AvREAL(av));
2399                     if (reified) {
2400                         /* transfer 'ownership' of refcnts to new @_ */
2401                         AvREAL_on(av);
2402                         AvREIFY_off(av);
2403                     }
2404                     while (items--) {
2405                         if (*mark)
2406                             SvTEMP_off(*mark);
2407                         mark++;
2408                     }
2409                 }
2410                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2411                     /*
2412                      * We do not care about using sv to call CV;
2413                      * it's for informational purposes only.
2414                      */
2415                     SV * const sv = GvSV(PL_DBsub);
2416                     CV *gotocv;
2417
2418                     save_item(sv);
2419                     if (PERLDB_SUB_NN) {
2420                         const int type = SvTYPE(sv);
2421                         if (type < SVt_PVIV && type != SVt_IV)
2422                             sv_upgrade(sv, SVt_PVIV);
2423                         (void)SvIOK_on(sv);
2424                         SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2425                     } else {
2426                         gv_efullname3(sv, CvGV(cv), Nullch);
2427                     }
2428                     if (  PERLDB_GOTO
2429                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2430                         PUSHMARK( PL_stack_sp );
2431                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2432                         PL_stack_sp--;
2433                     }
2434                 }
2435                 RETURNOP(CvSTART(cv));
2436             }
2437         }
2438         else {
2439             label = SvPV_nolen_const(sv);
2440             if (!(do_dump || *label))
2441                 DIE(aTHX_ must_have_label);
2442         }
2443     }
2444     else if (PL_op->op_flags & OPf_SPECIAL) {
2445         if (! do_dump)
2446             DIE(aTHX_ must_have_label);
2447     }
2448     else
2449         label = cPVOP->op_pv;
2450
2451     if (label && *label) {
2452         OP *gotoprobe = 0;
2453         bool leaving_eval = FALSE;
2454         bool in_block = FALSE;
2455         PERL_CONTEXT *last_eval_cx = 0;
2456
2457         /* find label */
2458
2459         PL_lastgotoprobe = 0;
2460         *enterops = 0;
2461         for (ix = cxstack_ix; ix >= 0; ix--) {
2462             cx = &cxstack[ix];
2463             switch (CxTYPE(cx)) {
2464             case CXt_EVAL:
2465                 leaving_eval = TRUE;
2466                 if (!CxTRYBLOCK(cx)) {
2467                     gotoprobe = (last_eval_cx ?
2468                                 last_eval_cx->blk_eval.old_eval_root :
2469                                 PL_eval_root);
2470                     last_eval_cx = cx;
2471                     break;
2472                 }
2473                 /* else fall through */
2474             case CXt_LOOP:
2475                 gotoprobe = cx->blk_oldcop->op_sibling;
2476                 break;
2477             case CXt_SUBST:
2478                 continue;
2479             case CXt_BLOCK:
2480                 if (ix) {
2481                     gotoprobe = cx->blk_oldcop->op_sibling;
2482                     in_block = TRUE;
2483                 } else
2484                     gotoprobe = PL_main_root;
2485                 break;
2486             case CXt_SUB:
2487                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2488                     gotoprobe = CvROOT(cx->blk_sub.cv);
2489                     break;
2490                 }
2491                 /* FALL THROUGH */
2492             case CXt_FORMAT:
2493             case CXt_NULL:
2494                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2495             default:
2496                 if (ix)
2497                     DIE(aTHX_ "panic: goto");
2498                 gotoprobe = PL_main_root;
2499                 break;
2500             }
2501             if (gotoprobe) {
2502                 retop = dofindlabel(gotoprobe, label,
2503                                     enterops, enterops + GOTO_DEPTH);
2504                 if (retop)
2505                     break;
2506             }
2507             PL_lastgotoprobe = gotoprobe;
2508         }
2509         if (!retop)
2510             DIE(aTHX_ "Can't find label %s", label);
2511
2512         /* if we're leaving an eval, check before we pop any frames
2513            that we're not going to punt, otherwise the error
2514            won't be caught */
2515
2516         if (leaving_eval && *enterops && enterops[1]) {
2517             I32 i;
2518             for (i = 1; enterops[i]; i++)
2519                 if (enterops[i]->op_type == OP_ENTERITER)
2520                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2521         }
2522
2523         /* pop unwanted frames */
2524
2525         if (ix < cxstack_ix) {
2526             I32 oldsave;
2527
2528             if (ix < 0)
2529                 ix = 0;
2530             dounwind(ix);
2531             TOPBLOCK(cx);
2532             oldsave = PL_scopestack[PL_scopestack_ix];
2533             LEAVE_SCOPE(oldsave);
2534         }
2535
2536         /* push wanted frames */
2537
2538         if (*enterops && enterops[1]) {
2539             OP *oldop = PL_op;
2540             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2541             for (; enterops[ix]; ix++) {
2542                 PL_op = enterops[ix];
2543                 /* Eventually we may want to stack the needed arguments
2544                  * for each op.  For now, we punt on the hard ones. */
2545                 if (PL_op->op_type == OP_ENTERITER)
2546                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2547                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2548             }
2549             PL_op = oldop;
2550         }
2551     }
2552
2553     if (do_dump) {
2554 #ifdef VMS
2555         if (!retop) retop = PL_main_start;
2556 #endif
2557         PL_restartop = retop;
2558         PL_do_undump = TRUE;
2559
2560         my_unexec();
2561
2562         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2563         PL_do_undump = FALSE;
2564     }
2565
2566     RETURNOP(retop);
2567 }
2568
2569 PP(pp_exit)
2570 {
2571     dSP;
2572     I32 anum;
2573
2574     if (MAXARG < 1)
2575         anum = 0;
2576     else {
2577         anum = SvIVx(POPs);
2578 #ifdef VMS
2579         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2580             anum = 0;
2581         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2582 #endif
2583     }
2584     PL_exit_flags |= PERL_EXIT_EXPECTED;
2585     my_exit(anum);
2586     PUSHs(&PL_sv_undef);
2587     RETURN;
2588 }
2589
2590 #ifdef NOTYET
2591 PP(pp_nswitch)
2592 {
2593     dSP;
2594     const NV value = SvNVx(GvSV(cCOP->cop_gv));
2595     register I32 match = I_32(value);
2596
2597     if (value < 0.0) {
2598         if (((NV)match) > value)
2599             --match;            /* was fractional--truncate other way */
2600     }
2601     match -= cCOP->uop.scop.scop_offset;
2602     if (match < 0)
2603         match = 0;
2604     else if (match > cCOP->uop.scop.scop_max)
2605         match = cCOP->uop.scop.scop_max;
2606     PL_op = cCOP->uop.scop.scop_next[match];
2607     RETURNOP(PL_op);
2608 }
2609
2610 PP(pp_cswitch)
2611 {
2612     dSP;
2613     register I32 match;
2614
2615     if (PL_multiline)
2616         PL_op = PL_op->op_next;                 /* can't assume anything */
2617     else {
2618         match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
2619         match -= cCOP->uop.scop.scop_offset;
2620         if (match < 0)
2621             match = 0;
2622         else if (match > cCOP->uop.scop.scop_max)
2623             match = cCOP->uop.scop.scop_max;
2624         PL_op = cCOP->uop.scop.scop_next[match];
2625     }
2626     RETURNOP(PL_op);
2627 }
2628 #endif
2629
2630 /* Eval. */
2631
2632 STATIC void
2633 S_save_lines(pTHX_ AV *array, SV *sv)
2634 {
2635     const char *s = SvPVX_const(sv);
2636     const char * const send = SvPVX_const(sv) + SvCUR(sv);
2637     I32 line = 1;
2638
2639     while (s && s < send) {
2640         const char *t;
2641         SV * const tmpstr = NEWSV(85,0);
2642
2643         sv_upgrade(tmpstr, SVt_PVMG);
2644         t = strchr(s, '\n');
2645         if (t)
2646             t++;
2647         else
2648             t = send;
2649
2650         sv_setpvn(tmpstr, s, t - s);
2651         av_store(array, line++, tmpstr);
2652         s = t;
2653     }
2654 }
2655
2656 STATIC void
2657 S_docatch_body(pTHX)
2658 {
2659     CALLRUNOPS(aTHX);
2660     return;
2661 }
2662
2663 STATIC OP *
2664 S_docatch(pTHX_ OP *o)
2665 {
2666     int ret;
2667     OP * const oldop = PL_op;
2668     dJMPENV;
2669
2670 #ifdef DEBUGGING
2671     assert(CATCH_GET == TRUE);
2672 #endif
2673     PL_op = o;
2674
2675     JMPENV_PUSH(ret);
2676     switch (ret) {
2677     case 0:
2678         assert(cxstack_ix >= 0);
2679         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2680         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2681  redo_body:
2682         docatch_body();
2683         break;
2684     case 3:
2685         /* die caught by an inner eval - continue inner loop */
2686
2687         /* NB XXX we rely on the old popped CxEVAL still being at the top
2688          * of the stack; the way die_where() currently works, this
2689          * assumption is valid. In theory The cur_top_env value should be
2690          * returned in another global, the way retop (aka PL_restartop)
2691          * is. */
2692         assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2693
2694         if (PL_restartop
2695             && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2696         {
2697             PL_op = PL_restartop;
2698             PL_restartop = 0;
2699             goto redo_body;
2700         }
2701         /* FALL THROUGH */
2702     default:
2703         JMPENV_POP;
2704         PL_op = oldop;
2705         JMPENV_JUMP(ret);
2706         /* NOTREACHED */
2707     }
2708     JMPENV_POP;
2709     PL_op = oldop;
2710     return Nullop;
2711 }
2712
2713 OP *
2714 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2715 /* sv Text to convert to OP tree. */
2716 /* startop op_free() this to undo. */
2717 /* code Short string id of the caller. */
2718 {
2719     /* FIXME - how much of this code is common with pp_entereval?  */
2720     dVAR; dSP;                          /* Make POPBLOCK work. */
2721     PERL_CONTEXT *cx;
2722     SV **newsp;
2723     I32 gimme = G_VOID;
2724     I32 optype;
2725     OP dummy;
2726     OP *rop;
2727     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2728     char *tmpbuf = tbuf;
2729     char *safestr;
2730     int runtime;
2731     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2732     STRLEN len;
2733
2734     ENTER;
2735     lex_start(sv);
2736     SAVETMPS;
2737     /* switch to eval mode */
2738
2739     if (IN_PERL_COMPILETIME) {
2740         SAVECOPSTASH_FREE(&PL_compiling);
2741         CopSTASH_set(&PL_compiling, PL_curstash);
2742     }
2743     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2744         SV * const sv = sv_newmortal();
2745         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2746                        code, (unsigned long)++PL_evalseq,
2747                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2748         tmpbuf = SvPVX(sv);
2749     }
2750     else
2751         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2752     SAVECOPFILE_FREE(&PL_compiling);
2753     CopFILE_set(&PL_compiling, tmpbuf+2);
2754     SAVECOPLINE(&PL_compiling);
2755     CopLINE_set(&PL_compiling, 1);
2756     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2757        deleting the eval's FILEGV from the stash before gv_check() runs
2758        (i.e. before run-time proper). To work around the coredump that
2759        ensues, we always turn GvMULTI_on for any globals that were
2760        introduced within evals. See force_ident(). GSAR 96-10-12 */
2761     len = strlen(tmpbuf);
2762     safestr = savepvn(tmpbuf, len);
2763     SAVEDELETE(PL_defstash, safestr, len);
2764     SAVEHINTS();
2765 #ifdef OP_IN_REGISTER
2766     PL_opsave = op;
2767 #else
2768     SAVEVPTR(PL_op);
2769 #endif
2770
2771     /* we get here either during compilation, or via pp_regcomp at runtime */
2772     runtime = IN_PERL_RUNTIME;
2773     if (runtime)
2774         runcv = find_runcv(NULL);
2775
2776     PL_op = &dummy;
2777     PL_op->op_type = OP_ENTEREVAL;
2778     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2779     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2780     PUSHEVAL(cx, 0, Nullgv);
2781
2782     if (runtime)
2783         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2784     else
2785         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2786     POPBLOCK(cx,PL_curpm);
2787     POPEVAL(cx);
2788
2789     (*startop)->op_type = OP_NULL;
2790     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2791     lex_end();
2792     /* XXX DAPM do this properly one year */
2793     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2794     LEAVE;
2795     if (IN_PERL_COMPILETIME)
2796         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2797 #ifdef OP_IN_REGISTER
2798     op = PL_opsave;
2799 #endif
2800     PERL_UNUSED_VAR(newsp);
2801     PERL_UNUSED_VAR(optype);
2802
2803     return rop;
2804 }
2805
2806
2807 /*
2808 =for apidoc find_runcv
2809
2810 Locate the CV corresponding to the currently executing sub or eval.
2811 If db_seqp is non_null, skip CVs that are in the DB package and populate
2812 *db_seqp with the cop sequence number at the point that the DB:: code was
2813 entered. (allows debuggers to eval in the scope of the breakpoint rather
2814 than in the scope of the debugger itself).
2815
2816 =cut
2817 */
2818
2819 CV*
2820 Perl_find_runcv(pTHX_ U32 *db_seqp)
2821 {
2822     PERL_SI      *si;
2823
2824     if (db_seqp)
2825         *db_seqp = PL_curcop->cop_seq;
2826     for (si = PL_curstackinfo; si; si = si->si_prev) {
2827         I32 ix;
2828         for (ix = si->si_cxix; ix >= 0; ix--) {
2829             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2830             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2831                 CV * const cv = cx->blk_sub.cv;
2832                 /* skip DB:: code */
2833                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2834                     *db_seqp = cx->blk_oldcop->cop_seq;
2835                     continue;
2836                 }
2837                 return cv;
2838             }
2839             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2840                 return PL_compcv;
2841         }
2842     }
2843     return PL_main_cv;
2844 }
2845
2846
2847 /* Compile a require/do, an eval '', or a /(?{...})/.
2848  * In the last case, startop is non-null, and contains the address of
2849  * a pointer that should be set to the just-compiled code.
2850  * outside is the lexically enclosing CV (if any) that invoked us.
2851  */
2852
2853 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2854 STATIC OP *
2855 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2856 {
2857     dVAR; dSP;
2858     OP * const saveop = PL_op;
2859
2860     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2861                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2862                   : EVAL_INEVAL);
2863
2864     PUSHMARK(SP);
2865
2866     SAVESPTR(PL_compcv);
2867     PL_compcv = (CV*)NEWSV(1104,0);
2868     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2869     CvEVAL_on(PL_compcv);
2870     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2871     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2872
2873     CvOUTSIDE_SEQ(PL_compcv) = seq;
2874     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2875
2876     /* set up a scratch pad */
2877
2878     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2879
2880
2881     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2882
2883     /* make sure we compile in the right package */
2884
2885     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2886         SAVESPTR(PL_curstash);
2887         PL_curstash = CopSTASH(PL_curcop);
2888     }
2889     SAVESPTR(PL_beginav);
2890     PL_beginav = newAV();
2891     SAVEFREESV(PL_beginav);
2892     SAVEI32(PL_error_count);
2893
2894     /* try to compile it */
2895
2896     PL_eval_root = Nullop;
2897     PL_error_count = 0;
2898     PL_curcop = &PL_compiling;
2899     PL_curcop->cop_arybase = 0;
2900     if (saveop && saveop->op_flags & OPf_SPECIAL)
2901         PL_in_eval |= EVAL_KEEPERR;
2902     else
2903         sv_setpvn(ERRSV,"",0);
2904     if (yyparse() || PL_error_count || !PL_eval_root) {
2905         SV **newsp;                     /* Used by POPBLOCK. */
2906         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2907         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2908         const char *msg;
2909
2910         PL_op = saveop;
2911         if (PL_eval_root) {
2912             op_free(PL_eval_root);
2913             PL_eval_root = Nullop;
2914         }
2915         SP = PL_stack_base + POPMARK;           /* pop original mark */
2916         if (!startop) {
2917             POPBLOCK(cx,PL_curpm);
2918             POPEVAL(cx);
2919         }
2920         lex_end();
2921         LEAVE;
2922
2923         msg = SvPVx_nolen_const(ERRSV);
2924         if (optype == OP_REQUIRE) {
2925             const SV * const nsv = cx->blk_eval.old_namesv;
2926             (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2927                           &PL_sv_undef, 0);
2928             DIE(aTHX_ "%sCompilation failed in require",
2929                 *msg ? msg : "Unknown error\n");
2930         }
2931         else if (startop) {
2932             POPBLOCK(cx,PL_curpm);
2933             POPEVAL(cx);
2934             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2935                        (*msg ? msg : "Unknown error\n"));
2936         }
2937         else {
2938             if (!*msg) {
2939                 sv_setpv(ERRSV, "Compilation error");
2940             }
2941         }
2942         PERL_UNUSED_VAR(newsp);
2943         RETPUSHUNDEF;
2944     }
2945     CopLINE_set(&PL_compiling, 0);
2946     if (startop) {
2947         *startop = PL_eval_root;
2948     } else
2949         SAVEFREEOP(PL_eval_root);
2950
2951     /* Set the context for this new optree.
2952      * If the last op is an OP_REQUIRE, force scalar context.
2953      * Otherwise, propagate the context from the eval(). */
2954     if (PL_eval_root->op_type == OP_LEAVEEVAL
2955             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2956             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2957             == OP_REQUIRE)
2958         scalar(PL_eval_root);
2959     else if (gimme & G_VOID)
2960         scalarvoid(PL_eval_root);
2961     else if (gimme & G_ARRAY)
2962         list(PL_eval_root);
2963     else
2964         scalar(PL_eval_root);
2965
2966     DEBUG_x(dump_eval());
2967
2968     /* Register with debugger: */
2969     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2970         CV * const cv = get_cv("DB::postponed", FALSE);
2971         if (cv) {
2972             dSP;
2973             PUSHMARK(SP);
2974             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2975             PUTBACK;
2976             call_sv((SV*)cv, G_DISCARD);
2977         }
2978     }
2979
2980     /* compiled okay, so do it */
2981
2982     CvDEPTH(PL_compcv) = 1;
2983     SP = PL_stack_base + POPMARK;               /* pop original mark */
2984     PL_op = saveop;                     /* The caller may need it. */
2985     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2986
2987     RETURNOP(PL_eval_start);
2988 }
2989
2990 STATIC PerlIO *
2991 S_doopen_pm(pTHX_ const char *name, const char *mode)
2992 {
2993 #ifndef PERL_DISABLE_PMC
2994     const STRLEN namelen = strlen(name);
2995     PerlIO *fp;
2996
2997     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2998         SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2999         const char * const pmc = SvPV_nolen_const(pmcsv);
3000         Stat_t pmcstat;
3001         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3002             fp = PerlIO_open(name, mode);
3003         }
3004         else {
3005             Stat_t pmstat;
3006             if (PerlLIO_stat(name, &pmstat) < 0 ||
3007                 pmstat.st_mtime < pmcstat.st_mtime)
3008             {
3009                 fp = PerlIO_open(pmc, mode);
3010             }
3011             else {
3012                 fp = PerlIO_open(name, mode);
3013             }
3014         }
3015         SvREFCNT_dec(pmcsv);
3016     }
3017     else {
3018         fp = PerlIO_open(name, mode);
3019     }
3020     return fp;
3021 #else
3022     return PerlIO_open(name, mode);
3023 #endif /* !PERL_DISABLE_PMC */
3024 }
3025
3026 PP(pp_require)
3027 {
3028     dVAR; dSP;
3029     register PERL_CONTEXT *cx;
3030     SV *sv;
3031     const char *name;
3032     STRLEN len;
3033     const char *tryname = Nullch;
3034     SV *namesv = Nullsv;
3035     const I32 gimme = GIMME_V;
3036     PerlIO *tryrsfp = 0;
3037     int filter_has_file = 0;
3038     GV *filter_child_proc = 0;
3039     SV *filter_state = 0;
3040     SV *filter_sub = 0;
3041     SV *hook_sv = 0;
3042     SV *encoding;
3043     OP *op;
3044
3045     sv = POPs;
3046     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3047         if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) )       /* require v5.6.1 */
3048                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3049                         "v-string in use/require non-portable");
3050
3051         sv = new_version(sv);
3052         if (!sv_derived_from(PL_patchlevel, "version"))
3053             (void *)upg_version(PL_patchlevel);
3054         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3055             if ( vcmp(sv,PL_patchlevel) < 0 )
3056                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3057                     vnormal(sv), vnormal(PL_patchlevel));
3058         }
3059         else {
3060             if ( vcmp(sv,PL_patchlevel) > 0 )
3061                 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3062                     vnormal(sv), vnormal(PL_patchlevel));
3063         }
3064
3065             RETPUSHYES;
3066     }
3067     name = SvPV_const(sv, len);
3068     if (!(name && len > 0 && *name))
3069         DIE(aTHX_ "Null filename used");
3070     TAINT_PROPER("require");
3071     if (PL_op->op_type == OP_REQUIRE) {
3072         SV ** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3073         if ( svp ) {
3074             if (*svp != &PL_sv_undef)
3075                 RETPUSHYES;
3076             else
3077                 DIE(aTHX_ "Compilation failed in require");
3078         }
3079     }
3080
3081     /* prepare to compile file */
3082
3083     if (path_is_absolute(name)) {
3084         tryname = name;
3085         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3086     }
3087 #ifdef MACOS_TRADITIONAL
3088     if (!tryrsfp) {
3089         char newname[256];
3090
3091         MacPerl_CanonDir(name, newname, 1);
3092         if (path_is_absolute(newname)) {
3093             tryname = newname;
3094             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3095         }
3096     }
3097 #endif
3098     if (!tryrsfp) {
3099         AV * const ar = GvAVn(PL_incgv);
3100         I32 i;
3101 #ifdef VMS
3102         char *unixname;
3103         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3104 #endif
3105         {
3106             namesv = NEWSV(806, 0);
3107             for (i = 0; i <= AvFILL(ar); i++) {
3108                 SV *dirsv = *av_fetch(ar, i, TRUE);
3109
3110                 if (SvROK(dirsv)) {
3111                     int count;
3112                     SV *loader = dirsv;
3113
3114                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3115                         && !sv_isobject(loader))
3116                     {
3117                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3118                     }
3119
3120                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3121                                    PTR2UV(SvRV(dirsv)), name);
3122                     tryname = SvPVX_const(namesv);
3123                     tryrsfp = 0;
3124
3125                     ENTER;
3126                     SAVETMPS;
3127                     EXTEND(SP, 2);
3128
3129                     PUSHMARK(SP);
3130                     PUSHs(dirsv);
3131                     PUSHs(sv);
3132                     PUTBACK;
3133                     if (sv_isobject(loader))
3134                         count = call_method("INC", G_ARRAY);
3135                     else
3136                         count = call_sv(loader, G_ARRAY);
3137                     SPAGAIN;
3138
3139                     if (count > 0) {
3140                         int i = 0;
3141                         SV *arg;
3142
3143                         SP -= count - 1;
3144                         arg = SP[i++];
3145
3146                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3147                             arg = SvRV(arg);
3148                         }
3149
3150                         if (SvTYPE(arg) == SVt_PVGV) {
3151                             IO *io = GvIO((GV *)arg);
3152
3153                             ++filter_has_file;
3154
3155                             if (io) {
3156                                 tryrsfp = IoIFP(io);
3157                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3158                                     /* reading from a child process doesn't
3159                                        nest -- when returning from reading
3160                                        the inner module, the outer one is
3161                                        unreadable (closed?)  I've tried to
3162                                        save the gv to manage the lifespan of
3163                                        the pipe, but this didn't help. XXX */
3164                                     filter_child_proc = (GV *)arg;
3165                                     (void)SvREFCNT_inc(filter_child_proc);
3166                                 }
3167                                 else {
3168                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3169                                         PerlIO_close(IoOFP(io));
3170                                     }
3171                                     IoIFP(io) = Nullfp;
3172                                     IoOFP(io) = Nullfp;
3173                                 }
3174                             }
3175
3176                             if (i < count) {
3177                                 arg = SP[i++];
3178                             }
3179                         }
3180
3181                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3182                             filter_sub = arg;
3183                             (void)SvREFCNT_inc(filter_sub);
3184
3185                             if (i < count) {
3186                                 filter_state = SP[i];
3187                                 (void)SvREFCNT_inc(filter_state);
3188                             }
3189
3190                             if (tryrsfp == 0) {
3191                                 tryrsfp = PerlIO_open("/dev/null",
3192                                                       PERL_SCRIPT_MODE);
3193                             }
3194                         }
3195                         SP--;
3196                     }
3197
3198                     PUTBACK;
3199                     FREETMPS;
3200                     LEAVE;
3201
3202                     if (tryrsfp) {
3203                         hook_sv = dirsv;
3204                         break;
3205                     }
3206
3207                     filter_has_file = 0;
3208                     if (filter_child_proc) {
3209                         SvREFCNT_dec(filter_child_proc);
3210                         filter_child_proc = 0;
3211                     }
3212                     if (filter_state) {
3213                         SvREFCNT_dec(filter_state);
3214                         filter_state = 0;
3215                     }
3216                     if (filter_sub) {
3217                         SvREFCNT_dec(filter_sub);
3218                         filter_sub = 0;
3219                     }
3220                 }
3221                 else {
3222                   if (!path_is_absolute(name)
3223 #ifdef MACOS_TRADITIONAL
3224                         /* We consider paths of the form :a:b ambiguous and interpret them first
3225                            as global then as local
3226                         */
3227                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3228 #endif
3229                   ) {
3230                     const char *dir = SvPVx_nolen_const(dirsv);
3231 #ifdef MACOS_TRADITIONAL
3232                     char buf1[256];
3233                     char buf2[256];
3234
3235                     MacPerl_CanonDir(name, buf2, 1);
3236                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3237 #else
3238 #  ifdef VMS
3239                     char *unixdir;
3240                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3241                         continue;
3242                     sv_setpv(namesv, unixdir);
3243                     sv_catpv(namesv, unixname);
3244 #  else
3245 #    ifdef __SYMBIAN32__
3246                     if (PL_origfilename[0] &&
3247                         PL_origfilename[1] == ':' &&
3248                         !(dir[0] && dir[1] == ':'))
3249                         Perl_sv_setpvf(aTHX_ namesv,
3250                                        "%c:%s\\%s",
3251                                        PL_origfilename[0],
3252                                        dir, name);
3253                     else
3254                         Perl_sv_setpvf(aTHX_ namesv,
3255                                        "%s\\%s",
3256                                        dir, name);
3257 #    else
3258                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3259 #    endif
3260 #  endif
3261 #endif
3262                     TAINT_PROPER("require");
3263                     tryname = SvPVX_const(namesv);
3264                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3265                     if (tryrsfp) {
3266                         if (tryname[0] == '.' && tryname[1] == '/')
3267                             tryname += 2;
3268                         break;
3269                     }
3270                   }
3271                 }
3272             }
3273         }
3274     }
3275     SAVECOPFILE_FREE(&PL_compiling);
3276     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3277     SvREFCNT_dec(namesv);
3278     if (!tryrsfp) {
3279         if (PL_op->op_type == OP_REQUIRE) {
3280             const char *msgstr = name;
3281             if(errno == EMFILE) {
3282                 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3283                 sv_catpv(msg, ":  "); 
3284                 sv_catpv(msg, Strerror(errno));
3285                 msgstr = SvPV_nolen_const(msg);
3286             } else {
3287                 if (namesv) {                   /* did we lookup @INC? */
3288                     SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3289                     SV * const dirmsgsv = NEWSV(0, 0);
3290                     AV * const ar = GvAVn(PL_incgv);
3291                     I32 i;
3292                     sv_catpvn(msg, " in @INC", 8);
3293                     if (instr(SvPVX_const(msg), ".h "))
3294                         sv_catpv(msg, " (change .h to .ph maybe?)");
3295                     if (instr(SvPVX_const(msg), ".ph "))
3296                         sv_catpv(msg, " (did you run h2ph?)");
3297                     sv_catpv(msg, " (@INC contains:");
3298                     for (i = 0; i <= AvFILL(ar); i++) {
3299                         const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3300                         Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3301                         sv_catsv(msg, dirmsgsv);
3302                     }
3303                     sv_catpvn(msg, ")", 1);
3304                     SvREFCNT_dec(dirmsgsv);
3305                     msgstr = SvPV_nolen_const(msg);
3306                 }    
3307             }
3308             DIE(aTHX_ "Can't locate %s", msgstr);
3309         }
3310
3311         RETPUSHUNDEF;
3312     }
3313     else
3314         SETERRNO(0, SS_NORMAL);
3315
3316     /* FIXME - is name ever assigned to after the SvPVX_const that also set
3317        len?  If no, then this strlen() is superfluous.  */
3318     /* Assume success here to prevent recursive requirement. */
3319     len = strlen(name);
3320     /* Check whether a hook in @INC has already filled %INC */
3321     if (!hook_sv) {
3322         (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3323     } else {
3324         SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3325         if (!svp)
3326             (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
3327     }
3328
3329     ENTER;
3330     SAVETMPS;
3331     lex_start(sv_2mortal(newSVpvn("",0)));
3332     SAVEGENERICSV(PL_rsfp_filters);
3333     PL_rsfp_filters = Nullav;
3334
3335     PL_rsfp = tryrsfp;
3336     SAVEHINTS();
3337     PL_hints = 0;
3338     SAVESPTR(PL_compiling.cop_warnings);
3339     if (PL_dowarn & G_WARN_ALL_ON)
3340         PL_compiling.cop_warnings = pWARN_ALL ;
3341     else if (PL_dowarn & G_WARN_ALL_OFF)
3342         PL_compiling.cop_warnings = pWARN_NONE ;
3343     else if (PL_taint_warn)
3344         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3345     else
3346         PL_compiling.cop_warnings = pWARN_STD ;
3347     SAVESPTR(PL_compiling.cop_io);
3348     PL_compiling.cop_io = Nullsv;
3349
3350     if (filter_sub || filter_child_proc) {
3351         SV * const datasv = filter_add(run_user_filter, Nullsv);
3352         IoLINES(datasv) = filter_has_file;
3353         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3354         IoTOP_GV(datasv) = (GV *)filter_state;
3355         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3356     }
3357
3358     /* switch to eval mode */
3359     PUSHBLOCK(cx, CXt_EVAL, SP);
3360     PUSHEVAL(cx, name, Nullgv);
3361     cx->blk_eval.retop = PL_op->op_next;
3362
3363     SAVECOPLINE(&PL_compiling);
3364     CopLINE_set(&PL_compiling, 0);
3365
3366     PUTBACK;
3367
3368     /* Store and reset encoding. */
3369     encoding = PL_encoding;
3370     PL_encoding = Nullsv;
3371
3372     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3373
3374     /* Restore encoding. */
3375     PL_encoding = encoding;
3376
3377     return op;
3378 }
3379
3380 PP(pp_entereval)
3381 {
3382     dVAR; dSP;
3383     register PERL_CONTEXT *cx;
3384     dPOPss;
3385     const I32 gimme = GIMME_V;
3386     const I32 was = PL_sub_generation;
3387     char tbuf[TYPE_DIGITS(long) + 12];
3388     char *tmpbuf = tbuf;
3389     char *safestr;
3390     STRLEN len;
3391     OP *ret;
3392     CV* runcv;
3393     U32 seq;
3394
3395     if (!SvPV_nolen_const(sv))
3396         RETPUSHUNDEF;
3397     TAINT_PROPER("eval");
3398
3399     ENTER;
3400     lex_start(sv);
3401     SAVETMPS;
3402
3403     /* switch to eval mode */
3404
3405     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3406         SV * const sv = sv_newmortal();
3407         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3408                        (unsigned long)++PL_evalseq,
3409                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3410         tmpbuf = SvPVX(sv);
3411     }
3412     else
3413         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3414     SAVECOPFILE_FREE(&PL_compiling);
3415     CopFILE_set(&PL_compiling, tmpbuf+2);
3416     SAVECOPLINE(&PL_compiling);
3417     CopLINE_set(&PL_compiling, 1);
3418     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3419        deleting the eval's FILEGV from the stash before gv_check() runs
3420        (i.e. before run-time proper). To work around the coredump that
3421        ensues, we always turn GvMULTI_on for any globals that were
3422        introduced within evals. See force_ident(). GSAR 96-10-12 */
3423     len = strlen(tmpbuf);
3424     safestr = savepvn(tmpbuf, len);
3425     SAVEDELETE(PL_defstash, safestr, len);
3426     SAVEHINTS();
3427     PL_hints = PL_op->op_targ;
3428     SAVESPTR(PL_compiling.cop_warnings);
3429     if (specialWARN(PL_curcop->cop_warnings))
3430         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3431     else {
3432         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3433         SAVEFREESV(PL_compiling.cop_warnings);
3434     }
3435     SAVESPTR(PL_compiling.cop_io);
3436     if (specialCopIO(PL_curcop->cop_io))
3437         PL_compiling.cop_io = PL_curcop->cop_io;
3438     else {
3439         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3440         SAVEFREESV(PL_compiling.cop_io);
3441     }
3442     /* special case: an eval '' executed within the DB package gets lexically
3443      * placed in the first non-DB CV rather than the current CV - this
3444      * allows the debugger to execute code, find lexicals etc, in the
3445      * scope of the code being debugged. Passing &seq gets find_runcv
3446      * to do the dirty work for us */
3447     runcv = find_runcv(&seq);
3448
3449     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3450     PUSHEVAL(cx, 0, Nullgv);
3451     cx->blk_eval.retop = PL_op->op_next;
3452
3453     /* prepare to compile string */
3454
3455     if (PERLDB_LINE && PL_curstash != PL_debstash)
3456         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3457     PUTBACK;
3458     ret = doeval(gimme, NULL, runcv, seq);
3459     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3460         && ret != PL_op->op_next) {     /* Successive compilation. */
3461         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3462     }
3463     return DOCATCH(ret);
3464 }
3465
3466 PP(pp_leaveeval)
3467 {
3468     dVAR; dSP;
3469     register SV **mark;
3470     SV **newsp;
3471     PMOP *newpm;
3472     I32 gimme;
3473     register PERL_CONTEXT *cx;
3474     OP *retop;
3475     const U8 save_flags = PL_op -> op_flags;
3476     I32 optype;
3477
3478     POPBLOCK(cx,newpm);
3479     POPEVAL(cx);
3480     retop = cx->blk_eval.retop;
3481
3482     TAINT_NOT;
3483     if (gimme == G_VOID)
3484         MARK = newsp;
3485     else if (gimme == G_SCALAR) {
3486         MARK = newsp + 1;
3487         if (MARK <= SP) {
3488             if (SvFLAGS(TOPs) & SVs_TEMP)
3489                 *MARK = TOPs;
3490             else
3491                 *MARK = sv_mortalcopy(TOPs);
3492         }
3493         else {
3494             MEXTEND(mark,0);
3495             *MARK = &PL_sv_undef;
3496         }
3497         SP = MARK;
3498     }
3499     else {
3500         /* in case LEAVE wipes old return values */
3501         for (mark = newsp + 1; mark <= SP; mark++) {
3502             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3503                 *mark = sv_mortalcopy(*mark);
3504                 TAINT_NOT;      /* Each item is independent */
3505             }
3506         }
3507     }
3508     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3509
3510 #ifdef DEBUGGING
3511     assert(CvDEPTH(PL_compcv) == 1);
3512 #endif
3513     CvDEPTH(PL_compcv) = 0;
3514     lex_end();
3515
3516     if (optype == OP_REQUIRE &&
3517         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3518     {
3519         /* Unassume the success we assumed earlier. */
3520         SV * const nsv = cx->blk_eval.old_namesv;
3521         (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3522         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3523         /* die_where() did LEAVE, or we won't be here */
3524     }
3525     else {
3526         LEAVE;
3527         if (!(save_flags & OPf_SPECIAL))
3528             sv_setpvn(ERRSV,"",0);
3529     }
3530
3531     RETURNOP(retop);
3532 }
3533
3534 PP(pp_entertry)
3535 {
3536     dVAR; dSP;
3537     register PERL_CONTEXT *cx;
3538     const I32 gimme = GIMME_V;
3539
3540     ENTER;
3541     SAVETMPS;
3542
3543     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3544     PUSHEVAL(cx, 0, 0);
3545     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3546
3547     PL_in_eval = EVAL_INEVAL;
3548     sv_setpvn(ERRSV,"",0);
3549     PUTBACK;
3550     return DOCATCH(PL_op->op_next);
3551 }
3552
3553 PP(pp_leavetry)
3554 {
3555     dVAR; dSP;
3556     register SV **mark;
3557     SV **newsp;
3558     PMOP *newpm;
3559     I32 gimme;
3560     register PERL_CONTEXT *cx;
3561     I32 optype;
3562
3563     POPBLOCK(cx,newpm);
3564     POPEVAL(cx);
3565     PERL_UNUSED_VAR(optype);
3566
3567     TAINT_NOT;
3568     if (gimme == G_VOID)
3569         SP = newsp;
3570     else if (gimme == G_SCALAR) {
3571         MARK = newsp + 1;
3572         if (MARK <= SP) {
3573             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3574                 *MARK = TOPs;
3575             else
3576                 *MARK = sv_mortalcopy(TOPs);
3577         }
3578         else {
3579             MEXTEND(mark,0);
3580             *MARK = &PL_sv_undef;
3581         }
3582         SP = MARK;
3583     }
3584     else {
3585         /* in case LEAVE wipes old return values */
3586         for (mark = newsp + 1; mark <= SP; mark++) {
3587             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3588                 *mark = sv_mortalcopy(*mark);
3589                 TAINT_NOT;      /* Each item is independent */
3590             }
3591         }
3592     }
3593     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3594
3595     LEAVE;
3596     sv_setpvn(ERRSV,"",0);
3597     RETURN;
3598 }
3599
3600 STATIC OP *
3601 S_doparseform(pTHX_ SV *sv)
3602 {
3603     STRLEN len;
3604     register char *s = SvPV_force(sv, len);
3605     register char *send = s + len;
3606     register char *base = Nullch;
3607     register I32 skipspaces = 0;
3608     bool noblank   = FALSE;
3609     bool repeat    = FALSE;
3610     bool postspace = FALSE;
3611     U32 *fops;
3612     register U32 *fpc;
3613     U32 *linepc = 0;
3614     register I32 arg;
3615     bool ischop;
3616     bool unchopnum = FALSE;
3617     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3618
3619     if (len == 0)
3620         Perl_croak(aTHX_ "Null picture in formline");
3621
3622     /* estimate the buffer size needed */
3623     for (base = s; s <= send; s++) {
3624         if (*s == '\n' || *s == '@' || *s == '^')
3625             maxops += 10;
3626     }
3627     s = base;
3628     base = Nullch;
3629
3630     Newx(fops, maxops, U32);
3631     fpc = fops;
3632
3633     if (s < send) {
3634         linepc = fpc;
3635         *fpc++ = FF_LINEMARK;
3636         noblank = repeat = FALSE;
3637         base = s;
3638     }
3639
3640     while (s <= send) {
3641         switch (*s++) {
3642         default:
3643             skipspaces = 0;
3644             continue;
3645
3646         case '~':
3647             if (*s == '~') {
3648                 repeat = TRUE;
3649                 *s = ' ';
3650             }
3651             noblank = TRUE;
3652             s[-1] = ' ';
3653             /* FALL THROUGH */
3654         case ' ': case '\t':
3655             skipspaces++;
3656             continue;
3657         case 0:
3658             if (s < send) {
3659                 skipspaces = 0;
3660                 continue;
3661             } /* else FALL THROUGH */
3662         case '\n':
3663             arg = s - base;
3664             skipspaces++;
3665             arg -= skipspaces;
3666             if (arg) {
3667                 if (postspace)
3668                     *fpc++ = FF_SPACE;
3669                 *fpc++ = FF_LITERAL;
3670                 *fpc++ = (U16)arg;
3671             }
3672             postspace = FALSE;
3673             if (s <= send)
3674                 skipspaces--;
3675             if (skipspaces) {
3676                 *fpc++ = FF_SKIP;
3677                 *fpc++ = (U16)skipspaces;
3678             }
3679             skipspaces = 0;
3680             if (s <= send)
3681                 *fpc++ = FF_NEWLINE;
3682             if (noblank) {
3683                 *fpc++ = FF_BLANK;
3684                 if (repeat)
3685                     arg = fpc - linepc + 1;
3686                 else
3687                     arg = 0;
3688                 *fpc++ = (U16)arg;
3689             }
3690             if (s < send) {
3691                 linepc = fpc;
3692                 *fpc++ = FF_LINEMARK;
3693                 noblank = repeat = FALSE;
3694                 base = s;
3695             }
3696             else
3697                 s++;
3698             continue;
3699
3700         case '@':
3701         case '^':
3702             ischop = s[-1] == '^';
3703
3704             if (postspace) {
3705                 *fpc++ = FF_SPACE;
3706                 postspace = FALSE;
3707             }
3708             arg = (s - base) - 1;
3709             if (arg) {
3710                 *fpc++ = FF_LITERAL;
3711                 *fpc++ = (U16)arg;
3712             }
3713
3714             base = s - 1;
3715             *fpc++ = FF_FETCH;
3716             if (*s == '*') {
3717                 s++;
3718                 *fpc++ = 2;  /* skip the @* or ^* */
3719                 if (ischop) {
3720                     *fpc++ = FF_LINESNGL;
3721                     *fpc++ = FF_CHOP;
3722                 } else
3723                     *fpc++ = FF_LINEGLOB;
3724             }
3725             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3726                 arg = ischop ? 512 : 0;
3727                 base = s - 1;
3728                 while (*s == '#')
3729                     s++;
3730                 if (*s == '.') {
3731                     const char * const f = ++s;
3732                     while (*s == '#')
3733                         s++;
3734                     arg |= 256 + (s - f);
3735                 }
3736                 *fpc++ = s - base;              /* fieldsize for FETCH */
3737                 *fpc++ = FF_DECIMAL;
3738                 *fpc++ = (U16)arg;
3739                 unchopnum |= ! ischop;
3740             }
3741             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3742                 arg = ischop ? 512 : 0;
3743                 base = s - 1;
3744                 s++;                                /* skip the '0' first */
3745                 while (*s == '#')
3746                     s++;
3747                 if (*s == '.') {
3748                     const char * const f = ++s;
3749                     while (*s == '#')
3750                         s++;
3751                     arg |= 256 + (s - f);
3752                 }
3753                 *fpc++ = s - base;                /* fieldsize for FETCH */
3754                 *fpc++ = FF_0DECIMAL;
3755                 *fpc++ = (U16)arg;
3756                 unchopnum |= ! ischop;
3757             }
3758             else {
3759                 I32 prespace = 0;
3760                 bool ismore = FALSE;
3761
3762                 if (*s == '>') {
3763                     while (*++s == '>') ;
3764                     prespace = FF_SPACE;
3765                 }
3766                 else if (*s == '|') {
3767                     while (*++s == '|') ;
3768                     prespace = FF_HALFSPACE;
3769                     postspace = TRUE;
3770                 }
3771                 else {
3772                     if (*s == '<')
3773                         while (*++s == '<') ;
3774                     postspace = TRUE;
3775                 }
3776                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3777                     s += 3;
3778                     ismore = TRUE;
3779                 }
3780                 *fpc++ = s - base;              /* fieldsize for FETCH */
3781
3782                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3783
3784                 if (prespace)
3785                     *fpc++ = (U16)prespace;
3786                 *fpc++ = FF_ITEM;
3787                 if (ismore)
3788                     *fpc++ = FF_MORE;
3789                 if (ischop)
3790                     *fpc++ = FF_CHOP;
3791             }
3792             base = s;
3793             skipspaces = 0;
3794             continue;
3795         }
3796     }
3797     *fpc++ = FF_END;
3798
3799     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3800     arg = fpc - fops;
3801     { /* need to jump to the next word */
3802         int z;
3803         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3804         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3805         s = SvPVX(sv) + SvCUR(sv) + z;
3806     }
3807     Copy(fops, s, arg, U32);
3808     Safefree(fops);
3809     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3810     SvCOMPILED_on(sv);
3811
3812     if (unchopnum && repeat)
3813         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3814     return 0;
3815 }
3816
3817
3818 STATIC bool
3819 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3820 {
3821     /* Can value be printed in fldsize chars, using %*.*f ? */
3822     NV pwr = 1;
3823     NV eps = 0.5;
3824     bool res = FALSE;
3825     int intsize = fldsize - (value < 0 ? 1 : 0);
3826
3827     if (frcsize & 256)
3828         intsize--;
3829     frcsize &= 255;
3830     intsize -= frcsize;
3831
3832     while (intsize--) pwr *= 10.0;
3833     while (frcsize--) eps /= 10.0;
3834
3835     if( value >= 0 ){
3836         if (value + eps >= pwr)
3837             res = TRUE;
3838     } else {
3839         if (value - eps <= -pwr)
3840             res = TRUE;
3841     }
3842     return res;
3843 }
3844
3845 static I32
3846 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3847 {
3848     dVAR;
3849     SV *datasv = FILTER_DATA(idx);
3850     const int filter_has_file = IoLINES(datasv);
3851     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3852     SV *filter_state = (SV *)IoTOP_GV(datasv);
3853     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3854     int len = 0;
3855
3856     /* I was having segfault trouble under Linux 2.2.5 after a
3857        parse error occured.  (Had to hack around it with a test
3858        for PL_error_count == 0.)  Solaris doesn't segfault --
3859        not sure where the trouble is yet.  XXX */
3860
3861     if (filter_has_file) {
3862         len = FILTER_READ(idx+1, buf_sv, maxlen);
3863     }
3864
3865     if (filter_sub && len >= 0) {
3866         dSP;
3867         int count;
3868
3869         ENTER;
3870         SAVE_DEFSV;
3871         SAVETMPS;
3872         EXTEND(SP, 2);
3873
3874         DEFSV = buf_sv;
3875         PUSHMARK(SP);
3876         PUSHs(sv_2mortal(newSViv(maxlen)));
3877         if (filter_state) {
3878             PUSHs(filter_state);
3879         }
3880         PUTBACK;
3881         count = call_sv(filter_sub, G_SCALAR);
3882         SPAGAIN;
3883
3884         if (count > 0) {
3885             SV *out = POPs;
3886             if (SvOK(out)) {
3887                 len = SvIV(out);
3888             }
3889         }
3890
3891         PUTBACK;
3892         FREETMPS;
3893         LEAVE;
3894     }
3895
3896     if (len <= 0) {
3897         IoLINES(datasv) = 0;
3898         if (filter_child_proc) {
3899             SvREFCNT_dec(filter_child_proc);
3900             IoFMT_GV(datasv) = Nullgv;
3901         }
3902         if (filter_state) {
3903             SvREFCNT_dec(filter_state);
3904             IoTOP_GV(datasv) = Nullgv;
3905         }
3906         if (filter_sub) {
3907             SvREFCNT_dec(filter_sub);
3908             IoBOTTOM_GV(datasv) = Nullgv;
3909         }
3910         filter_del(run_user_filter);
3911     }
3912
3913     return len;
3914 }
3915
3916 /* perhaps someone can come up with a better name for
3917    this?  it is not really "absolute", per se ... */
3918 static bool
3919 S_path_is_absolute(pTHX_ const char *name)
3920 {
3921     if (PERL_FILE_IS_ABSOLUTE(name)
3922 #ifdef MACOS_TRADITIONAL
3923         || (*name == ':'))
3924 #else
3925         || (*name == '.' && (name[1] == '/' ||
3926                              (name[1] == '.' && name[2] == '/'))))
3927 #endif
3928     {
3929         return TRUE;
3930     }
3931     else
3932         return FALSE;
3933 }
3934
3935 /*
3936  * Local variables:
3937  * c-indentation-style: bsd
3938  * c-basic-offset: 4
3939  * indent-tabs-mode: t
3940  * End:
3941  *
3942  * ex: set ts=8 sts=4 sw=4 noet:
3943  */