This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Separate bad range end detection.
[perl5.git] / pp_ctl.c
1 /*    pp_ctl.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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  *     [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
20  */
21
22 /* This file contains control-oriented pp ("push/pop") functions that
23  * execute the opcodes that make up a perl program. A typical pp function
24  * expects to find its arguments on the stack, and usually pushes its
25  * results onto the stack, hence the 'pp' terminology. Each OP structure
26  * contains a pointer to the relevant pp_foo() function.
27  *
28  * Control-oriented means things like pp_enteriter() and pp_next(), which
29  * alter the flow of control of the program.
30  */
31
32
33 #include "EXTERN.h"
34 #define PERL_IN_PP_CTL_C
35 #include "perl.h"
36
37 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
38
39 #define dopoptosub(plop)        dopoptosub_at(cxstack, (plop))
40
41 PP(pp_wantarray)
42 {
43     dSP;
44     I32 cxix;
45     const PERL_CONTEXT *cx;
46     EXTEND(SP, 1);
47
48     if (PL_op->op_private & OPpOFFBYONE) {
49         if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
50     }
51     else {
52       cxix = dopoptosub(cxstack_ix);
53       if (cxix < 0)
54         RETPUSHUNDEF;
55       cx = &cxstack[cxix];
56     }
57
58     switch (cx->blk_gimme) {
59     case G_ARRAY:
60         RETPUSHYES;
61     case G_SCALAR:
62         RETPUSHNO;
63     default:
64         RETPUSHUNDEF;
65     }
66 }
67
68 PP(pp_regcreset)
69 {
70     TAINT_NOT;
71     return NORMAL;
72 }
73
74 PP(pp_regcomp)
75 {
76     dSP;
77     PMOP *pm = (PMOP*)cLOGOP->op_other;
78     SV **args;
79     int nargs;
80     REGEXP *re = NULL;
81     REGEXP *new_re;
82     const regexp_engine *eng;
83     bool is_bare_re= FALSE;
84
85     if (PL_op->op_flags & OPf_STACKED) {
86         dMARK;
87         nargs = SP - MARK;
88         args  = ++MARK;
89     }
90     else {
91         nargs = 1;
92         args  = SP;
93     }
94
95     /* prevent recompiling under /o and ithreads. */
96 #if defined(USE_ITHREADS)
97     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
98         SP = args-1;
99         RETURN;
100     }
101 #endif
102
103     re = PM_GETRE(pm);
104     assert (re != (REGEXP*) &PL_sv_undef);
105     eng = re ? RX_ENGINE(re) : current_re_engine();
106
107     /*
108      In the below logic: these are basically the same - check if this regcomp is part of a split.
109
110     (PL_op->op_pmflags & PMf_split )
111     (PL_op->op_next->op_type == OP_PUSHRE)
112
113     We could add a new mask for this and copy the PMf_split, if we did
114     some bit definition fiddling first.
115
116     For now we leave this
117     */
118
119     new_re = (eng->op_comp
120                     ? eng->op_comp
121                     : &Perl_re_op_compile
122             )(aTHX_ args, nargs, pm->op_code_list, eng, re,
123                 &is_bare_re,
124                 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
125                 pm->op_pmflags |
126                     (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
127
128     if (pm->op_pmflags & PMf_HAS_CV)
129         ReANY(new_re)->qr_anoncv
130                         = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
131
132     if (is_bare_re) {
133         REGEXP *tmp;
134         /* The match's LHS's get-magic might need to access this op's regexp
135            (e.g. $' =~ /$re/ while foo; see bug 70764).  So we must call
136            get-magic now before we replace the regexp. Hopefully this hack can
137            be replaced with the approach described at
138            http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
139            some day. */
140         if (pm->op_type == OP_MATCH) {
141             SV *lhs;
142             const bool was_tainted = TAINT_get;
143             if (pm->op_flags & OPf_STACKED)
144                 lhs = args[-1];
145             else if (pm->op_targ)
146                 lhs = PAD_SV(pm->op_targ);
147             else lhs = DEFSV;
148             SvGETMAGIC(lhs);
149             /* Restore the previous value of PL_tainted (which may have been
150                modified by get-magic), to avoid incorrectly setting the
151                RXf_TAINTED flag with RX_TAINT_on further down. */
152             TAINT_set(was_tainted);
153 #ifdef NO_TAINT_SUPPORT
154             PERL_UNUSED_VAR(was_tainted);
155 #endif
156         }
157         tmp = reg_temp_copy(NULL, new_re);
158         ReREFCNT_dec(new_re);
159         new_re = tmp;
160     }
161
162     if (re != new_re) {
163         ReREFCNT_dec(re);
164         PM_SETRE(pm, new_re);
165     }
166
167
168     if (TAINTING_get && TAINT_get) {
169         SvTAINTED_on((SV*)new_re);
170         RX_TAINT_on(new_re);
171     }
172
173 #if !defined(USE_ITHREADS)
174     /* can't change the optree at runtime either */
175     /* PMf_KEEP is handled differently under threads to avoid these problems */
176     if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
177         pm = PL_curpm;
178     if (pm->op_pmflags & PMf_KEEP) {
179         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
180         cLOGOP->op_first->op_next = PL_op->op_next;
181     }
182 #endif
183
184     SP = args-1;
185     RETURN;
186 }
187
188
189 PP(pp_substcont)
190 {
191     dSP;
192     PERL_CONTEXT *cx = &cxstack[cxstack_ix];
193     PMOP * const pm = (PMOP*) cLOGOP->op_other;
194     SV * const dstr = cx->sb_dstr;
195     char *s = cx->sb_s;
196     char *m = cx->sb_m;
197     char *orig = cx->sb_orig;
198     REGEXP * const rx = cx->sb_rx;
199     SV *nsv = NULL;
200     REGEXP *old = PM_GETRE(pm);
201
202     PERL_ASYNC_CHECK();
203
204     if(old != rx) {
205         if(old)
206             ReREFCNT_dec(old);
207         PM_SETRE(pm,ReREFCNT_inc(rx));
208     }
209
210     rxres_restore(&cx->sb_rxres, rx);
211
212     if (cx->sb_iters++) {
213         const SSize_t saviters = cx->sb_iters;
214         if (cx->sb_iters > cx->sb_maxiters)
215             DIE(aTHX_ "Substitution loop");
216
217         SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
218
219         /* See "how taint works" above pp_subst() */
220         if (SvTAINTED(TOPs))
221             cx->sb_rxtainted |= SUBST_TAINT_REPL;
222         sv_catsv_nomg(dstr, POPs);
223         if (CxONCE(cx) || s < orig ||
224                 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
225                              (s == m), cx->sb_targ, NULL,
226                     (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
227         {
228             SV *targ = cx->sb_targ;
229
230             assert(cx->sb_strend >= s);
231             if(cx->sb_strend > s) {
232                  if (DO_UTF8(dstr) && !SvUTF8(targ))
233                       sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
234                  else
235                       sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
236             }
237             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
238                 cx->sb_rxtainted |= SUBST_TAINT_PAT;
239
240             if (pm->op_pmflags & PMf_NONDESTRUCT) {
241                 PUSHs(dstr);
242                 /* From here on down we're using the copy, and leaving the
243                    original untouched.  */
244                 targ = dstr;
245             }
246             else {
247                 SV_CHECK_THINKFIRST_COW_DROP(targ);
248                 if (isGV(targ)) Perl_croak_no_modify();
249                 SvPV_free(targ);
250                 SvPV_set(targ, SvPVX(dstr));
251                 SvCUR_set(targ, SvCUR(dstr));
252                 SvLEN_set(targ, SvLEN(dstr));
253                 if (DO_UTF8(dstr))
254                     SvUTF8_on(targ);
255                 SvPV_set(dstr, NULL);
256
257                 PL_tainted = 0;
258                 mPUSHi(saviters - 1);
259
260                 (void)SvPOK_only_UTF8(targ);
261             }
262
263             /* update the taint state of various various variables in
264              * preparation for final exit.
265              * See "how taint works" above pp_subst() */
266             if (TAINTING_get) {
267                 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
268                     ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
269                                     == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
270                 )
271                     (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
272
273                 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
274                     && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
275                 )
276                     SvTAINTED_on(TOPs);  /* taint return value */
277                 /* needed for mg_set below */
278                 TAINT_set(
279                     cBOOL(cx->sb_rxtainted &
280                           (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
281                 );
282                 SvTAINT(TARG);
283             }
284             /* PL_tainted must be correctly set for this mg_set */
285             SvSETMAGIC(TARG);
286             TAINT_NOT;
287             LEAVE_SCOPE(cx->sb_oldsave);
288             POPSUBST(cx);
289             PERL_ASYNC_CHECK();
290             RETURNOP(pm->op_next);
291             NOT_REACHED; /* NOTREACHED */
292         }
293         cx->sb_iters = saviters;
294     }
295     if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
296         m = s;
297         s = orig;
298         assert(!RX_SUBOFFSET(rx));
299         cx->sb_orig = orig = RX_SUBBEG(rx);
300         s = orig + (m - s);
301         cx->sb_strend = s + (cx->sb_strend - m);
302     }
303     cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
304     if (m > s) {
305         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
306             sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
307         else
308             sv_catpvn_nomg(dstr, s, m-s);
309     }
310     cx->sb_s = RX_OFFS(rx)[0].end + orig;
311     { /* Update the pos() information. */
312         SV * const sv
313             = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
314         MAGIC *mg;
315         if (!(mg = mg_find_mglob(sv))) {
316             mg = sv_magicext_mglob(sv);
317         }
318         assert(SvPOK(sv));
319         MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
320     }
321     if (old != rx)
322         (void)ReREFCNT_inc(rx);
323     /* update the taint state of various various variables in preparation
324      * for calling the code block.
325      * See "how taint works" above pp_subst() */
326     if (TAINTING_get) {
327         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
328             cx->sb_rxtainted |= SUBST_TAINT_PAT;
329
330         if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
331             ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
332                             == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
333         )
334             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
335
336         if (cx->sb_iters > 1 && (cx->sb_rxtainted & 
337                         (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
338             SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
339                          ? cx->sb_dstr : cx->sb_targ);
340         TAINT_NOT;
341     }
342     rxres_save(&cx->sb_rxres, rx);
343     PL_curpm = pm;
344     RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
345 }
346
347 void
348 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
349 {
350     UV *p = (UV*)*rsp;
351     U32 i;
352
353     PERL_ARGS_ASSERT_RXRES_SAVE;
354     PERL_UNUSED_CONTEXT;
355
356     if (!p || p[1] < RX_NPARENS(rx)) {
357 #ifdef PERL_ANY_COW
358         i = 7 + (RX_NPARENS(rx)+1) * 2;
359 #else
360         i = 6 + (RX_NPARENS(rx)+1) * 2;
361 #endif
362         if (!p)
363             Newx(p, i, UV);
364         else
365             Renew(p, i, UV);
366         *rsp = (void*)p;
367     }
368
369     /* what (if anything) to free on croak */
370     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
371     RX_MATCH_COPIED_off(rx);
372     *p++ = RX_NPARENS(rx);
373
374 #ifdef PERL_ANY_COW
375     *p++ = PTR2UV(RX_SAVED_COPY(rx));
376     RX_SAVED_COPY(rx) = NULL;
377 #endif
378
379     *p++ = PTR2UV(RX_SUBBEG(rx));
380     *p++ = (UV)RX_SUBLEN(rx);
381     *p++ = (UV)RX_SUBOFFSET(rx);
382     *p++ = (UV)RX_SUBCOFFSET(rx);
383     for (i = 0; i <= RX_NPARENS(rx); ++i) {
384         *p++ = (UV)RX_OFFS(rx)[i].start;
385         *p++ = (UV)RX_OFFS(rx)[i].end;
386     }
387 }
388
389 static void
390 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
391 {
392     UV *p = (UV*)*rsp;
393     U32 i;
394
395     PERL_ARGS_ASSERT_RXRES_RESTORE;
396     PERL_UNUSED_CONTEXT;
397
398     RX_MATCH_COPY_FREE(rx);
399     RX_MATCH_COPIED_set(rx, *p);
400     *p++ = 0;
401     RX_NPARENS(rx) = *p++;
402
403 #ifdef PERL_ANY_COW
404     if (RX_SAVED_COPY(rx))
405         SvREFCNT_dec (RX_SAVED_COPY(rx));
406     RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
407     *p++ = 0;
408 #endif
409
410     RX_SUBBEG(rx) = INT2PTR(char*,*p++);
411     RX_SUBLEN(rx) = (I32)(*p++);
412     RX_SUBOFFSET(rx) = (I32)*p++;
413     RX_SUBCOFFSET(rx) = (I32)*p++;
414     for (i = 0; i <= RX_NPARENS(rx); ++i) {
415         RX_OFFS(rx)[i].start = (I32)(*p++);
416         RX_OFFS(rx)[i].end = (I32)(*p++);
417     }
418 }
419
420 static void
421 S_rxres_free(pTHX_ void **rsp)
422 {
423     UV * const p = (UV*)*rsp;
424
425     PERL_ARGS_ASSERT_RXRES_FREE;
426     PERL_UNUSED_CONTEXT;
427
428     if (p) {
429         void *tmp = INT2PTR(char*,*p);
430 #ifdef PERL_POISON
431 #ifdef PERL_ANY_COW
432         U32 i = 9 + p[1] * 2;
433 #else
434         U32 i = 8 + p[1] * 2;
435 #endif
436 #endif
437
438 #ifdef PERL_ANY_COW
439         SvREFCNT_dec (INT2PTR(SV*,p[2]));
440 #endif
441 #ifdef PERL_POISON
442         PoisonFree(p, i, sizeof(UV));
443 #endif
444
445         Safefree(tmp);
446         Safefree(p);
447         *rsp = NULL;
448     }
449 }
450
451 #define FORM_NUM_BLANK (1<<30)
452 #define FORM_NUM_POINT (1<<29)
453
454 PP(pp_formline)
455 {
456     dSP; dMARK; dORIGMARK;
457     SV * const tmpForm = *++MARK;
458     SV *formsv;             /* contains text of original format */
459     U32 *fpc;       /* format ops program counter */
460     char *t;        /* current append position in target string */
461     const char *f;          /* current position in format string */
462     I32 arg;
463     SV *sv = NULL; /* current item */
464     const char *item = NULL;/* string value of current item */
465     I32 itemsize  = 0;      /* length (chars) of item, possibly truncated */
466     I32 itembytes = 0;      /* as itemsize, but length in bytes */
467     I32 fieldsize = 0;      /* width of current field */
468     I32 lines = 0;          /* number of lines that have been output */
469     bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
470     const char *chophere = NULL; /* where to chop current item */
471     STRLEN linemark = 0;    /* pos of start of line in output */
472     NV value;
473     bool gotsome = FALSE;   /* seen at least one non-blank item on this line */
474     STRLEN len;             /* length of current sv */
475     STRLEN linemax;         /* estimate of output size in bytes */
476     bool item_is_utf8 = FALSE;
477     bool targ_is_utf8 = FALSE;
478     const char *fmt;
479     MAGIC *mg = NULL;
480     U8 *source;             /* source of bytes to append */
481     STRLEN to_copy;         /* how may bytes to append */
482     char trans;             /* what chars to translate */
483
484     mg = doparseform(tmpForm);
485
486     fpc = (U32*)mg->mg_ptr;
487     /* the actual string the format was compiled from.
488      * with overload etc, this may not match tmpForm */
489     formsv = mg->mg_obj;
490
491
492     SvPV_force(PL_formtarget, len);
493     if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
494         SvTAINTED_on(PL_formtarget);
495     if (DO_UTF8(PL_formtarget))
496         targ_is_utf8 = TRUE;
497     linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
498     t = SvGROW(PL_formtarget, len + linemax + 1);
499     /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
500     t += len;
501     f = SvPV_const(formsv, len);
502
503     for (;;) {
504         DEBUG_f( {
505             const char *name = "???";
506             arg = -1;
507             switch (*fpc) {
508             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
509             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
510             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
511             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
512             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
513
514             case FF_CHECKNL:    name = "CHECKNL";       break;
515             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
516             case FF_SPACE:      name = "SPACE";         break;
517             case FF_HALFSPACE:  name = "HALFSPACE";     break;
518             case FF_ITEM:       name = "ITEM";          break;
519             case FF_CHOP:       name = "CHOP";          break;
520             case FF_LINEGLOB:   name = "LINEGLOB";      break;
521             case FF_NEWLINE:    name = "NEWLINE";       break;
522             case FF_MORE:       name = "MORE";          break;
523             case FF_LINEMARK:   name = "LINEMARK";      break;
524             case FF_END:        name = "END";           break;
525             case FF_0DECIMAL:   name = "0DECIMAL";      break;
526             case FF_LINESNGL:   name = "LINESNGL";      break;
527             }
528             if (arg >= 0)
529                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
530             else
531                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
532         } );
533         switch (*fpc++) {
534         case FF_LINEMARK: /* start (or end) of a line */
535             linemark = t - SvPVX(PL_formtarget);
536             lines++;
537             gotsome = FALSE;
538             break;
539
540         case FF_LITERAL: /* append <arg> literal chars */
541             to_copy = *fpc++;
542             source = (U8 *)f;
543             f += to_copy;
544             trans = '~';
545             item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
546             goto append;
547
548         case FF_SKIP: /* skip <arg> chars in format */
549             f += *fpc++;
550             break;
551
552         case FF_FETCH: /* get next item and set field size to <arg> */
553             arg = *fpc++;
554             f += arg;
555             fieldsize = arg;
556
557             if (MARK < SP)
558                 sv = *++MARK;
559             else {
560                 sv = &PL_sv_no;
561                 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
562             }
563             if (SvTAINTED(sv))
564                 SvTAINTED_on(PL_formtarget);
565             break;
566
567         case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
568             {
569                 const char *s = item = SvPV_const(sv, len);
570                 const char *send = s + len;
571
572                 itemsize = 0;
573                 item_is_utf8 = DO_UTF8(sv);
574                 while (s < send) {
575                     if (!isCNTRL(*s))
576                         gotsome = TRUE;
577                     else if (*s == '\n')
578                         break;
579
580                     if (item_is_utf8)
581                         s += UTF8SKIP(s);
582                     else
583                         s++;
584                     itemsize++;
585                     if (itemsize == fieldsize)
586                         break;
587                 }
588                 itembytes = s - item;
589                 break;
590             }
591
592         case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
593             {
594                 const char *s = item = SvPV_const(sv, len);
595                 const char *send = s + len;
596                 I32 size = 0;
597
598                 chophere = NULL;
599                 item_is_utf8 = DO_UTF8(sv);
600                 while (s < send) {
601                     /* look for a legal split position */
602                     if (isSPACE(*s)) {
603                         if (*s == '\r') {
604                             chophere = s;
605                             itemsize = size;
606                             break;
607                         }
608                         if (chopspace) {
609                             /* provisional split point */
610                             chophere = s;
611                             itemsize = size;
612                         }
613                         /* we delay testing fieldsize until after we've
614                          * processed the possible split char directly
615                          * following the last field char; so if fieldsize=3
616                          * and item="a b cdef", we consume "a b", not "a".
617                          * Ditto further down.
618                          */
619                         if (size == fieldsize)
620                             break;
621                     }
622                     else {
623                         if (strchr(PL_chopset, *s)) {
624                             /* provisional split point */
625                             /* for a non-space split char, we include
626                              * the split char; hence the '+1' */
627                             chophere = s + 1;
628                             itemsize = size;
629                         }
630                         if (size == fieldsize)
631                             break;
632                         if (!isCNTRL(*s))
633                             gotsome = TRUE;
634                     }
635
636                     if (item_is_utf8)
637                         s += UTF8SKIP(s);
638                     else
639                         s++;
640                     size++;
641                 }
642                 if (!chophere || s == send) {
643                     chophere = s;
644                     itemsize = size;
645                 }
646                 itembytes = chophere - item;
647
648                 break;
649             }
650
651         case FF_SPACE: /* append padding space (diff of field, item size) */
652             arg = fieldsize - itemsize;
653             if (arg) {
654                 fieldsize -= arg;
655                 while (arg-- > 0)
656                     *t++ = ' ';
657             }
658             break;
659
660         case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
661             arg = fieldsize - itemsize;
662             if (arg) {
663                 arg /= 2;
664                 fieldsize -= arg;
665                 while (arg-- > 0)
666                     *t++ = ' ';
667             }
668             break;
669
670         case FF_ITEM: /* append a text item, while blanking ctrl chars */
671             to_copy = itembytes;
672             source = (U8 *)item;
673             trans = 1;
674             goto append;
675
676         case FF_CHOP: /* (for ^*) chop the current item */
677             if (sv != &PL_sv_no) {
678                 const char *s = chophere;
679                 if (chopspace) {
680                     while (isSPACE(*s))
681                         s++;
682                 }
683                 if (SvPOKp(sv))
684                     sv_chop(sv,s);
685                 else
686                     /* tied, overloaded or similar strangeness.
687                      * Do it the hard way */
688                     sv_setpvn(sv, s, len - (s-item));
689                 SvSETMAGIC(sv);
690                 break;
691             }
692
693         case FF_LINESNGL: /* process ^*  */
694             chopspace = 0;
695             /* FALLTHROUGH */
696
697         case FF_LINEGLOB: /* process @*  */
698             {
699                 const bool oneline = fpc[-1] == FF_LINESNGL;
700                 const char *s = item = SvPV_const(sv, len);
701                 const char *const send = s + len;
702
703                 item_is_utf8 = DO_UTF8(sv);
704                 chophere = s + len;
705                 if (!len)
706                     break;
707                 trans = 0;
708                 gotsome = TRUE;
709                 source = (U8 *) s;
710                 to_copy = len;
711                 while (s < send) {
712                     if (*s++ == '\n') {
713                         if (oneline) {
714                             to_copy = s - item - 1;
715                             chophere = s;
716                             break;
717                         } else {
718                             if (s == send) {
719                                 to_copy--;
720                             } else
721                                 lines++;
722                         }
723                     }
724                 }
725             }
726
727         append:
728             /* append to_copy bytes from source to PL_formstring.
729              * item_is_utf8 implies source is utf8.
730              * if trans, translate certain characters during the copy */
731             {
732                 U8 *tmp = NULL;
733                 STRLEN grow = 0;
734
735                 SvCUR_set(PL_formtarget,
736                           t - SvPVX_const(PL_formtarget));
737
738                 if (targ_is_utf8 && !item_is_utf8) {
739                     source = tmp = bytes_to_utf8(source, &to_copy);
740                 } else {
741                     if (item_is_utf8 && !targ_is_utf8) {
742                         U8 *s;
743                         /* Upgrade targ to UTF8, and then we reduce it to
744                            a problem we have a simple solution for.
745                            Don't need get magic.  */
746                         sv_utf8_upgrade_nomg(PL_formtarget);
747                         targ_is_utf8 = TRUE;
748                         /* re-calculate linemark */
749                         s = (U8*)SvPVX(PL_formtarget);
750                         /* the bytes we initially allocated to append the
751                          * whole line may have been gobbled up during the
752                          * upgrade, so allocate a whole new line's worth
753                          * for safety */
754                         grow = linemax;
755                         while (linemark--)
756                             s += UTF8SKIP(s);
757                         linemark = s - (U8*)SvPVX(PL_formtarget);
758                     }
759                     /* Easy. They agree.  */
760                     assert (item_is_utf8 == targ_is_utf8);
761                 }
762                 if (!trans)
763                     /* @* and ^* are the only things that can exceed
764                      * the linemax, so grow by the output size, plus
765                      * a whole new form's worth in case of any further
766                      * output */
767                     grow = linemax + to_copy;
768                 if (grow)
769                     SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
770                 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
771
772                 Copy(source, t, to_copy, char);
773                 if (trans) {
774                     /* blank out ~ or control chars, depending on trans.
775                      * works on bytes not chars, so relies on not
776                      * matching utf8 continuation bytes */
777                     U8 *s = (U8*)t;
778                     U8 *send = s + to_copy;
779                     while (s < send) {
780                         const int ch = *s;
781                         if (trans == '~' ? (ch == '~') : isCNTRL(ch))
782                             *s = ' ';
783                         s++;
784                     }
785                 }
786
787                 t += to_copy;
788                 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
789                 if (tmp)
790                     Safefree(tmp);
791                 break;
792             }
793
794         case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
795             arg = *fpc++;
796             fmt = (const char *)
797                 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
798             goto ff_dec;
799
800         case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
801             arg = *fpc++;
802             fmt = (const char *)
803                 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
804         ff_dec:
805             /* If the field is marked with ^ and the value is undefined,
806                blank it out. */
807             if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
808                 arg = fieldsize;
809                 while (arg--)
810                     *t++ = ' ';
811                 break;
812             }
813             gotsome = TRUE;
814             value = SvNV(sv);
815             /* overflow evidence */
816             if (num_overflow(value, fieldsize, arg)) {
817                 arg = fieldsize;
818                 while (arg--)
819                     *t++ = '#';
820                 break;
821             }
822             /* Formats aren't yet marked for locales, so assume "yes". */
823             {
824                 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
825                 int len;
826                 DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
827                 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
828 #ifdef USE_QUADMATH
829                 {
830                     const char* qfmt = quadmath_format_single(fmt);
831                     int len;
832                     if (!qfmt)
833                         Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
834                     len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
835                     if (len == -1)
836                         Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
837                     if (qfmt != fmt)
838                         Safefree(fmt);
839                 }
840 #else
841                 /* we generate fmt ourselves so it is safe */
842                 GCC_DIAG_IGNORE(-Wformat-nonliteral);
843                 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
844                 GCC_DIAG_RESTORE;
845 #endif
846                 PERL_MY_SNPRINTF_POST_GUARD(len, max);
847                 RESTORE_LC_NUMERIC();
848             }
849             t += fieldsize;
850             break;
851
852         case FF_NEWLINE: /* delete trailing spaces, then append \n */
853             f++;
854             while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
855             t++;
856             *t++ = '\n';
857             break;
858
859         case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
860             arg = *fpc++;
861             if (gotsome) {
862                 if (arg) {              /* repeat until fields exhausted? */
863                     fpc--;
864                     goto end;
865                 }
866             }
867             else {
868                 t = SvPVX(PL_formtarget) + linemark;
869                 lines--;
870             }
871             break;
872
873         case FF_MORE: /* replace long end of string with '...' */
874             {
875                 const char *s = chophere;
876                 const char *send = item + len;
877                 if (chopspace) {
878                     while (isSPACE(*s) && (s < send))
879                         s++;
880                 }
881                 if (s < send) {
882                     char *s1;
883                     arg = fieldsize - itemsize;
884                     if (arg) {
885                         fieldsize -= arg;
886                         while (arg-- > 0)
887                             *t++ = ' ';
888                     }
889                     s1 = t - 3;
890                     if (strnEQ(s1,"   ",3)) {
891                         while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
892                             s1--;
893                     }
894                     *s1++ = '.';
895                     *s1++ = '.';
896                     *s1++ = '.';
897                 }
898                 break;
899             }
900
901         case FF_END: /* tidy up, then return */
902         end:
903             assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
904             *t = '\0';
905             SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
906             if (targ_is_utf8)
907                 SvUTF8_on(PL_formtarget);
908             FmLINES(PL_formtarget) += lines;
909             SP = ORIGMARK;
910             if (fpc[-1] == FF_BLANK)
911                 RETURNOP(cLISTOP->op_first);
912             else
913                 RETPUSHYES;
914         }
915     }
916 }
917
918 PP(pp_grepstart)
919 {
920     dSP;
921     SV *src;
922
923     if (PL_stack_base + *PL_markstack_ptr == SP) {
924         (void)POPMARK;
925         if (GIMME_V == G_SCALAR)
926             mXPUSHi(0);
927         RETURNOP(PL_op->op_next->op_next);
928     }
929     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
930     Perl_pp_pushmark(aTHX);                             /* push dst */
931     Perl_pp_pushmark(aTHX);                             /* push src */
932     ENTER_with_name("grep");                                    /* enter outer scope */
933
934     SAVETMPS;
935     if (PL_op->op_private & OPpGREP_LEX)
936         SAVESPTR(PAD_SVl(PL_op->op_targ));
937     else
938         SAVE_DEFSV;
939     ENTER_with_name("grep_item");                                       /* enter inner scope */
940     SAVEVPTR(PL_curpm);
941
942     src = PL_stack_base[*PL_markstack_ptr];
943     if (SvPADTMP(src)) {
944         src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
945         PL_tmps_floor++;
946     }
947     SvTEMP_off(src);
948     if (PL_op->op_private & OPpGREP_LEX)
949         PAD_SVl(PL_op->op_targ) = src;
950     else
951         DEFSV_set(src);
952
953     PUTBACK;
954     if (PL_op->op_type == OP_MAPSTART)
955         Perl_pp_pushmark(aTHX);                 /* push top */
956     return ((LOGOP*)PL_op->op_next)->op_other;
957 }
958
959 PP(pp_mapwhile)
960 {
961     dSP;
962     const I32 gimme = GIMME_V;
963     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
964     I32 count;
965     I32 shift;
966     SV** src;
967     SV** dst;
968
969     /* first, move source pointer to the next item in the source list */
970     ++PL_markstack_ptr[-1];
971
972     /* if there are new items, push them into the destination list */
973     if (items && gimme != G_VOID) {
974         /* might need to make room back there first */
975         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
976             /* XXX this implementation is very pessimal because the stack
977              * is repeatedly extended for every set of items.  Is possible
978              * to do this without any stack extension or copying at all
979              * by maintaining a separate list over which the map iterates
980              * (like foreach does). --gsar */
981
982             /* everything in the stack after the destination list moves
983              * towards the end the stack by the amount of room needed */
984             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
985
986             /* items to shift up (accounting for the moved source pointer) */
987             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
988
989             /* This optimization is by Ben Tilly and it does
990              * things differently from what Sarathy (gsar)
991              * is describing.  The downside of this optimization is
992              * that leaves "holes" (uninitialized and hopefully unused areas)
993              * to the Perl stack, but on the other hand this
994              * shouldn't be a problem.  If Sarathy's idea gets
995              * implemented, this optimization should become
996              * irrelevant.  --jhi */
997             if (shift < count)
998                 shift = count; /* Avoid shifting too often --Ben Tilly */
999
1000             EXTEND(SP,shift);
1001             src = SP;
1002             dst = (SP += shift);
1003             PL_markstack_ptr[-1] += shift;
1004             *PL_markstack_ptr += shift;
1005             while (count--)
1006                 *dst-- = *src--;
1007         }
1008         /* copy the new items down to the destination list */
1009         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1010         if (gimme == G_ARRAY) {
1011             /* add returned items to the collection (making mortal copies
1012              * if necessary), then clear the current temps stack frame
1013              * *except* for those items. We do this splicing the items
1014              * into the start of the tmps frame (so some items may be on
1015              * the tmps stack twice), then moving PL_tmps_floor above
1016              * them, then freeing the frame. That way, the only tmps that
1017              * accumulate over iterations are the return values for map.
1018              * We have to do to this way so that everything gets correctly
1019              * freed if we die during the map.
1020              */
1021             I32 tmpsbase;
1022             I32 i = items;
1023             /* make space for the slice */
1024             EXTEND_MORTAL(items);
1025             tmpsbase = PL_tmps_floor + 1;
1026             Move(PL_tmps_stack + tmpsbase,
1027                  PL_tmps_stack + tmpsbase + items,
1028                  PL_tmps_ix - PL_tmps_floor,
1029                  SV*);
1030             PL_tmps_ix += items;
1031
1032             while (i-- > 0) {
1033                 SV *sv = POPs;
1034                 if (!SvTEMP(sv))
1035                     sv = sv_mortalcopy(sv);
1036                 *dst-- = sv;
1037                 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1038             }
1039             /* clear the stack frame except for the items */
1040             PL_tmps_floor += items;
1041             FREETMPS;
1042             /* FREETMPS may have cleared the TEMP flag on some of the items */
1043             i = items;
1044             while (i-- > 0)
1045                 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1046         }
1047         else {
1048             /* scalar context: we don't care about which values map returns
1049              * (we use undef here). And so we certainly don't want to do mortal
1050              * copies of meaningless values. */
1051             while (items-- > 0) {
1052                 (void)POPs;
1053                 *dst-- = &PL_sv_undef;
1054             }
1055             FREETMPS;
1056         }
1057     }
1058     else {
1059         FREETMPS;
1060     }
1061     LEAVE_with_name("grep_item");                                       /* exit inner scope */
1062
1063     /* All done yet? */
1064     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1065
1066         (void)POPMARK;                          /* pop top */
1067         LEAVE_with_name("grep");                                        /* exit outer scope */
1068         (void)POPMARK;                          /* pop src */
1069         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1070         (void)POPMARK;                          /* pop dst */
1071         SP = PL_stack_base + POPMARK;           /* pop original mark */
1072         if (gimme == G_SCALAR) {
1073             if (PL_op->op_private & OPpGREP_LEX) {
1074                 SV* sv = sv_newmortal();
1075                 sv_setiv(sv, items);
1076                 PUSHs(sv);
1077             }
1078             else {
1079                 dTARGET;
1080                 XPUSHi(items);
1081             }
1082         }
1083         else if (gimme == G_ARRAY)
1084             SP += items;
1085         RETURN;
1086     }
1087     else {
1088         SV *src;
1089
1090         ENTER_with_name("grep_item");                                   /* enter inner scope */
1091         SAVEVPTR(PL_curpm);
1092
1093         /* set $_ to the new source item */
1094         src = PL_stack_base[PL_markstack_ptr[-1]];
1095         if (SvPADTMP(src)) {
1096             src = sv_mortalcopy(src);
1097         }
1098         SvTEMP_off(src);
1099         if (PL_op->op_private & OPpGREP_LEX)
1100             PAD_SVl(PL_op->op_targ) = src;
1101         else
1102             DEFSV_set(src);
1103
1104         RETURNOP(cLOGOP->op_other);
1105     }
1106 }
1107
1108 /* Range stuff. */
1109
1110 PP(pp_range)
1111 {
1112     if (GIMME_V == G_ARRAY)
1113         return NORMAL;
1114     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1115         return cLOGOP->op_other;
1116     else
1117         return NORMAL;
1118 }
1119
1120 PP(pp_flip)
1121 {
1122     dSP;
1123
1124     if (GIMME_V == G_ARRAY) {
1125         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1126     }
1127     else {
1128         dTOPss;
1129         SV * const targ = PAD_SV(PL_op->op_targ);
1130         int flip = 0;
1131
1132         if (PL_op->op_private & OPpFLIP_LINENUM) {
1133             if (GvIO(PL_last_in_gv)) {
1134                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1135             }
1136             else {
1137                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1138                 if (gv && GvSV(gv))
1139                     flip = SvIV(sv) == SvIV(GvSV(gv));
1140             }
1141         } else {
1142             flip = SvTRUE(sv);
1143         }
1144         if (flip) {
1145             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1146             if (PL_op->op_flags & OPf_SPECIAL) {
1147                 sv_setiv(targ, 1);
1148                 SETs(targ);
1149                 RETURN;
1150             }
1151             else {
1152                 sv_setiv(targ, 0);
1153                 SP--;
1154                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1155             }
1156         }
1157         sv_setpvs(TARG, "");
1158         SETs(targ);
1159         RETURN;
1160     }
1161 }
1162
1163 /* This code tries to decide if "$left .. $right" should use the
1164    magical string increment, or if the range is numeric (we make
1165    an exception for .."0" [#18165]). AMS 20021031. */
1166
1167 #define RANGE_IS_NUMERIC(left,right) ( \
1168         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1169         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1170         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1171           looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1172          && (!SvOK(right) || looks_like_number(right))))
1173
1174 PP(pp_flop)
1175 {
1176     dSP;
1177
1178     if (GIMME_V == G_ARRAY) {
1179         dPOPPOPssrl;
1180
1181         SvGETMAGIC(left);
1182         SvGETMAGIC(right);
1183
1184         if (RANGE_IS_NUMERIC(left,right)) {
1185             IV i, j, n;
1186             if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1187                 (SvOK(right) && (SvIOK(right)
1188                                  ? SvIsUV(right) && SvUV(right) > IV_MAX
1189                                  : SvNV_nomg(right) > IV_MAX)))
1190                 DIE(aTHX_ "Range iterator outside integer range");
1191             i = SvIV_nomg(left);
1192             j = SvIV_nomg(right);
1193             if (j >= i) {
1194                 /* Dance carefully around signed max. */
1195                 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1196                 if (!overflow) {
1197                     n = j - i + 1;
1198                     /* The wraparound of signed integers is undefined
1199                      * behavior, but here we aim for count >=1, and
1200                      * negative count is just wrong. */
1201                     if (n < 1)
1202                         overflow = TRUE;
1203                 }
1204                 if (overflow)
1205                     Perl_croak(aTHX_ "Out of memory during list extend");
1206                 EXTEND_MORTAL(n);
1207                 EXTEND(SP, n);
1208             }
1209             else
1210                 n = 0;
1211             while (n--) {
1212                 SV * const sv = sv_2mortal(newSViv(i));
1213                 PUSHs(sv);
1214                 if (n) /* avoid incrementing above IV_MAX */
1215                     i++;
1216             }
1217         }
1218         else {
1219             STRLEN len, llen;
1220             const char * const lpv = SvPV_nomg_const(left, llen);
1221             const char * const tmps = SvPV_nomg_const(right, len);
1222
1223             SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1224             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1225                 XPUSHs(sv);
1226                 if (strEQ(SvPVX_const(sv),tmps))
1227                     break;
1228                 sv = sv_2mortal(newSVsv(sv));
1229                 sv_inc(sv);
1230             }
1231         }
1232     }
1233     else {
1234         dTOPss;
1235         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1236         int flop = 0;
1237         sv_inc(targ);
1238
1239         if (PL_op->op_private & OPpFLIP_LINENUM) {
1240             if (GvIO(PL_last_in_gv)) {
1241                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1242             }
1243             else {
1244                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1245                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1246             }
1247         }
1248         else {
1249             flop = SvTRUE(sv);
1250         }
1251
1252         if (flop) {
1253             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1254             sv_catpvs(targ, "E0");
1255         }
1256         SETs(targ);
1257     }
1258
1259     RETURN;
1260 }
1261
1262 /* Control. */
1263
1264 static const char * const context_name[] = {
1265     "pseudo-block",
1266     NULL, /* CXt_WHEN never actually needs "block" */
1267     NULL, /* CXt_BLOCK never actually needs "block" */
1268     NULL, /* CXt_GIVEN never actually needs "block" */
1269     NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1270     NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1271     NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1272     NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1273     "subroutine",
1274     "format",
1275     "eval",
1276     "substitution",
1277 };
1278
1279 STATIC I32
1280 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1281 {
1282     I32 i;
1283
1284     PERL_ARGS_ASSERT_DOPOPTOLABEL;
1285
1286     for (i = cxstack_ix; i >= 0; i--) {
1287         const PERL_CONTEXT * const cx = &cxstack[i];
1288         switch (CxTYPE(cx)) {
1289         case CXt_SUBST:
1290         case CXt_SUB:
1291         case CXt_FORMAT:
1292         case CXt_EVAL:
1293         case CXt_NULL:
1294             /* diag_listed_as: Exiting subroutine via %s */
1295             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1296                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1297             if (CxTYPE(cx) == CXt_NULL)
1298                 return -1;
1299             break;
1300         case CXt_LOOP_LAZYIV:
1301         case CXt_LOOP_LAZYSV:
1302         case CXt_LOOP_FOR:
1303         case CXt_LOOP_PLAIN:
1304           {
1305             STRLEN cx_label_len = 0;
1306             U32 cx_label_flags = 0;
1307             const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1308             if (!cx_label || !(
1309                     ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1310                         (flags & SVf_UTF8)
1311                             ? (bytes_cmp_utf8(
1312                                         (const U8*)cx_label, cx_label_len,
1313                                         (const U8*)label, len) == 0)
1314                             : (bytes_cmp_utf8(
1315                                         (const U8*)label, len,
1316                                         (const U8*)cx_label, cx_label_len) == 0)
1317                     : (len == cx_label_len && ((cx_label == label)
1318                                     || memEQ(cx_label, label, len))) )) {
1319                 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1320                         (long)i, cx_label));
1321                 continue;
1322             }
1323             DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1324             return i;
1325           }
1326         }
1327     }
1328     return i;
1329 }
1330
1331
1332
1333 I32
1334 Perl_dowantarray(pTHX)
1335 {
1336     const I32 gimme = block_gimme();
1337     return (gimme == G_VOID) ? G_SCALAR : gimme;
1338 }
1339
1340 I32
1341 Perl_block_gimme(pTHX)
1342 {
1343     const I32 cxix = dopoptosub(cxstack_ix);
1344     if (cxix < 0)
1345         return G_VOID;
1346
1347     switch (cxstack[cxix].blk_gimme) {
1348     case G_VOID:
1349         return G_VOID;
1350     case G_SCALAR:
1351         return G_SCALAR;
1352     case G_ARRAY:
1353         return G_ARRAY;
1354     default:
1355         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1356     }
1357     NOT_REACHED; /* NOTREACHED */
1358 }
1359
1360 I32
1361 Perl_is_lvalue_sub(pTHX)
1362 {
1363     const I32 cxix = dopoptosub(cxstack_ix);
1364     assert(cxix >= 0);  /* We should only be called from inside subs */
1365
1366     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1367         return CxLVAL(cxstack + cxix);
1368     else
1369         return 0;
1370 }
1371
1372 /* only used by PUSHSUB */
1373 I32
1374 Perl_was_lvalue_sub(pTHX)
1375 {
1376     const I32 cxix = dopoptosub(cxstack_ix-1);
1377     assert(cxix >= 0);  /* We should only be called from inside subs */
1378
1379     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1380         return CxLVAL(cxstack + cxix);
1381     else
1382         return 0;
1383 }
1384
1385 STATIC I32
1386 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1387 {
1388     I32 i;
1389
1390     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1391 #ifndef DEBUGGING
1392     PERL_UNUSED_CONTEXT;
1393 #endif
1394
1395     for (i = startingblock; i >= 0; i--) {
1396         const PERL_CONTEXT * const cx = &cxstk[i];
1397         switch (CxTYPE(cx)) {
1398         default:
1399             continue;
1400         case CXt_SUB:
1401             /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1402              * twice; the first for the normal foo() call, and the second
1403              * for a faked up re-entry into the sub to execute the
1404              * code block. Hide this faked entry from the world. */
1405             if (cx->cx_type & CXp_SUB_RE_FAKE)
1406                 continue;
1407             /* FALLTHROUGH */
1408         case CXt_EVAL:
1409         case CXt_FORMAT:
1410             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1411             return i;
1412         }
1413     }
1414     return i;
1415 }
1416
1417 STATIC I32
1418 S_dopoptoeval(pTHX_ I32 startingblock)
1419 {
1420     I32 i;
1421     for (i = startingblock; i >= 0; i--) {
1422         const PERL_CONTEXT *cx = &cxstack[i];
1423         switch (CxTYPE(cx)) {
1424         default:
1425             continue;
1426         case CXt_EVAL:
1427             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1428             return i;
1429         }
1430     }
1431     return i;
1432 }
1433
1434 STATIC I32
1435 S_dopoptoloop(pTHX_ I32 startingblock)
1436 {
1437     I32 i;
1438     for (i = startingblock; i >= 0; i--) {
1439         const PERL_CONTEXT * const cx = &cxstack[i];
1440         switch (CxTYPE(cx)) {
1441         case CXt_SUBST:
1442         case CXt_SUB:
1443         case CXt_FORMAT:
1444         case CXt_EVAL:
1445         case CXt_NULL:
1446             /* diag_listed_as: Exiting subroutine via %s */
1447             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1448                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1449             if ((CxTYPE(cx)) == CXt_NULL)
1450                 return -1;
1451             break;
1452         case CXt_LOOP_LAZYIV:
1453         case CXt_LOOP_LAZYSV:
1454         case CXt_LOOP_FOR:
1455         case CXt_LOOP_PLAIN:
1456             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1457             return i;
1458         }
1459     }
1460     return i;
1461 }
1462
1463 STATIC I32
1464 S_dopoptogiven(pTHX_ I32 startingblock)
1465 {
1466     I32 i;
1467     for (i = startingblock; i >= 0; i--) {
1468         const PERL_CONTEXT *cx = &cxstack[i];
1469         switch (CxTYPE(cx)) {
1470         default:
1471             continue;
1472         case CXt_GIVEN:
1473             DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1474             return i;
1475         case CXt_LOOP_PLAIN:
1476             assert(!CxFOREACHDEF(cx));
1477             break;
1478         case CXt_LOOP_LAZYIV:
1479         case CXt_LOOP_LAZYSV:
1480         case CXt_LOOP_FOR:
1481             if (CxFOREACHDEF(cx)) {
1482                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1483                 return i;
1484             }
1485         }
1486     }
1487     return i;
1488 }
1489
1490 STATIC I32
1491 S_dopoptowhen(pTHX_ I32 startingblock)
1492 {
1493     I32 i;
1494     for (i = startingblock; i >= 0; i--) {
1495         const PERL_CONTEXT *cx = &cxstack[i];
1496         switch (CxTYPE(cx)) {
1497         default:
1498             continue;
1499         case CXt_WHEN:
1500             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1501             return i;
1502         }
1503     }
1504     return i;
1505 }
1506
1507 void
1508 Perl_dounwind(pTHX_ I32 cxix)
1509 {
1510     I32 optype;
1511
1512     if (!PL_curstackinfo) /* can happen if die during thread cloning */
1513         return;
1514
1515     while (cxstack_ix > cxix) {
1516         SV *sv;
1517         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1518         DEBUG_CX("UNWIND");                                             \
1519         /* Note: we don't need to restore the base context info till the end. */
1520         switch (CxTYPE(cx)) {
1521         case CXt_SUBST:
1522             POPSUBST(cx);
1523             continue;  /* not break */
1524         case CXt_SUB:
1525             POPSUB(cx,sv);
1526             LEAVESUB(sv);
1527             break;
1528         case CXt_EVAL:
1529             POPEVAL(cx);
1530             break;
1531         case CXt_LOOP_LAZYIV:
1532         case CXt_LOOP_LAZYSV:
1533         case CXt_LOOP_FOR:
1534         case CXt_LOOP_PLAIN:
1535             POPLOOP(cx);
1536             break;
1537         case CXt_NULL:
1538             break;
1539         case CXt_FORMAT:
1540             POPFORMAT(cx);
1541             break;
1542         }
1543         cxstack_ix--;
1544     }
1545     PERL_UNUSED_VAR(optype);
1546 }
1547
1548 void
1549 Perl_qerror(pTHX_ SV *err)
1550 {
1551     PERL_ARGS_ASSERT_QERROR;
1552
1553     if (PL_in_eval) {
1554         if (PL_in_eval & EVAL_KEEPERR) {
1555                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1556                                                     SVfARG(err));
1557         }
1558         else
1559             sv_catsv(ERRSV, err);
1560     }
1561     else if (PL_errors)
1562         sv_catsv(PL_errors, err);
1563     else
1564         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1565     if (PL_parser)
1566         ++PL_parser->error_count;
1567 }
1568
1569 void
1570 Perl_die_unwind(pTHX_ SV *msv)
1571 {
1572     SV *exceptsv = sv_mortalcopy(msv);
1573     U8 in_eval = PL_in_eval;
1574     PERL_ARGS_ASSERT_DIE_UNWIND;
1575
1576     if (in_eval) {
1577         I32 cxix;
1578         I32 gimme;
1579
1580         /*
1581          * Historically, perl used to set ERRSV ($@) early in the die
1582          * process and rely on it not getting clobbered during unwinding.
1583          * That sucked, because it was liable to get clobbered, so the
1584          * setting of ERRSV used to emit the exception from eval{} has
1585          * been moved to much later, after unwinding (see just before
1586          * JMPENV_JUMP below).  However, some modules were relying on the
1587          * early setting, by examining $@ during unwinding to use it as
1588          * a flag indicating whether the current unwinding was caused by
1589          * an exception.  It was never a reliable flag for that purpose,
1590          * being totally open to false positives even without actual
1591          * clobberage, but was useful enough for production code to
1592          * semantically rely on it.
1593          *
1594          * We'd like to have a proper introspective interface that
1595          * explicitly describes the reason for whatever unwinding
1596          * operations are currently in progress, so that those modules
1597          * work reliably and $@ isn't further overloaded.  But we don't
1598          * have one yet.  In its absence, as a stopgap measure, ERRSV is
1599          * now *additionally* set here, before unwinding, to serve as the
1600          * (unreliable) flag that it used to.
1601          *
1602          * This behaviour is temporary, and should be removed when a
1603          * proper way to detect exceptional unwinding has been developed.
1604          * As of 2010-12, the authors of modules relying on the hack
1605          * are aware of the issue, because the modules failed on
1606          * perls 5.13.{1..7} which had late setting of $@ without this
1607          * early-setting hack.
1608          */
1609         if (!(in_eval & EVAL_KEEPERR)) {
1610             SvTEMP_off(exceptsv);
1611             sv_setsv(ERRSV, exceptsv);
1612         }
1613
1614         if (in_eval & EVAL_KEEPERR) {
1615             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1616                            SVfARG(exceptsv));
1617         }
1618
1619         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1620                && PL_curstackinfo->si_prev)
1621         {
1622             dounwind(-1);
1623             POPSTACK;
1624         }
1625
1626         if (cxix >= 0) {
1627             I32 optype;
1628             SV *namesv;
1629             PERL_CONTEXT *cx;
1630             SV **newsp;
1631 #ifdef DEBUGGING
1632             COP *oldcop;
1633 #endif
1634             JMPENV *restartjmpenv;
1635             OP *restartop;
1636
1637             if (cxix < cxstack_ix)
1638                 dounwind(cxix);
1639
1640             POPBLOCK(cx,PL_curpm);
1641             if (CxTYPE(cx) != CXt_EVAL) {
1642                 STRLEN msglen;
1643                 const char* message = SvPVx_const(exceptsv, msglen);
1644                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1645                 PerlIO_write(Perl_error_log, message, msglen);
1646                 my_exit(1);
1647             }
1648             POPEVAL(cx);
1649             namesv = cx->blk_eval.old_namesv;
1650 #ifdef DEBUGGING
1651             oldcop = cx->blk_oldcop;
1652 #endif
1653             restartjmpenv = cx->blk_eval.cur_top_env;
1654             restartop = cx->blk_eval.retop;
1655
1656             if (gimme == G_SCALAR)
1657                 *++newsp = &PL_sv_undef;
1658             PL_stack_sp = newsp;
1659
1660             LEAVE;
1661
1662             if (optype == OP_REQUIRE) {
1663                 assert (PL_curcop == oldcop);
1664                 (void)hv_store(GvHVn(PL_incgv),
1665                                SvPVX_const(namesv),
1666                                SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1667                                &PL_sv_undef, 0);
1668                 /* note that unlike pp_entereval, pp_require isn't
1669                  * supposed to trap errors. So now that we've popped the
1670                  * EVAL that pp_require pushed, and processed the error
1671                  * message, rethrow the error */
1672                 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1673                            SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1674                                                                     SVs_TEMP)));
1675             }
1676             if (!(in_eval & EVAL_KEEPERR))
1677                 sv_setsv(ERRSV, exceptsv);
1678             PL_restartjmpenv = restartjmpenv;
1679             PL_restartop = restartop;
1680             JMPENV_JUMP(3);
1681             NOT_REACHED; /* NOTREACHED */
1682         }
1683     }
1684
1685     write_to_stderr(exceptsv);
1686     my_failure_exit();
1687     NOT_REACHED; /* NOTREACHED */
1688 }
1689
1690 PP(pp_xor)
1691 {
1692     dSP; dPOPTOPssrl;
1693     if (SvTRUE(left) != SvTRUE(right))
1694         RETSETYES;
1695     else
1696         RETSETNO;
1697 }
1698
1699 /*
1700
1701 =head1 CV Manipulation Functions
1702
1703 =for apidoc caller_cx
1704
1705 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>.  The
1706 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1707 information returned to Perl by C<caller>.  Note that XSUBs don't get a
1708 stack frame, so C<caller_cx(0, NULL)> will return information for the
1709 immediately-surrounding Perl code.
1710
1711 This function skips over the automatic calls to C<&DB::sub> made on the
1712 behalf of the debugger.  If the stack frame requested was a sub called by
1713 C<DB::sub>, the return value will be the frame for the call to
1714 C<DB::sub>, since that has the correct line number/etc. for the call
1715 site.  If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1716 frame for the sub call itself.
1717
1718 =cut
1719 */
1720
1721 const PERL_CONTEXT *
1722 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1723 {
1724     I32 cxix = dopoptosub(cxstack_ix);
1725     const PERL_CONTEXT *cx;
1726     const PERL_CONTEXT *ccstack = cxstack;
1727     const PERL_SI *top_si = PL_curstackinfo;
1728
1729     for (;;) {
1730         /* we may be in a higher stacklevel, so dig down deeper */
1731         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1732             top_si = top_si->si_prev;
1733             ccstack = top_si->si_cxstack;
1734             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1735         }
1736         if (cxix < 0)
1737             return NULL;
1738         /* caller() should not report the automatic calls to &DB::sub */
1739         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1740                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1741             count++;
1742         if (!count--)
1743             break;
1744         cxix = dopoptosub_at(ccstack, cxix - 1);
1745     }
1746
1747     cx = &ccstack[cxix];
1748     if (dbcxp) *dbcxp = cx;
1749
1750     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1751         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1752         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1753            field below is defined for any cx. */
1754         /* caller() should not report the automatic calls to &DB::sub */
1755         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1756             cx = &ccstack[dbcxix];
1757     }
1758
1759     return cx;
1760 }
1761
1762 PP(pp_caller)
1763 {
1764     dSP;
1765     const PERL_CONTEXT *cx;
1766     const PERL_CONTEXT *dbcx;
1767     I32 gimme = GIMME_V;
1768     const HEK *stash_hek;
1769     I32 count = 0;
1770     bool has_arg = MAXARG && TOPs;
1771     const COP *lcop;
1772
1773     if (MAXARG) {
1774       if (has_arg)
1775         count = POPi;
1776       else (void)POPs;
1777     }
1778
1779     cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1780     if (!cx) {
1781         if (gimme != G_ARRAY) {
1782             EXTEND(SP, 1);
1783             RETPUSHUNDEF;
1784         }
1785         RETURN;
1786     }
1787
1788     DEBUG_CX("CALLER");
1789     assert(CopSTASH(cx->blk_oldcop));
1790     stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1791       ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1792       : NULL;
1793     if (gimme != G_ARRAY) {
1794         EXTEND(SP, 1);
1795         if (!stash_hek)
1796             PUSHs(&PL_sv_undef);
1797         else {
1798             dTARGET;
1799             sv_sethek(TARG, stash_hek);
1800             PUSHs(TARG);
1801         }
1802         RETURN;
1803     }
1804
1805     EXTEND(SP, 11);
1806
1807     if (!stash_hek)
1808         PUSHs(&PL_sv_undef);
1809     else {
1810         dTARGET;
1811         sv_sethek(TARG, stash_hek);
1812         PUSHTARG;
1813     }
1814     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1815     lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1816                        cx->blk_sub.retop, TRUE);
1817     if (!lcop)
1818         lcop = cx->blk_oldcop;
1819     mPUSHi((I32)CopLINE(lcop));
1820     if (!has_arg)
1821         RETURN;
1822     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1823         /* So is ccstack[dbcxix]. */
1824         if (CvHASGV(dbcx->blk_sub.cv)) {
1825             PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1826             PUSHs(boolSV(CxHASARGS(cx)));
1827         }
1828         else {
1829             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1830             PUSHs(boolSV(CxHASARGS(cx)));
1831         }
1832     }
1833     else {
1834         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1835         mPUSHi(0);
1836     }
1837     gimme = (I32)cx->blk_gimme;
1838     if (gimme == G_VOID)
1839         PUSHs(&PL_sv_undef);
1840     else
1841         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1842     if (CxTYPE(cx) == CXt_EVAL) {
1843         /* eval STRING */
1844         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1845             SV *cur_text = cx->blk_eval.cur_text;
1846             if (SvCUR(cur_text) >= 2) {
1847                 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1848                                      SvUTF8(cur_text)|SVs_TEMP));
1849             }
1850             else {
1851                 /* I think this is will always be "", but be sure */
1852                 PUSHs(sv_2mortal(newSVsv(cur_text)));
1853             }
1854
1855             PUSHs(&PL_sv_no);
1856         }
1857         /* require */
1858         else if (cx->blk_eval.old_namesv) {
1859             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1860             PUSHs(&PL_sv_yes);
1861         }
1862         /* eval BLOCK (try blocks have old_namesv == 0) */
1863         else {
1864             PUSHs(&PL_sv_undef);
1865             PUSHs(&PL_sv_undef);
1866         }
1867     }
1868     else {
1869         PUSHs(&PL_sv_undef);
1870         PUSHs(&PL_sv_undef);
1871     }
1872     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1873         && CopSTASH_eq(PL_curcop, PL_debstash))
1874     {
1875         AV * const ary = cx->blk_sub.argarray;
1876         const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1877
1878         Perl_init_dbargs(aTHX);
1879
1880         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1881             av_extend(PL_dbargs, AvFILLp(ary) + off);
1882         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1883         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1884     }
1885     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1886     {
1887         SV * mask ;
1888         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1889
1890         if  (old_warnings == pWARN_NONE)
1891             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1892         else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1893             mask = &PL_sv_undef ;
1894         else if (old_warnings == pWARN_ALL ||
1895                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1896             /* Get the bit mask for $warnings::Bits{all}, because
1897              * it could have been extended by warnings::register */
1898             SV **bits_all;
1899             HV * const bits = get_hv("warnings::Bits", 0);
1900             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1901                 mask = newSVsv(*bits_all);
1902             }
1903             else {
1904                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1905             }
1906         }
1907         else
1908             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1909         mPUSHs(mask);
1910     }
1911
1912     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1913           sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1914           : &PL_sv_undef);
1915     RETURN;
1916 }
1917
1918 PP(pp_reset)
1919 {
1920     dSP;
1921     const char * tmps;
1922     STRLEN len = 0;
1923     if (MAXARG < 1 || (!TOPs && !POPs))
1924         tmps = NULL, len = 0;
1925     else
1926         tmps = SvPVx_const(POPs, len);
1927     sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1928     PUSHs(&PL_sv_yes);
1929     RETURN;
1930 }
1931
1932 /* like pp_nextstate, but used instead when the debugger is active */
1933
1934 PP(pp_dbstate)
1935 {
1936     PL_curcop = (COP*)PL_op;
1937     TAINT_NOT;          /* Each statement is presumed innocent */
1938     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1939     FREETMPS;
1940
1941     PERL_ASYNC_CHECK();
1942
1943     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1944             || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
1945     {
1946         dSP;
1947         PERL_CONTEXT *cx;
1948         const I32 gimme = G_ARRAY;
1949         U8 hasargs;
1950         GV * const gv = PL_DBgv;
1951         CV * cv = NULL;
1952
1953         if (gv && isGV_with_GP(gv))
1954             cv = GvCV(gv);
1955
1956         if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1957             DIE(aTHX_ "No DB::DB routine defined");
1958
1959         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1960             /* don't do recursive DB::DB call */
1961             return NORMAL;
1962
1963         ENTER;
1964         SAVETMPS;
1965
1966         SAVEI32(PL_debug);
1967         SAVESTACK_POS();
1968         PL_debug = 0;
1969         hasargs = 0;
1970         SPAGAIN;
1971
1972         if (CvISXSUB(cv)) {
1973             PUSHMARK(SP);
1974             (void)(*CvXSUB(cv))(aTHX_ cv);
1975             FREETMPS;
1976             LEAVE;
1977             return NORMAL;
1978         }
1979         else {
1980             PUSHBLOCK(cx, CXt_SUB, SP);
1981             PUSHSUB_DB(cx);
1982             cx->blk_sub.retop = PL_op->op_next;
1983             CvDEPTH(cv)++;
1984             if (CvDEPTH(cv) >= 2) {
1985                 PERL_STACK_OVERFLOW_CHECK();
1986                 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1987             }
1988             SAVECOMPPAD();
1989             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1990             RETURNOP(CvSTART(cv));
1991         }
1992     }
1993     else
1994         return NORMAL;
1995 }
1996
1997 /* S_leave_common: Common code that many functions in this file use on
1998                    scope exit.  */
1999
2000 /* SVs on the stack that have any of the flags passed in are left as is.
2001    Other SVs are protected via the mortals stack if lvalue is true, and
2002    copied otherwise.
2003
2004    Also, taintedness is cleared.
2005 */
2006
2007 STATIC SV **
2008 S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
2009                               U32 flags, bool lvalue)
2010 {
2011     bool padtmp = 0;
2012     PERL_ARGS_ASSERT_LEAVE_COMMON;
2013
2014     TAINT_NOT;
2015     if (flags & SVs_PADTMP) {
2016         flags &= ~SVs_PADTMP;
2017         padtmp = 1;
2018     }
2019     if (gimme == G_SCALAR) {
2020         if (MARK < SP)
2021             *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2022                             ? *SP
2023                             : lvalue
2024                                 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2025                                 : sv_mortalcopy(*SP);
2026         else {
2027             /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2028             MARK = newsp;
2029             MEXTEND(MARK, 1);
2030             *++MARK = &PL_sv_undef;
2031             return MARK;
2032         }
2033     }
2034     else if (gimme == G_ARRAY) {
2035         /* in case LEAVE wipes old return values */
2036         while (++MARK <= SP) {
2037             if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2038                 *++newsp = *MARK;
2039             else {
2040                 *++newsp = lvalue
2041                             ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
2042                             : sv_mortalcopy(*MARK);
2043                 TAINT_NOT;      /* Each item is independent */
2044             }
2045         }
2046         /* When this function was called with MARK == newsp, we reach this
2047          * point with SP == newsp. */
2048     }
2049
2050     return newsp;
2051 }
2052
2053 PP(pp_enter)
2054 {
2055     dSP;
2056     PERL_CONTEXT *cx;
2057     I32 gimme = GIMME_V;
2058
2059     ENTER_with_name("block");
2060
2061     SAVETMPS;
2062     PUSHBLOCK(cx, CXt_BLOCK, SP);
2063
2064     RETURN;
2065 }
2066
2067 PP(pp_leave)
2068 {
2069     dSP;
2070     PERL_CONTEXT *cx;
2071     SV **newsp;
2072     PMOP *newpm;
2073     I32 gimme;
2074
2075     if (PL_op->op_flags & OPf_SPECIAL) {
2076         cx = &cxstack[cxstack_ix];
2077         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
2078     }
2079
2080     POPBLOCK(cx,newpm);
2081
2082     gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2083
2084     SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
2085                                PL_op->op_private & OPpLVALUE);
2086     PL_curpm = newpm;   /* Don't pop $1 et al till now */
2087
2088     LEAVE_with_name("block");
2089
2090     RETURN;
2091 }
2092
2093 static bool
2094 S_outside_integer(pTHX_ SV *sv)
2095 {
2096   if (SvOK(sv)) {
2097     const NV nv = SvNV_nomg(sv);
2098 #ifdef NV_PRESERVES_UV
2099     if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2100       return TRUE;
2101 #else
2102     if (nv <= (NV)IV_MIN)
2103       return TRUE;
2104     if ((nv > 0) &&
2105         ((nv > (NV)UV_MAX ||
2106           SvUV_nomg(sv) > (UV)IV_MAX)))
2107       return TRUE;
2108 #endif
2109   }
2110   return FALSE;
2111 }
2112
2113 PP(pp_enteriter)
2114 {
2115     dSP; dMARK;
2116     PERL_CONTEXT *cx;
2117     const I32 gimme = GIMME_V;
2118     void *itervar; /* location of the iteration variable */
2119     U8 cxtype = CXt_LOOP_FOR;
2120
2121     ENTER_with_name("loop1");
2122     SAVETMPS;
2123
2124     if (PL_op->op_targ) {                        /* "my" variable */
2125         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2126             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2127             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2128                     SVs_PADSTALE, SVs_PADSTALE);
2129         }
2130         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2131 #ifdef USE_ITHREADS
2132         itervar = PL_comppad;
2133 #else
2134         itervar = &PAD_SVl(PL_op->op_targ);
2135 #endif
2136     }
2137     else if (LIKELY(isGV(TOPs))) {              /* symbol table variable */
2138         GV * const gv = MUTABLE_GV(POPs);
2139         SV** svp = &GvSV(gv);
2140         save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2141         *svp = newSV(0);
2142         itervar = (void *)gv;
2143         save_aliased_sv(gv);
2144     }
2145     else {
2146         SV * const sv = POPs;
2147         assert(SvTYPE(sv) == SVt_PVMG);
2148         assert(SvMAGIC(sv));
2149         assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2150         itervar = (void *)sv;
2151         cxtype |= CXp_FOR_LVREF;
2152     }
2153
2154     if (PL_op->op_private & OPpITER_DEF)
2155         cxtype |= CXp_FOR_DEF;
2156
2157     ENTER_with_name("loop2");
2158
2159     PUSHBLOCK(cx, cxtype, SP);
2160     PUSHLOOP_FOR(cx, itervar, MARK);
2161     if (PL_op->op_flags & OPf_STACKED) {
2162         SV *maybe_ary = POPs;
2163         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2164             dPOPss;
2165             SV * const right = maybe_ary;
2166             if (UNLIKELY(cxtype & CXp_FOR_LVREF))
2167                 DIE(aTHX_ "Assigned value is not a reference");
2168             SvGETMAGIC(sv);
2169             SvGETMAGIC(right);
2170             if (RANGE_IS_NUMERIC(sv,right)) {
2171                 cx->cx_type &= ~CXTYPEMASK;
2172                 cx->cx_type |= CXt_LOOP_LAZYIV;
2173                 /* Make sure that no-one re-orders cop.h and breaks our
2174                    assumptions */
2175                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2176                 if (S_outside_integer(aTHX_ sv) ||
2177                     S_outside_integer(aTHX_ right))
2178                     DIE(aTHX_ "Range iterator outside integer range");
2179                 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2180                 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2181 #ifdef DEBUGGING
2182                 /* for correct -Dstv display */
2183                 cx->blk_oldsp = sp - PL_stack_base;
2184 #endif
2185             }
2186             else {
2187                 cx->cx_type &= ~CXTYPEMASK;
2188                 cx->cx_type |= CXt_LOOP_LAZYSV;
2189                 /* Make sure that no-one re-orders cop.h and breaks our
2190                    assumptions */
2191                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2192                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2193                 cx->blk_loop.state_u.lazysv.end = right;
2194                 SvREFCNT_inc(right);
2195                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2196                 /* This will do the upgrade to SVt_PV, and warn if the value
2197                    is uninitialised.  */
2198                 (void) SvPV_nolen_const(right);
2199                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2200                    to replace !SvOK() with a pointer to "".  */
2201                 if (!SvOK(right)) {
2202                     SvREFCNT_dec(right);
2203                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2204                 }
2205             }
2206         }
2207         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2208             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2209             SvREFCNT_inc(maybe_ary);
2210             cx->blk_loop.state_u.ary.ix =
2211                 (PL_op->op_private & OPpITER_REVERSED) ?
2212                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2213                 -1;
2214         }
2215     }
2216     else { /* iterating over items on the stack */
2217         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2218         if (PL_op->op_private & OPpITER_REVERSED) {
2219             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2220         }
2221         else {
2222             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2223         }
2224     }
2225
2226     RETURN;
2227 }
2228
2229 PP(pp_enterloop)
2230 {
2231     dSP;
2232     PERL_CONTEXT *cx;
2233     const I32 gimme = GIMME_V;
2234
2235     ENTER_with_name("loop1");
2236     SAVETMPS;
2237     ENTER_with_name("loop2");
2238
2239     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2240     PUSHLOOP_PLAIN(cx, SP);
2241
2242     RETURN;
2243 }
2244
2245 PP(pp_leaveloop)
2246 {
2247     dSP;
2248     PERL_CONTEXT *cx;
2249     I32 gimme;
2250     SV **newsp;
2251     PMOP *newpm;
2252     SV **mark;
2253
2254     POPBLOCK(cx,newpm);
2255     assert(CxTYPE_is_LOOP(cx));
2256     mark = newsp;
2257     newsp = PL_stack_base + cx->blk_loop.resetsp;
2258
2259     SP = leave_common(newsp, SP, MARK, gimme, 0,
2260                                PL_op->op_private & OPpLVALUE);
2261     PUTBACK;
2262
2263     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2264     PL_curpm = newpm;   /* ... and pop $1 et al */
2265
2266     LEAVE_with_name("loop2");
2267     LEAVE_with_name("loop1");
2268
2269     return NORMAL;
2270 }
2271
2272 STATIC void
2273 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2274                        PERL_CONTEXT *cx, PMOP *newpm)
2275 {
2276     const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2277     if (gimme == G_SCALAR) {
2278         if (CxLVAL(cx) && !ref) {     /* Leave it as it is if we can. */
2279             SV *sv;
2280             const char *what = NULL;
2281             if (MARK < SP) {
2282                 assert(MARK+1 == SP);
2283                 if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
2284                     !SvSMAGICAL(TOPs)) {
2285                     what =
2286                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2287                         : "a readonly value" : "a temporary";
2288                 }
2289                 else goto copy_sv;
2290             }
2291             else {
2292                 /* sub:lvalue{} will take us here. */
2293                 what = "undef";
2294             }
2295             LEAVE;
2296             cxstack_ix--;
2297             POPSUB(cx,sv);
2298             PL_curpm = newpm;
2299             LEAVESUB(sv);
2300             Perl_croak(aTHX_
2301                       "Can't return %s from lvalue subroutine", what
2302             );
2303         }
2304         if (MARK < SP) {
2305               copy_sv:
2306                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2307                     if (!SvPADTMP(*SP)) {
2308                         *++newsp = SvREFCNT_inc(*SP);
2309                         FREETMPS;
2310                         sv_2mortal(*newsp);
2311                     }
2312                     else {
2313                         /* FREETMPS could clobber it */
2314                         SV *sv = SvREFCNT_inc(*SP);
2315                         FREETMPS;
2316                         *++newsp = sv_mortalcopy(sv);
2317                         SvREFCNT_dec(sv);
2318                     }
2319                 }
2320                 else
2321                     *++newsp =
2322                       SvPADTMP(*SP)
2323                        ? sv_mortalcopy(*SP)
2324                        : !SvTEMP(*SP)
2325                           ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2326                           : *SP;
2327         }
2328         else {
2329             EXTEND(newsp,1);
2330             *++newsp = &PL_sv_undef;
2331         }
2332         if (CxLVAL(cx) & OPpDEREF) {
2333             SvGETMAGIC(TOPs);
2334             if (!SvOK(TOPs)) {
2335                 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2336             }
2337         }
2338     }
2339     else if (gimme == G_ARRAY) {
2340         assert (!(CxLVAL(cx) & OPpDEREF));
2341         if (ref || !CxLVAL(cx))
2342             while (++MARK <= SP)
2343                 *++newsp =
2344                        SvFLAGS(*MARK) & SVs_PADTMP
2345                            ? sv_mortalcopy(*MARK)
2346                      : SvTEMP(*MARK)
2347                            ? *MARK
2348                            : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2349         else while (++MARK <= SP) {
2350             if (*MARK != &PL_sv_undef
2351                     && (SvPADTMP(*MARK) || SvREADONLY(*MARK))
2352             ) {
2353                     const bool ro = cBOOL( SvREADONLY(*MARK) );
2354                     SV *sv;
2355                     /* Might be flattened array after $#array =  */
2356                     PUTBACK;
2357                     LEAVE;
2358                     cxstack_ix--;
2359                     POPSUB(cx,sv);
2360                     PL_curpm = newpm;
2361                     LEAVESUB(sv);
2362                /* diag_listed_as: Can't return %s from lvalue subroutine */
2363                     Perl_croak(aTHX_
2364                         "Can't return a %s from lvalue subroutine",
2365                          ro ? "readonly value" : "temporary");
2366             }
2367             else
2368                 *++newsp =
2369                     SvTEMP(*MARK)
2370                        ? *MARK
2371                        : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2372         }
2373     }
2374     PL_stack_sp = newsp;
2375 }
2376
2377 PP(pp_return)
2378 {
2379     dSP; dMARK;
2380     PERL_CONTEXT *cx;
2381     bool popsub2 = FALSE;
2382     bool clear_errsv = FALSE;
2383     bool lval = FALSE;
2384     I32 gimme;
2385     SV **newsp;
2386     PMOP *newpm;
2387     I32 optype = 0;
2388     SV *namesv;
2389     SV *sv;
2390     OP *retop = NULL;
2391
2392     const I32 cxix = dopoptosub(cxstack_ix);
2393
2394     if (cxix < 0) {
2395         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2396                                      * sort block, which is a CXt_NULL
2397                                      * not a CXt_SUB */
2398             dounwind(0);
2399             PL_stack_base[1] = *PL_stack_sp;
2400             PL_stack_sp = PL_stack_base + 1;
2401             return 0;
2402         }
2403         else
2404             DIE(aTHX_ "Can't return outside a subroutine");
2405     }
2406     if (cxix < cxstack_ix)
2407         dounwind(cxix);
2408
2409     if (CxMULTICALL(&cxstack[cxix])) {
2410         gimme = cxstack[cxix].blk_gimme;
2411         if (gimme == G_VOID)
2412             PL_stack_sp = PL_stack_base;
2413         else if (gimme == G_SCALAR) {
2414             PL_stack_base[1] = *PL_stack_sp;
2415             PL_stack_sp = PL_stack_base + 1;
2416         }
2417         return 0;
2418     }
2419
2420     POPBLOCK(cx,newpm);
2421     switch (CxTYPE(cx)) {
2422     case CXt_SUB:
2423         popsub2 = TRUE;
2424         lval = !!CvLVALUE(cx->blk_sub.cv);
2425         retop = cx->blk_sub.retop;
2426         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2427         break;
2428     case CXt_EVAL:
2429         if (!(PL_in_eval & EVAL_KEEPERR))
2430             clear_errsv = TRUE;
2431         POPEVAL(cx);
2432         namesv = cx->blk_eval.old_namesv;
2433         retop = cx->blk_eval.retop;
2434         if (CxTRYBLOCK(cx))
2435             break;
2436         if (optype == OP_REQUIRE &&
2437             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2438         {
2439             /* Unassume the success we assumed earlier. */
2440             (void)hv_delete(GvHVn(PL_incgv),
2441                             SvPVX_const(namesv),
2442                             SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2443                             G_DISCARD);
2444             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2445         }
2446         break;
2447     case CXt_FORMAT:
2448         retop = cx->blk_sub.retop;
2449         POPFORMAT(cx);
2450         break;
2451     default:
2452         DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2453     }
2454
2455     TAINT_NOT;
2456     if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2457     else {
2458       if (gimme == G_SCALAR) {
2459         if (MARK < SP) {
2460             if (popsub2) {
2461                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2462                     if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2463                          && !SvMAGICAL(TOPs)) {
2464                         *++newsp = SvREFCNT_inc(*SP);
2465                         FREETMPS;
2466                         sv_2mortal(*newsp);
2467                     }
2468                     else {
2469                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2470                         FREETMPS;
2471                         *++newsp = sv_mortalcopy(sv);
2472                         SvREFCNT_dec(sv);
2473                     }
2474                 }
2475                 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2476                           && !SvMAGICAL(*SP)) {
2477                     *++newsp = *SP;
2478                 }
2479                 else
2480                     *++newsp = sv_mortalcopy(*SP);
2481             }
2482             else
2483                 *++newsp = sv_mortalcopy(*SP);
2484         }
2485         else
2486             *++newsp = &PL_sv_undef;
2487       }
2488       else if (gimme == G_ARRAY) {
2489         while (++MARK <= SP) {
2490             *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2491                                && !SvGMAGICAL(*MARK)
2492                         ? *MARK : sv_mortalcopy(*MARK);
2493             TAINT_NOT;          /* Each item is independent */
2494         }
2495       }
2496       PL_stack_sp = newsp;
2497     }
2498
2499     LEAVE;
2500     /* Stack values are safe: */
2501     if (popsub2) {
2502         cxstack_ix--;
2503         POPSUB(cx,sv);  /* release CV and @_ ... */
2504     }
2505     else
2506         sv = NULL;
2507     PL_curpm = newpm;   /* ... and pop $1 et al */
2508
2509     LEAVESUB(sv);
2510     if (clear_errsv) {
2511         CLEAR_ERRSV();
2512     }
2513     return retop;
2514 }
2515
2516 /* This duplicates parts of pp_leavesub, so that it can share code with
2517  * pp_return */
2518 PP(pp_leavesublv)
2519 {
2520     dSP;
2521     SV **newsp;
2522     PMOP *newpm;
2523     I32 gimme;
2524     PERL_CONTEXT *cx;
2525     SV *sv;
2526
2527     if (CxMULTICALL(&cxstack[cxstack_ix]))
2528         return 0;
2529
2530     POPBLOCK(cx,newpm);
2531     cxstack_ix++; /* temporarily protect top context */
2532
2533     TAINT_NOT;
2534
2535     S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2536
2537     LEAVE;
2538     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2539     cxstack_ix--;
2540     PL_curpm = newpm;   /* ... and pop $1 et al */
2541
2542     LEAVESUB(sv);
2543     return cx->blk_sub.retop;
2544 }
2545
2546 static I32
2547 S_unwind_loop(pTHX_ const char * const opname)
2548 {
2549     I32 cxix;
2550     if (PL_op->op_flags & OPf_SPECIAL) {
2551         cxix = dopoptoloop(cxstack_ix);
2552         if (cxix < 0)
2553             /* diag_listed_as: Can't "last" outside a loop block */
2554             Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2555     }
2556     else {
2557         dSP;
2558         STRLEN label_len;
2559         const char * const label =
2560             PL_op->op_flags & OPf_STACKED
2561                 ? SvPV(TOPs,label_len)
2562                 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2563         const U32 label_flags =
2564             PL_op->op_flags & OPf_STACKED
2565                 ? SvUTF8(POPs)
2566                 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2567         PUTBACK;
2568         cxix = dopoptolabel(label, label_len, label_flags);
2569         if (cxix < 0)
2570             /* diag_listed_as: Label not found for "last %s" */
2571             Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2572                                        opname,
2573                                        SVfARG(PL_op->op_flags & OPf_STACKED
2574                                               && !SvGMAGICAL(TOPp1s)
2575                                               ? TOPp1s
2576                                               : newSVpvn_flags(label,
2577                                                     label_len,
2578                                                     label_flags | SVs_TEMP)));
2579     }
2580     if (cxix < cxstack_ix)
2581         dounwind(cxix);
2582     return cxix;
2583 }
2584
2585 PP(pp_last)
2586 {
2587     PERL_CONTEXT *cx;
2588     I32 pop2 = 0;
2589     I32 gimme;
2590     I32 optype;
2591     OP *nextop = NULL;
2592     SV **newsp;
2593     PMOP *newpm;
2594     SV *sv = NULL;
2595
2596     S_unwind_loop(aTHX_ "last");
2597
2598     POPBLOCK(cx,newpm);
2599     cxstack_ix++; /* temporarily protect top context */
2600     switch (CxTYPE(cx)) {
2601     case CXt_LOOP_LAZYIV:
2602     case CXt_LOOP_LAZYSV:
2603     case CXt_LOOP_FOR:
2604     case CXt_LOOP_PLAIN:
2605         pop2 = CxTYPE(cx);
2606         newsp = PL_stack_base + cx->blk_loop.resetsp;
2607         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2608         break;
2609     case CXt_SUB:
2610         pop2 = CXt_SUB;
2611         nextop = cx->blk_sub.retop;
2612         break;
2613     case CXt_EVAL:
2614         POPEVAL(cx);
2615         nextop = cx->blk_eval.retop;
2616         break;
2617     case CXt_FORMAT:
2618         POPFORMAT(cx);
2619         nextop = cx->blk_sub.retop;
2620         break;
2621     default:
2622         DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2623     }
2624
2625     TAINT_NOT;
2626     PL_stack_sp = newsp;
2627
2628     LEAVE;
2629     cxstack_ix--;
2630     /* Stack values are safe: */
2631     switch (pop2) {
2632     case CXt_LOOP_LAZYIV:
2633     case CXt_LOOP_PLAIN:
2634     case CXt_LOOP_LAZYSV:
2635     case CXt_LOOP_FOR:
2636         POPLOOP(cx);    /* release loop vars ... */
2637         LEAVE;
2638         break;
2639     case CXt_SUB:
2640         POPSUB(cx,sv);  /* release CV and @_ ... */
2641         break;
2642     }
2643     PL_curpm = newpm;   /* ... and pop $1 et al */
2644
2645     LEAVESUB(sv);
2646     PERL_UNUSED_VAR(optype);
2647     PERL_UNUSED_VAR(gimme);
2648     return nextop;
2649 }
2650
2651 PP(pp_next)
2652 {
2653     PERL_CONTEXT *cx;
2654     const I32 inner = PL_scopestack_ix;
2655
2656     S_unwind_loop(aTHX_ "next");
2657
2658     /* clear off anything above the scope we're re-entering, but
2659      * save the rest until after a possible continue block */
2660     TOPBLOCK(cx);
2661     if (PL_scopestack_ix < inner)
2662         leave_scope(PL_scopestack[PL_scopestack_ix]);
2663     PL_curcop = cx->blk_oldcop;
2664     PERL_ASYNC_CHECK();
2665     return (cx)->blk_loop.my_op->op_nextop;
2666 }
2667
2668 PP(pp_redo)
2669 {
2670     const I32 cxix = S_unwind_loop(aTHX_ "redo");
2671     PERL_CONTEXT *cx;
2672     I32 oldsave;
2673     OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2674
2675     if (redo_op->op_type == OP_ENTER) {
2676         /* pop one less context to avoid $x being freed in while (my $x..) */
2677         cxstack_ix++;
2678         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2679         redo_op = redo_op->op_next;
2680     }
2681
2682     TOPBLOCK(cx);
2683     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2684     LEAVE_SCOPE(oldsave);
2685     FREETMPS;
2686     PL_curcop = cx->blk_oldcop;
2687     PERL_ASYNC_CHECK();
2688     return redo_op;
2689 }
2690
2691 STATIC OP *
2692 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2693 {
2694     OP **ops = opstack;
2695     static const char* const too_deep = "Target of goto is too deeply nested";
2696
2697     PERL_ARGS_ASSERT_DOFINDLABEL;
2698
2699     if (ops >= oplimit)
2700         Perl_croak(aTHX_ "%s", too_deep);
2701     if (o->op_type == OP_LEAVE ||
2702         o->op_type == OP_SCOPE ||
2703         o->op_type == OP_LEAVELOOP ||
2704         o->op_type == OP_LEAVESUB ||
2705         o->op_type == OP_LEAVETRY)
2706     {
2707         *ops++ = cUNOPo->op_first;
2708         if (ops >= oplimit)
2709             Perl_croak(aTHX_ "%s", too_deep);
2710     }
2711     *ops = 0;
2712     if (o->op_flags & OPf_KIDS) {
2713         OP *kid;
2714         /* First try all the kids at this level, since that's likeliest. */
2715         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2716             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2717                 STRLEN kid_label_len;
2718                 U32 kid_label_flags;
2719                 const char *kid_label = CopLABEL_len_flags(kCOP,
2720                                                     &kid_label_len, &kid_label_flags);
2721                 if (kid_label && (
2722                     ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2723                         (flags & SVf_UTF8)
2724                             ? (bytes_cmp_utf8(
2725                                         (const U8*)kid_label, kid_label_len,
2726                                         (const U8*)label, len) == 0)
2727                             : (bytes_cmp_utf8(
2728                                         (const U8*)label, len,
2729                                         (const U8*)kid_label, kid_label_len) == 0)
2730                     : ( len == kid_label_len && ((kid_label == label)
2731                                     || memEQ(kid_label, label, len)))))
2732                     return kid;
2733             }
2734         }
2735         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2736             if (kid == PL_lastgotoprobe)
2737                 continue;
2738             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2739                 if (ops == opstack)
2740                     *ops++ = kid;
2741                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2742                          ops[-1]->op_type == OP_DBSTATE)
2743                     ops[-1] = kid;
2744                 else
2745                     *ops++ = kid;
2746             }
2747             if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2748                 return o;
2749         }
2750     }
2751     *ops = 0;
2752     return 0;
2753 }
2754
2755
2756 /* also used for: pp_dump() */
2757
2758 PP(pp_goto)
2759 {
2760     dVAR; dSP;
2761     OP *retop = NULL;
2762     I32 ix;
2763     PERL_CONTEXT *cx;
2764 #define GOTO_DEPTH 64
2765     OP *enterops[GOTO_DEPTH];
2766     const char *label = NULL;
2767     STRLEN label_len = 0;
2768     U32 label_flags = 0;
2769     const bool do_dump = (PL_op->op_type == OP_DUMP);
2770     static const char* const must_have_label = "goto must have label";
2771
2772     if (PL_op->op_flags & OPf_STACKED) {
2773         /* goto EXPR  or  goto &foo */
2774
2775         SV * const sv = POPs;
2776         SvGETMAGIC(sv);
2777
2778         /* This egregious kludge implements goto &subroutine */
2779         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2780             I32 cxix;
2781             PERL_CONTEXT *cx;
2782             CV *cv = MUTABLE_CV(SvRV(sv));
2783             AV *arg = GvAV(PL_defgv);
2784             I32 oldsave;
2785
2786         retry:
2787             if (!CvROOT(cv) && !CvXSUB(cv)) {
2788                 const GV * const gv = CvGV(cv);
2789                 if (gv) {
2790                     GV *autogv;
2791                     SV *tmpstr;
2792                     /* autoloaded stub? */
2793                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2794                         goto retry;
2795                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2796                                           GvNAMELEN(gv),
2797                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2798                     if (autogv && (cv = GvCV(autogv)))
2799                         goto retry;
2800                     tmpstr = sv_newmortal();
2801                     gv_efullname3(tmpstr, gv, NULL);
2802                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2803                 }
2804                 DIE(aTHX_ "Goto undefined subroutine");
2805             }
2806
2807             /* First do some returnish stuff. */
2808             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2809             FREETMPS;
2810             cxix = dopoptosub(cxstack_ix);
2811             if (cxix < cxstack_ix) {
2812                 if (cxix < 0) {
2813                     SvREFCNT_dec(cv);
2814                     DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2815                 }
2816                 dounwind(cxix);
2817             }
2818             TOPBLOCK(cx);
2819             SPAGAIN;
2820             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2821             if (CxTYPE(cx) == CXt_EVAL) {
2822                 SvREFCNT_dec(cv);
2823                 if (CxREALEVAL(cx))
2824                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2825                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2826                 else
2827                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2828                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2829             }
2830             else if (CxMULTICALL(cx))
2831             {
2832                 SvREFCNT_dec(cv);
2833                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2834             }
2835             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2836                 AV* av = cx->blk_sub.argarray;
2837
2838                 /* abandon the original @_ if it got reified or if it is
2839                    the same as the current @_ */
2840                 if (AvREAL(av) || av == arg) {
2841                     SvREFCNT_dec(av);
2842                     av = newAV();
2843                     AvREIFY_only(av);
2844                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2845                 }
2846                 else CLEAR_ARGARRAY(av);
2847             }
2848             /* We donate this refcount later to the callee’s pad. */
2849             SvREFCNT_inc_simple_void(arg);
2850             if (CxTYPE(cx) == CXt_SUB &&
2851                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2852                 SvREFCNT_dec(cx->blk_sub.cv);
2853             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2854             LEAVE_SCOPE(oldsave);
2855
2856             /* A destructor called during LEAVE_SCOPE could have undefined
2857              * our precious cv.  See bug #99850. */
2858             if (!CvROOT(cv) && !CvXSUB(cv)) {
2859                 const GV * const gv = CvGV(cv);
2860                 SvREFCNT_dec(arg);
2861                 if (gv) {
2862                     SV * const tmpstr = sv_newmortal();
2863                     gv_efullname3(tmpstr, gv, NULL);
2864                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2865                                SVfARG(tmpstr));
2866                 }
2867                 DIE(aTHX_ "Goto undefined subroutine");
2868             }
2869
2870             /* Now do some callish stuff. */
2871             SAVETMPS;
2872             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2873             if (CvISXSUB(cv)) {
2874                 SV **newsp;
2875                 I32 gimme;
2876                 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2877                 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2878                 SV** mark;
2879
2880                 PERL_UNUSED_VAR(newsp);
2881                 PERL_UNUSED_VAR(gimme);
2882
2883                 /* put GvAV(defgv) back onto stack */
2884                 if (items) {
2885                     EXTEND(SP, items+1); /* @_ could have been extended. */
2886                 }
2887                 mark = SP;
2888                 if (items) {
2889                     SSize_t index;
2890                     bool r = cBOOL(AvREAL(arg));
2891                     for (index=0; index<items; index++)
2892                     {
2893                         SV *sv;
2894                         if (m) {
2895                             SV ** const svp = av_fetch(arg, index, 0);
2896                             sv = svp ? *svp : NULL;
2897                         }
2898                         else sv = AvARRAY(arg)[index];
2899                         SP[index+1] = sv
2900                             ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2901                             : sv_2mortal(newSVavdefelem(arg, index, 1));
2902                     }
2903                 }
2904                 SP += items;
2905                 SvREFCNT_dec(arg);
2906                 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2907                     /* Restore old @_ */
2908                     arg = GvAV(PL_defgv);
2909                     GvAV(PL_defgv) = cx->blk_sub.savearray;
2910                     SvREFCNT_dec(arg);
2911                 }
2912
2913                 retop = cx->blk_sub.retop;
2914                 /* XS subs don't have a CxSUB, so pop it */
2915                 POPBLOCK(cx, PL_curpm);
2916                 /* Push a mark for the start of arglist */
2917                 PUSHMARK(mark);
2918                 PUTBACK;
2919                 (void)(*CvXSUB(cv))(aTHX_ cv);
2920                 LEAVE;
2921                 goto _return;
2922             }
2923             else {
2924                 PADLIST * const padlist = CvPADLIST(cv);
2925                 cx->blk_sub.cv = cv;
2926                 cx->blk_sub.olddepth = CvDEPTH(cv);
2927
2928                 CvDEPTH(cv)++;
2929                 if (CvDEPTH(cv) < 2)
2930                     SvREFCNT_inc_simple_void_NN(cv);
2931                 else {
2932                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2933                         sub_crush_depth(cv);
2934                     pad_push(padlist, CvDEPTH(cv));
2935                 }
2936                 PL_curcop = cx->blk_oldcop;
2937                 SAVECOMPPAD();
2938                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2939                 if (CxHASARGS(cx))
2940                 {
2941                     CX_CURPAD_SAVE(cx->blk_sub);
2942
2943                     /* cx->blk_sub.argarray has no reference count, so we
2944                        need something to hang on to our argument array so
2945                        that cx->blk_sub.argarray does not end up pointing
2946                        to freed memory as the result of undef *_.  So put
2947                        it in the callee’s pad, donating our refer-
2948                        ence count. */
2949                     if (arg) {
2950                         SvREFCNT_dec(PAD_SVl(0));
2951                         PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2952                     }
2953
2954                     /* GvAV(PL_defgv) might have been modified on scope
2955                        exit, so restore it. */
2956                     if (arg != GvAV(PL_defgv)) {
2957                         AV * const av = GvAV(PL_defgv);
2958                         GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2959                         SvREFCNT_dec(av);
2960                     }
2961                 }
2962                 else SvREFCNT_dec(arg);
2963                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2964                     Perl_get_db_sub(aTHX_ NULL, cv);
2965                     if (PERLDB_GOTO) {
2966                         CV * const gotocv = get_cvs("DB::goto", 0);
2967                         if (gotocv) {
2968                             PUSHMARK( PL_stack_sp );
2969                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2970                             PL_stack_sp--;
2971                         }
2972                     }
2973                 }
2974                 retop = CvSTART(cv);
2975                 goto putback_return;
2976             }
2977         }
2978         else {
2979             /* goto EXPR */
2980             label       = SvPV_nomg_const(sv, label_len);
2981             label_flags = SvUTF8(sv);
2982         }
2983     }
2984     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2985         /* goto LABEL  or  dump LABEL */
2986         label       = cPVOP->op_pv;
2987         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2988         label_len   = strlen(label);
2989     }
2990     if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2991
2992     PERL_ASYNC_CHECK();
2993
2994     if (label_len) {
2995         OP *gotoprobe = NULL;
2996         bool leaving_eval = FALSE;
2997         bool in_block = FALSE;
2998         PERL_CONTEXT *last_eval_cx = NULL;
2999
3000         /* find label */
3001
3002         PL_lastgotoprobe = NULL;
3003         *enterops = 0;
3004         for (ix = cxstack_ix; ix >= 0; ix--) {
3005             cx = &cxstack[ix];
3006             switch (CxTYPE(cx)) {
3007             case CXt_EVAL:
3008                 leaving_eval = TRUE;
3009                 if (!CxTRYBLOCK(cx)) {
3010                     gotoprobe = (last_eval_cx ?
3011                                 last_eval_cx->blk_eval.old_eval_root :
3012                                 PL_eval_root);
3013                     last_eval_cx = cx;
3014                     break;
3015                 }
3016                 /* else fall through */
3017             case CXt_LOOP_LAZYIV:
3018             case CXt_LOOP_LAZYSV:
3019             case CXt_LOOP_FOR:
3020             case CXt_LOOP_PLAIN:
3021             case CXt_GIVEN:
3022             case CXt_WHEN:
3023                 gotoprobe = OpSIBLING(cx->blk_oldcop);
3024                 break;
3025             case CXt_SUBST:
3026                 continue;
3027             case CXt_BLOCK:
3028                 if (ix) {
3029                     gotoprobe = OpSIBLING(cx->blk_oldcop);
3030                     in_block = TRUE;
3031                 } else
3032                     gotoprobe = PL_main_root;
3033                 break;
3034             case CXt_SUB:
3035                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3036                     gotoprobe = CvROOT(cx->blk_sub.cv);
3037                     break;
3038                 }
3039                 /* FALLTHROUGH */
3040             case CXt_FORMAT:
3041             case CXt_NULL:
3042                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3043             default:
3044                 if (ix)
3045                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3046                         CxTYPE(cx), (long) ix);
3047                 gotoprobe = PL_main_root;
3048                 break;
3049             }
3050             if (gotoprobe) {
3051                 OP *sibl1, *sibl2;
3052
3053                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3054                                     enterops, enterops + GOTO_DEPTH);
3055                 if (retop)
3056                     break;
3057                 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3058                      sibl1->op_type == OP_UNSTACK &&
3059                      (sibl2 = OpSIBLING(sibl1)))
3060                 {
3061                     retop = dofindlabel(sibl2,
3062                                         label, label_len, label_flags, enterops,
3063                                         enterops + GOTO_DEPTH);
3064                     if (retop)
3065                         break;
3066                 }
3067             }
3068             PL_lastgotoprobe = gotoprobe;
3069         }
3070         if (!retop)
3071             DIE(aTHX_ "Can't find label %"UTF8f, 
3072                        UTF8fARG(label_flags, label_len, label));
3073
3074         /* if we're leaving an eval, check before we pop any frames
3075            that we're not going to punt, otherwise the error
3076            won't be caught */
3077
3078         if (leaving_eval && *enterops && enterops[1]) {
3079             I32 i;
3080             for (i = 1; enterops[i]; i++)
3081                 if (enterops[i]->op_type == OP_ENTERITER)
3082                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3083         }
3084
3085         if (*enterops && enterops[1]) {
3086             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3087             if (enterops[i])
3088                 deprecate("\"goto\" to jump into a construct");
3089         }
3090
3091         /* pop unwanted frames */
3092
3093         if (ix < cxstack_ix) {
3094             I32 oldsave;
3095
3096             if (ix < 0)
3097                 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3098             dounwind(ix);
3099             TOPBLOCK(cx);
3100             oldsave = PL_scopestack[PL_scopestack_ix];
3101             LEAVE_SCOPE(oldsave);
3102         }
3103
3104         /* push wanted frames */
3105
3106         if (*enterops && enterops[1]) {
3107             OP * const oldop = PL_op;
3108             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3109             for (; enterops[ix]; ix++) {
3110                 PL_op = enterops[ix];
3111                 /* Eventually we may want to stack the needed arguments
3112                  * for each op.  For now, we punt on the hard ones. */
3113                 if (PL_op->op_type == OP_ENTERITER)
3114                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3115                 PL_op->op_ppaddr(aTHX);
3116             }
3117             PL_op = oldop;
3118         }
3119     }
3120
3121     else {
3122         assert(do_dump);
3123 #ifdef VMS
3124         if (!retop) retop = PL_main_start;
3125 #endif
3126         PL_restartop = retop;
3127         PL_do_undump = TRUE;
3128
3129         my_unexec();
3130
3131         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3132         PL_do_undump = FALSE;
3133     }
3134
3135     putback_return:
3136     PL_stack_sp = sp;
3137     _return:
3138     PERL_ASYNC_CHECK();
3139     return retop;
3140 }
3141
3142 PP(pp_exit)
3143 {
3144     dSP;
3145     I32 anum;
3146
3147     if (MAXARG < 1)
3148         anum = 0;
3149     else if (!TOPs) {
3150         anum = 0; (void)POPs;
3151     }
3152     else {
3153         anum = SvIVx(POPs);
3154 #ifdef VMS
3155         if (anum == 1
3156          && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3157             anum = 0;
3158         VMSISH_HUSHED  =
3159             VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3160 #endif
3161     }
3162     PL_exit_flags |= PERL_EXIT_EXPECTED;
3163     my_exit(anum);
3164     PUSHs(&PL_sv_undef);
3165     RETURN;
3166 }
3167
3168 /* Eval. */
3169
3170 STATIC void
3171 S_save_lines(pTHX_ AV *array, SV *sv)
3172 {
3173     const char *s = SvPVX_const(sv);
3174     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3175     I32 line = 1;
3176
3177     PERL_ARGS_ASSERT_SAVE_LINES;
3178
3179     while (s && s < send) {
3180         const char *t;
3181         SV * const tmpstr = newSV_type(SVt_PVMG);
3182
3183         t = (const char *)memchr(s, '\n', send - s);
3184         if (t)
3185             t++;
3186         else
3187             t = send;
3188
3189         sv_setpvn(tmpstr, s, t - s);
3190         av_store(array, line++, tmpstr);
3191         s = t;
3192     }
3193 }
3194
3195 /*
3196 =for apidoc docatch
3197
3198 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3199
3200 0 is used as continue inside eval,
3201
3202 3 is used for a die caught by an inner eval - continue inner loop
3203
3204 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3205 establish a local jmpenv to handle exception traps.
3206
3207 =cut
3208 */
3209 STATIC OP *
3210 S_docatch(pTHX_ OP *o)
3211 {
3212     int ret;
3213     OP * const oldop = PL_op;
3214     dJMPENV;
3215
3216 #ifdef DEBUGGING
3217     assert(CATCH_GET == TRUE);
3218 #endif
3219     PL_op = o;
3220
3221     JMPENV_PUSH(ret);
3222     switch (ret) {
3223     case 0:
3224         assert(cxstack_ix >= 0);
3225         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3226         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3227  redo_body:
3228         CALLRUNOPS(aTHX);
3229         break;
3230     case 3:
3231         /* die caught by an inner eval - continue inner loop */
3232         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3233             PL_restartjmpenv = NULL;
3234             PL_op = PL_restartop;
3235             PL_restartop = 0;
3236             goto redo_body;
3237         }
3238         /* FALLTHROUGH */
3239     default:
3240         JMPENV_POP;
3241         PL_op = oldop;
3242         JMPENV_JUMP(ret);
3243         NOT_REACHED; /* NOTREACHED */
3244     }
3245     JMPENV_POP;
3246     PL_op = oldop;
3247     return NULL;
3248 }
3249
3250
3251 /*
3252 =for apidoc find_runcv
3253
3254 Locate the CV corresponding to the currently executing sub or eval.
3255 If db_seqp is non_null, skip CVs that are in the DB package and populate
3256 *db_seqp with the cop sequence number at the point that the DB:: code was
3257 entered.  (This allows debuggers to eval in the scope of the breakpoint
3258 rather than in the scope of the debugger itself.)
3259
3260 =cut
3261 */
3262
3263 CV*
3264 Perl_find_runcv(pTHX_ U32 *db_seqp)
3265 {
3266     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3267 }
3268
3269 /* If this becomes part of the API, it might need a better name. */
3270 CV *
3271 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3272 {
3273     PERL_SI      *si;
3274     int          level = 0;
3275
3276     if (db_seqp)
3277         *db_seqp =
3278             PL_curcop == &PL_compiling
3279                 ? PL_cop_seqmax
3280                 : PL_curcop->cop_seq;
3281
3282     for (si = PL_curstackinfo; si; si = si->si_prev) {
3283         I32 ix;
3284         for (ix = si->si_cxix; ix >= 0; ix--) {
3285             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3286             CV *cv = NULL;
3287             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3288                 cv = cx->blk_sub.cv;
3289                 /* skip DB:: code */
3290                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3291                     *db_seqp = cx->blk_oldcop->cop_seq;
3292                     continue;
3293                 }
3294                 if (cx->cx_type & CXp_SUB_RE)
3295                     continue;
3296             }
3297             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3298                 cv = cx->blk_eval.cv;
3299             if (cv) {
3300                 switch (cond) {
3301                 case FIND_RUNCV_padid_eq:
3302                     if (!CvPADLIST(cv)
3303                      || CvPADLIST(cv)->xpadl_id != (U32)arg)
3304                         continue;
3305                     return cv;
3306                 case FIND_RUNCV_level_eq:
3307                     if (level++ != arg) continue;
3308                     /* GERONIMO! */
3309                 default:
3310                     return cv;
3311                 }
3312             }
3313         }
3314     }
3315     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3316 }
3317
3318
3319 /* Run yyparse() in a setjmp wrapper. Returns:
3320  *   0: yyparse() successful
3321  *   1: yyparse() failed
3322  *   3: yyparse() died
3323  */
3324 STATIC int
3325 S_try_yyparse(pTHX_ int gramtype)
3326 {
3327     int ret;
3328     dJMPENV;
3329
3330     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3331     JMPENV_PUSH(ret);
3332     switch (ret) {
3333     case 0:
3334         ret = yyparse(gramtype) ? 1 : 0;
3335         break;
3336     case 3:
3337         break;
3338     default:
3339         JMPENV_POP;
3340         JMPENV_JUMP(ret);
3341         NOT_REACHED; /* NOTREACHED */
3342     }
3343     JMPENV_POP;
3344     return ret;
3345 }
3346
3347
3348 /* Compile a require/do or an eval ''.
3349  *
3350  * outside is the lexically enclosing CV (if any) that invoked us.
3351  * seq     is the current COP scope value.
3352  * hh      is the saved hints hash, if any.
3353  *
3354  * Returns a bool indicating whether the compile was successful; if so,
3355  * PL_eval_start contains the first op of the compiled code; otherwise,
3356  * pushes undef.
3357  *
3358  * This function is called from two places: pp_require and pp_entereval.
3359  * These can be distinguished by whether PL_op is entereval.
3360  */
3361
3362 STATIC bool
3363 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3364 {
3365     dSP;
3366     OP * const saveop = PL_op;
3367     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3368     COP * const oldcurcop = PL_curcop;
3369     bool in_require = (saveop->op_type == OP_REQUIRE);
3370     int yystatus;
3371     CV *evalcv;
3372
3373     PL_in_eval = (in_require
3374                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3375                   : (EVAL_INEVAL |
3376                         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3377                             ? EVAL_RE_REPARSING : 0)));
3378
3379     PUSHMARK(SP);
3380
3381     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3382     CvEVAL_on(evalcv);
3383     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3384     cxstack[cxstack_ix].blk_eval.cv = evalcv;
3385     cxstack[cxstack_ix].blk_gimme = gimme;
3386
3387     CvOUTSIDE_SEQ(evalcv) = seq;
3388     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3389
3390     /* set up a scratch pad */
3391
3392     CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3393     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3394
3395
3396     SAVEMORTALIZESV(evalcv);    /* must remain until end of current statement */
3397
3398     /* make sure we compile in the right package */
3399
3400     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3401         SAVEGENERICSV(PL_curstash);
3402         PL_curstash = (HV *)CopSTASH(PL_curcop);
3403         if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3404         else SvREFCNT_inc_simple_void(PL_curstash);
3405     }
3406     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3407     SAVESPTR(PL_beginav);
3408     PL_beginav = newAV();
3409     SAVEFREESV(PL_beginav);
3410     SAVESPTR(PL_unitcheckav);
3411     PL_unitcheckav = newAV();
3412     SAVEFREESV(PL_unitcheckav);
3413
3414
3415     ENTER_with_name("evalcomp");
3416     SAVESPTR(PL_compcv);
3417     PL_compcv = evalcv;
3418
3419     /* try to compile it */
3420
3421     PL_eval_root = NULL;
3422     PL_curcop = &PL_compiling;
3423     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3424         PL_in_eval |= EVAL_KEEPERR;
3425     else
3426         CLEAR_ERRSV();
3427
3428     SAVEHINTS();
3429     if (clear_hints) {
3430         PL_hints = 0;
3431         hv_clear(GvHV(PL_hintgv));
3432     }
3433     else {
3434         PL_hints = saveop->op_private & OPpEVAL_COPHH
3435                      ? oldcurcop->cop_hints : saveop->op_targ;
3436
3437         /* making 'use re eval' not be in scope when compiling the
3438          * qr/mabye_has_runtime_code_block/ ensures that we don't get
3439          * infinite recursion when S_has_runtime_code() gives a false
3440          * positive: the second time round, HINT_RE_EVAL isn't set so we
3441          * don't bother calling S_has_runtime_code() */
3442         if (PL_in_eval & EVAL_RE_REPARSING)
3443             PL_hints &= ~HINT_RE_EVAL;
3444
3445         if (hh) {
3446             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3447             SvREFCNT_dec(GvHV(PL_hintgv));
3448             GvHV(PL_hintgv) = hh;
3449         }
3450     }
3451     SAVECOMPILEWARNINGS();
3452     if (clear_hints) {
3453         if (PL_dowarn & G_WARN_ALL_ON)
3454             PL_compiling.cop_warnings = pWARN_ALL ;
3455         else if (PL_dowarn & G_WARN_ALL_OFF)
3456             PL_compiling.cop_warnings = pWARN_NONE ;
3457         else
3458             PL_compiling.cop_warnings = pWARN_STD ;
3459     }
3460     else {
3461         PL_compiling.cop_warnings =
3462             DUP_WARNINGS(oldcurcop->cop_warnings);
3463         cophh_free(CopHINTHASH_get(&PL_compiling));
3464         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3465             /* The label, if present, is the first entry on the chain. So rather
3466                than writing a blank label in front of it (which involves an
3467                allocation), just use the next entry in the chain.  */
3468             PL_compiling.cop_hints_hash
3469                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3470             /* Check the assumption that this removed the label.  */
3471             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3472         }
3473         else
3474             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3475     }
3476
3477     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3478
3479     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3480      * so honour CATCH_GET and trap it here if necessary */
3481
3482     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3483
3484     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3485         SV **newsp;                     /* Used by POPBLOCK. */
3486         PERL_CONTEXT *cx;
3487         I32 optype;                     /* Used by POPEVAL. */
3488         SV *namesv;
3489         SV *errsv = NULL;
3490
3491         cx = NULL;
3492         namesv = NULL;
3493         PERL_UNUSED_VAR(newsp);
3494         PERL_UNUSED_VAR(optype);
3495
3496         /* note that if yystatus == 3, then the EVAL CX block has already
3497          * been popped, and various vars restored */
3498         PL_op = saveop;
3499         if (yystatus != 3) {
3500             if (PL_eval_root) {
3501                 op_free(PL_eval_root);
3502                 PL_eval_root = NULL;
3503             }
3504             SP = PL_stack_base + POPMARK;       /* pop original mark */
3505             POPBLOCK(cx,PL_curpm);
3506             POPEVAL(cx);
3507             namesv = cx->blk_eval.old_namesv;
3508             /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3509             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3510         }
3511
3512         errsv = ERRSV;
3513         if (in_require) {
3514             if (!cx) {
3515                 /* If cx is still NULL, it means that we didn't go in the
3516                  * POPEVAL branch. */
3517                 cx = &cxstack[cxstack_ix];
3518                 assert(CxTYPE(cx) == CXt_EVAL);
3519                 namesv = cx->blk_eval.old_namesv;
3520             }
3521             (void)hv_store(GvHVn(PL_incgv),
3522                            SvPVX_const(namesv),
3523                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3524                            &PL_sv_undef, 0);
3525             Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3526                        SVfARG(errsv
3527                                 ? errsv
3528                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3529         }
3530         else {
3531             if (!*(SvPV_nolen_const(errsv))) {
3532                 sv_setpvs(errsv, "Compilation error");
3533             }
3534         }
3535         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3536         PUTBACK;
3537         return FALSE;
3538     }
3539     else
3540         LEAVE_with_name("evalcomp");
3541
3542     CopLINE_set(&PL_compiling, 0);
3543     SAVEFREEOP(PL_eval_root);
3544     cv_forget_slab(evalcv);
3545
3546     DEBUG_x(dump_eval());
3547
3548     /* Register with debugger: */
3549     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3550         CV * const cv = get_cvs("DB::postponed", 0);
3551         if (cv) {
3552             dSP;
3553             PUSHMARK(SP);
3554             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3555             PUTBACK;
3556             call_sv(MUTABLE_SV(cv), G_DISCARD);
3557         }
3558     }
3559
3560     if (PL_unitcheckav) {
3561         OP *es = PL_eval_start;
3562         call_list(PL_scopestack_ix, PL_unitcheckav);
3563         PL_eval_start = es;
3564     }
3565
3566     /* compiled okay, so do it */
3567
3568     CvDEPTH(evalcv) = 1;
3569     SP = PL_stack_base + POPMARK;               /* pop original mark */
3570     PL_op = saveop;                     /* The caller may need it. */
3571     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3572
3573     PUTBACK;
3574     return TRUE;
3575 }
3576
3577 STATIC PerlIO *
3578 S_check_type_and_open(pTHX_ SV *name)
3579 {
3580     Stat_t st;
3581     STRLEN len;
3582     PerlIO * retio;
3583     const char *p = SvPV_const(name, len);
3584     int st_rc;
3585
3586     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3587
3588     /* checking here captures a reasonable error message when
3589      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3590      * user gets a confusing message about looking for the .pmc file
3591      * rather than for the .pm file.
3592      * This check prevents a \0 in @INC causing problems.
3593      */
3594     if (!IS_SAFE_PATHNAME(p, len, "require"))
3595         return NULL;
3596
3597     /* on Win32 stat is expensive (it does an open() and close() twice and
3598        a couple other IO calls), the open will fail with a dir on its own with
3599        errno EACCES, so only do a stat to separate a dir from a real EACCES
3600        caused by user perms */
3601 #ifndef WIN32
3602     /* we use the value of errno later to see how stat() or open() failed.
3603      * We don't want it set if the stat succeeded but we still failed,
3604      * such as if the name exists, but is a directory */
3605     errno = 0;
3606
3607     st_rc = PerlLIO_stat(p, &st);
3608
3609     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3610         return NULL;
3611     }
3612 #endif
3613
3614 #if !defined(PERLIO_IS_STDIO)
3615     retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3616 #else
3617     retio = PerlIO_open(p, PERL_SCRIPT_MODE);
3618 #endif
3619 #ifdef WIN32
3620     /* EACCES stops the INC search early in pp_require to implement
3621        feature RT #113422 */
3622     if(!retio && errno == EACCES) { /* exists but probably a directory */
3623         int eno;
3624         st_rc = PerlLIO_stat(p, &st);
3625         if (st_rc >= 0) {
3626             if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3627                 eno = 0;
3628             else
3629                 eno = EACCES;
3630             errno = eno;
3631         }
3632     }
3633 #endif
3634     return retio;
3635 }
3636
3637 #ifndef PERL_DISABLE_PMC
3638 STATIC PerlIO *
3639 S_doopen_pm(pTHX_ SV *name)
3640 {
3641     STRLEN namelen;
3642     const char *p = SvPV_const(name, namelen);
3643
3644     PERL_ARGS_ASSERT_DOOPEN_PM;
3645
3646     /* check the name before trying for the .pmc name to avoid the
3647      * warning referring to the .pmc which the user probably doesn't
3648      * know or care about
3649      */
3650     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3651         return NULL;
3652
3653     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3654         SV *const pmcsv = sv_newmortal();
3655         Stat_t pmcstat;
3656
3657         SvSetSV_nosteal(pmcsv,name);
3658         sv_catpvs(pmcsv, "c");
3659
3660         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3661             return check_type_and_open(pmcsv);
3662     }
3663     return check_type_and_open(name);
3664 }
3665 #else
3666 #  define doopen_pm(name) check_type_and_open(name)
3667 #endif /* !PERL_DISABLE_PMC */
3668
3669 /* require doesn't search for absolute names, or when the name is
3670    explicity relative the current directory */
3671 PERL_STATIC_INLINE bool
3672 S_path_is_searchable(const char *name)
3673 {
3674     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3675
3676     if (PERL_FILE_IS_ABSOLUTE(name)
3677 #ifdef WIN32
3678         || (*name == '.' && ((name[1] == '/' ||
3679                              (name[1] == '.' && name[2] == '/'))
3680                          || (name[1] == '\\' ||
3681                              ( name[1] == '.' && name[2] == '\\')))
3682             )
3683 #else
3684         || (*name == '.' && (name[1] == '/' ||
3685                              (name[1] == '.' && name[2] == '/')))
3686 #endif
3687          )
3688     {
3689         return FALSE;
3690     }
3691     else
3692         return TRUE;
3693 }
3694
3695
3696 /* also used for: pp_dofile() */
3697
3698 PP(pp_require)
3699 {
3700     dSP;
3701     PERL_CONTEXT *cx;
3702     SV *sv;
3703     const char *name;
3704     STRLEN len;
3705     char * unixname;
3706     STRLEN unixlen;
3707 #ifdef VMS
3708     int vms_unixname = 0;
3709     char *unixdir;
3710 #endif
3711     const char *tryname = NULL;
3712     SV *namesv = NULL;
3713     const I32 gimme = GIMME_V;
3714     int filter_has_file = 0;
3715     PerlIO *tryrsfp = NULL;
3716     SV *filter_cache = NULL;
3717     SV *filter_state = NULL;
3718     SV *filter_sub = NULL;
3719     SV *hook_sv = NULL;
3720     OP *op;
3721     int saved_errno;
3722     bool path_searchable;
3723
3724     sv = POPs;
3725     SvGETMAGIC(sv);
3726     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3727         sv = sv_2mortal(new_version(sv));
3728         if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3729             upg_version(PL_patchlevel, TRUE);
3730         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3731             if ( vcmp(sv,PL_patchlevel) <= 0 )
3732                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3733                     SVfARG(sv_2mortal(vnormal(sv))),
3734                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3735                 );
3736         }
3737         else {
3738             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3739                 I32 first = 0;
3740                 AV *lav;
3741                 SV * const req = SvRV(sv);
3742                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3743
3744                 /* get the left hand term */
3745                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3746
3747                 first  = SvIV(*av_fetch(lav,0,0));
3748                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3749                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3750                     || av_tindex(lav) > 1            /* FP with > 3 digits */
3751                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3752                    ) {
3753                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3754                         "%"SVf", stopped",
3755                         SVfARG(sv_2mortal(vnormal(req))),
3756                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3757                     );
3758                 }
3759                 else { /* probably 'use 5.10' or 'use 5.8' */
3760                     SV *hintsv;
3761                     I32 second = 0;
3762
3763                     if (av_tindex(lav)>=1)
3764                         second = SvIV(*av_fetch(lav,1,0));
3765
3766                     second /= second >= 600  ? 100 : 10;
3767                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3768                                            (int)first, (int)second);
3769                     upg_version(hintsv, TRUE);
3770
3771                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3772                         "--this is only %"SVf", stopped",
3773                         SVfARG(sv_2mortal(vnormal(req))),
3774                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3775                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3776                     );
3777                 }
3778             }
3779         }
3780
3781         RETPUSHYES;
3782     }
3783     if (!SvOK(sv))
3784         DIE(aTHX_ "Missing or undefined argument to require");
3785     name = SvPV_nomg_const(sv, len);
3786     if (!(name && len > 0 && *name))
3787         DIE(aTHX_ "Missing or undefined argument to require");
3788
3789     if (!IS_SAFE_PATHNAME(name, len, "require")) {
3790         DIE(aTHX_ "Can't locate %s:   %s",
3791             pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3792                       SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3793             Strerror(ENOENT));
3794     }
3795     TAINT_PROPER("require");
3796
3797     path_searchable = path_is_searchable(name);
3798
3799 #ifdef VMS
3800     /* The key in the %ENV hash is in the syntax of file passed as the argument
3801      * usually this is in UNIX format, but sometimes in VMS format, which
3802      * can result in a module being pulled in more than once.
3803      * To prevent this, the key must be stored in UNIX format if the VMS
3804      * name can be translated to UNIX.
3805      */
3806     
3807     if ((unixname =
3808           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3809          != NULL) {
3810         unixlen = strlen(unixname);
3811         vms_unixname = 1;
3812     }
3813     else
3814 #endif
3815     {
3816         /* if not VMS or VMS name can not be translated to UNIX, pass it
3817          * through.
3818          */
3819         unixname = (char *) name;
3820         unixlen = len;
3821     }
3822     if (PL_op->op_type == OP_REQUIRE) {
3823         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3824                                           unixname, unixlen, 0);
3825         if ( svp ) {
3826             if (*svp != &PL_sv_undef)
3827                 RETPUSHYES;
3828             else
3829                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3830                             "Compilation failed in require", unixname);
3831         }
3832     }
3833
3834     LOADING_FILE_PROBE(unixname);
3835
3836     /* prepare to compile file */
3837
3838     if (!path_searchable) {
3839         /* At this point, name is SvPVX(sv)  */
3840         tryname = name;
3841         tryrsfp = doopen_pm(sv);
3842     }
3843     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3844         AV * const ar = GvAVn(PL_incgv);
3845         SSize_t i;
3846 #ifdef VMS
3847         if (vms_unixname)
3848 #endif
3849         {
3850             SV *nsv = sv;
3851             namesv = newSV_type(SVt_PV);
3852             for (i = 0; i <= AvFILL(ar); i++) {
3853                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3854
3855                 SvGETMAGIC(dirsv);
3856                 if (SvROK(dirsv)) {
3857                     int count;
3858                     SV **svp;
3859                     SV *loader = dirsv;
3860
3861                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3862                         && !SvOBJECT(SvRV(loader)))
3863                     {
3864                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3865                         SvGETMAGIC(loader);
3866                     }
3867
3868                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3869                                    PTR2UV(SvRV(dirsv)), name);
3870                     tryname = SvPVX_const(namesv);
3871                     tryrsfp = NULL;
3872
3873                     if (SvPADTMP(nsv)) {
3874                         nsv = sv_newmortal();
3875                         SvSetSV_nosteal(nsv,sv);
3876                     }
3877
3878                     ENTER_with_name("call_INC");
3879                     SAVETMPS;
3880                     EXTEND(SP, 2);
3881
3882                     PUSHMARK(SP);
3883                     PUSHs(dirsv);
3884                     PUSHs(nsv);
3885                     PUTBACK;
3886                     if (SvGMAGICAL(loader)) {
3887                         SV *l = sv_newmortal();
3888                         sv_setsv_nomg(l, loader);
3889                         loader = l;
3890                     }
3891                     if (sv_isobject(loader))
3892                         count = call_method("INC", G_ARRAY);
3893                     else
3894                         count = call_sv(loader, G_ARRAY);
3895                     SPAGAIN;
3896
3897                     if (count > 0) {
3898                         int i = 0;
3899                         SV *arg;
3900
3901                         SP -= count - 1;
3902                         arg = SP[i++];
3903
3904                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3905                             && !isGV_with_GP(SvRV(arg))) {
3906                             filter_cache = SvRV(arg);
3907
3908                             if (i < count) {
3909                                 arg = SP[i++];
3910                             }
3911                         }
3912
3913                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3914                             arg = SvRV(arg);
3915                         }
3916
3917                         if (isGV_with_GP(arg)) {
3918                             IO * const io = GvIO((const GV *)arg);
3919
3920                             ++filter_has_file;
3921
3922                             if (io) {
3923                                 tryrsfp = IoIFP(io);
3924                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3925                                     PerlIO_close(IoOFP(io));
3926                                 }
3927                                 IoIFP(io) = NULL;
3928                                 IoOFP(io) = NULL;
3929                             }
3930
3931                             if (i < count) {
3932                                 arg = SP[i++];
3933                             }
3934                         }
3935
3936                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3937                             filter_sub = arg;
3938                             SvREFCNT_inc_simple_void_NN(filter_sub);
3939
3940                             if (i < count) {
3941                                 filter_state = SP[i];
3942                                 SvREFCNT_inc_simple_void(filter_state);
3943                             }
3944                         }
3945
3946                         if (!tryrsfp && (filter_cache || filter_sub)) {
3947                             tryrsfp = PerlIO_open(BIT_BUCKET,
3948                                                   PERL_SCRIPT_MODE);
3949                         }
3950                         SP--;
3951                     }
3952
3953                     /* FREETMPS may free our filter_cache */
3954                     SvREFCNT_inc_simple_void(filter_cache);
3955
3956                     PUTBACK;
3957                     FREETMPS;
3958                     LEAVE_with_name("call_INC");
3959
3960                     /* Now re-mortalize it. */
3961                     sv_2mortal(filter_cache);
3962
3963                     /* Adjust file name if the hook has set an %INC entry.
3964                        This needs to happen after the FREETMPS above.  */
3965                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3966                     if (svp)
3967                         tryname = SvPV_nolen_const(*svp);
3968
3969                     if (tryrsfp) {
3970                         hook_sv = dirsv;
3971                         break;
3972                     }
3973
3974                     filter_has_file = 0;
3975                     filter_cache = NULL;
3976                     if (filter_state) {
3977                         SvREFCNT_dec_NN(filter_state);
3978                         filter_state = NULL;
3979                     }
3980                     if (filter_sub) {
3981                         SvREFCNT_dec_NN(filter_sub);
3982                         filter_sub = NULL;
3983                     }
3984                 }
3985                 else {
3986                   if (path_searchable) {
3987                     const char *dir;
3988                     STRLEN dirlen;
3989
3990                     if (SvOK(dirsv)) {
3991                         dir = SvPV_nomg_const(dirsv, dirlen);
3992                     } else {
3993                         dir = "";
3994                         dirlen = 0;
3995                     }
3996
3997                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3998                         continue;
3999 #ifdef VMS
4000                     if ((unixdir =
4001                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4002                          == NULL)
4003                         continue;
4004                     sv_setpv(namesv, unixdir);
4005                     sv_catpv(namesv, unixname);
4006 #else
4007 #  ifdef __SYMBIAN32__
4008                     if (PL_origfilename[0] &&
4009                         PL_origfilename[1] == ':' &&
4010                         !(dir[0] && dir[1] == ':'))
4011                         Perl_sv_setpvf(aTHX_ namesv,
4012                                        "%c:%s\\%s",
4013                                        PL_origfilename[0],
4014                                        dir, name);
4015                     else
4016                         Perl_sv_setpvf(aTHX_ namesv,
4017                                        "%s\\%s",
4018                                        dir, name);
4019 #  else
4020                     /* The equivalent of                    
4021                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4022                        but without the need to parse the format string, or
4023                        call strlen on either pointer, and with the correct
4024                        allocation up front.  */
4025                     {
4026                         char *tmp = SvGROW(namesv, dirlen + len + 2);
4027
4028                         memcpy(tmp, dir, dirlen);
4029                         tmp +=dirlen;
4030
4031                         /* Avoid '<dir>//<file>' */
4032                         if (!dirlen || *(tmp-1) != '/') {
4033                             *tmp++ = '/';
4034                         } else {
4035                             /* So SvCUR_set reports the correct length below */
4036                             dirlen--;
4037                         }
4038
4039                         /* name came from an SV, so it will have a '\0' at the
4040                            end that we can copy as part of this memcpy().  */
4041                         memcpy(tmp, name, len + 1);
4042
4043                         SvCUR_set(namesv, dirlen + len + 1);
4044                         SvPOK_on(namesv);
4045                     }
4046 #  endif
4047 #endif
4048                     TAINT_PROPER("require");
4049                     tryname = SvPVX_const(namesv);
4050                     tryrsfp = doopen_pm(namesv);
4051                     if (tryrsfp) {
4052                         if (tryname[0] == '.' && tryname[1] == '/') {
4053                             ++tryname;
4054                             while (*++tryname == '/') {}
4055                         }
4056                         break;
4057                     }
4058                     else if (errno == EMFILE || errno == EACCES) {
4059                         /* no point in trying other paths if out of handles;
4060                          * on the other hand, if we couldn't open one of the
4061                          * files, then going on with the search could lead to
4062                          * unexpected results; see perl #113422
4063                          */
4064                         break;
4065                     }
4066                   }
4067                 }
4068             }
4069         }
4070     }
4071     saved_errno = errno; /* sv_2mortal can realloc things */
4072     sv_2mortal(namesv);
4073     if (!tryrsfp) {
4074         if (PL_op->op_type == OP_REQUIRE) {
4075             if(saved_errno == EMFILE || saved_errno == EACCES) {
4076                 /* diag_listed_as: Can't locate %s */
4077                 DIE(aTHX_ "Can't locate %s:   %s: %s",
4078                     name, tryname, Strerror(saved_errno));
4079             } else {
4080                 if (namesv) {                   /* did we lookup @INC? */
4081                     AV * const ar = GvAVn(PL_incgv);
4082                     SSize_t i;
4083                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
4084                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4085                     for (i = 0; i <= AvFILL(ar); i++) {
4086                         sv_catpvs(inc, " ");
4087                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4088                     }
4089                     if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4090                         const char *c, *e = name + len - 3;
4091                         sv_catpv(msg, " (you may need to install the ");
4092                         for (c = name; c < e; c++) {
4093                             if (*c == '/') {
4094                                 sv_catpvs(msg, "::");
4095                             }
4096                             else {
4097                                 sv_catpvn(msg, c, 1);
4098                             }
4099                         }
4100                         sv_catpv(msg, " module)");
4101                     }
4102                     else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4103                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4104                     }
4105                     else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4106                         sv_catpv(msg, " (did you run h2ph?)");
4107                     }
4108
4109                     /* diag_listed_as: Can't locate %s */
4110                     DIE(aTHX_
4111                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4112                         name, msg, inc);
4113                 }
4114             }
4115             DIE(aTHX_ "Can't locate %s", name);
4116         }
4117
4118         CLEAR_ERRSV();
4119         RETPUSHUNDEF;
4120     }
4121     else
4122         SETERRNO(0, SS_NORMAL);
4123
4124     /* Assume success here to prevent recursive requirement. */
4125     /* name is never assigned to again, so len is still strlen(name)  */
4126     /* Check whether a hook in @INC has already filled %INC */
4127     if (!hook_sv) {
4128         (void)hv_store(GvHVn(PL_incgv),
4129                        unixname, unixlen, newSVpv(tryname,0),0);
4130     } else {
4131         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4132         if (!svp)
4133             (void)hv_store(GvHVn(PL_incgv),
4134                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4135     }
4136
4137     ENTER_with_name("eval");
4138     SAVETMPS;
4139     SAVECOPFILE_FREE(&PL_compiling);
4140     CopFILE_set(&PL_compiling, tryname);
4141     lex_start(NULL, tryrsfp, 0);
4142
4143     if (filter_sub || filter_cache) {
4144         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4145            than hanging another SV from it. In turn, filter_add() optionally
4146            takes the SV to use as the filter (or creates a new SV if passed
4147            NULL), so simply pass in whatever value filter_cache has.  */
4148         SV * const fc = filter_cache ? newSV(0) : NULL;
4149         SV *datasv;
4150         if (fc) sv_copypv(fc, filter_cache);
4151         datasv = filter_add(S_run_user_filter, fc);
4152         IoLINES(datasv) = filter_has_file;
4153         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4154         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4155     }
4156
4157     /* switch to eval mode */
4158     PUSHBLOCK(cx, CXt_EVAL, SP);
4159     PUSHEVAL(cx, name);
4160     cx->blk_eval.retop = PL_op->op_next;
4161
4162     SAVECOPLINE(&PL_compiling);
4163     CopLINE_set(&PL_compiling, 0);
4164
4165     PUTBACK;
4166
4167     if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4168         op = DOCATCH(PL_eval_start);
4169     else
4170         op = PL_op->op_next;
4171
4172     LOADED_FILE_PROBE(unixname);
4173
4174     return op;
4175 }
4176
4177 /* This is a op added to hold the hints hash for
4178    pp_entereval. The hash can be modified by the code
4179    being eval'ed, so we return a copy instead. */
4180
4181 PP(pp_hintseval)
4182 {
4183     dSP;
4184     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4185     RETURN;
4186 }
4187
4188
4189 PP(pp_entereval)
4190 {
4191     dSP;
4192     PERL_CONTEXT *cx;
4193     SV *sv;
4194     const I32 gimme = GIMME_V;
4195     const U32 was = PL_breakable_sub_gen;
4196     char tbuf[TYPE_DIGITS(long) + 12];
4197     bool saved_delete = FALSE;
4198     char *tmpbuf = tbuf;
4199     STRLEN len;
4200     CV* runcv;
4201     U32 seq, lex_flags = 0;
4202     HV *saved_hh = NULL;
4203     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4204
4205     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4206         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4207     }
4208     else if (PL_hints & HINT_LOCALIZE_HH || (
4209                 PL_op->op_private & OPpEVAL_COPHH
4210              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4211             )) {
4212         saved_hh = cop_hints_2hv(PL_curcop, 0);
4213         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4214     }
4215     sv = POPs;
4216     if (!SvPOK(sv)) {
4217         /* make sure we've got a plain PV (no overload etc) before testing
4218          * for taint. Making a copy here is probably overkill, but better
4219          * safe than sorry */
4220         STRLEN len;
4221         const char * const p = SvPV_const(sv, len);
4222
4223         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4224         lex_flags |= LEX_START_COPIED;
4225
4226         if (bytes && SvUTF8(sv))
4227             SvPVbyte_force(sv, len);
4228     }
4229     else if (bytes && SvUTF8(sv)) {
4230         /* Don't modify someone else's scalar */
4231         STRLEN len;
4232         sv = newSVsv(sv);
4233         (void)sv_2mortal(sv);
4234         SvPVbyte_force(sv,len);
4235         lex_flags |= LEX_START_COPIED;
4236     }
4237
4238     TAINT_IF(SvTAINTED(sv));
4239     TAINT_PROPER("eval");
4240
4241     ENTER_with_name("eval");
4242     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4243                            ? LEX_IGNORE_UTF8_HINTS
4244                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4245                         )
4246              );
4247     SAVETMPS;
4248
4249     /* switch to eval mode */
4250
4251     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4252         SV * const temp_sv = sv_newmortal();
4253         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4254                        (unsigned long)++PL_evalseq,
4255                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4256         tmpbuf = SvPVX(temp_sv);
4257         len = SvCUR(temp_sv);
4258     }
4259     else
4260         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4261     SAVECOPFILE_FREE(&PL_compiling);
4262     CopFILE_set(&PL_compiling, tmpbuf+2);
4263     SAVECOPLINE(&PL_compiling);
4264     CopLINE_set(&PL_compiling, 1);
4265     /* special case: an eval '' executed within the DB package gets lexically
4266      * placed in the first non-DB CV rather than the current CV - this
4267      * allows the debugger to execute code, find lexicals etc, in the
4268      * scope of the code being debugged. Passing &seq gets find_runcv
4269      * to do the dirty work for us */
4270     runcv = find_runcv(&seq);
4271
4272     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4273     PUSHEVAL(cx, 0);
4274     cx->blk_eval.retop = PL_op->op_next;
4275
4276     /* prepare to compile string */
4277
4278     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4279         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4280     else {
4281         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4282            deleting the eval's FILEGV from the stash before gv_check() runs
4283            (i.e. before run-time proper). To work around the coredump that
4284            ensues, we always turn GvMULTI_on for any globals that were
4285            introduced within evals. See force_ident(). GSAR 96-10-12 */
4286         char *const safestr = savepvn(tmpbuf, len);
4287         SAVEDELETE(PL_defstash, safestr, len);
4288         saved_delete = TRUE;
4289     }
4290     
4291     PUTBACK;
4292
4293     if (doeval(gimme, runcv, seq, saved_hh)) {
4294         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4295             ? (PERLDB_LINE || PERLDB_SAVESRC)
4296             :  PERLDB_SAVESRC_NOSUBS) {
4297             /* Retain the filegv we created.  */
4298         } else if (!saved_delete) {
4299             char *const safestr = savepvn(tmpbuf, len);
4300             SAVEDELETE(PL_defstash, safestr, len);
4301         }
4302         return DOCATCH(PL_eval_start);
4303     } else {
4304         /* We have already left the scope set up earlier thanks to the LEAVE
4305            in doeval().  */
4306         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4307             ? (PERLDB_LINE || PERLDB_SAVESRC)
4308             :  PERLDB_SAVESRC_INVALID) {
4309             /* Retain the filegv we created.  */
4310         } else if (!saved_delete) {
4311             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4312         }
4313         return PL_op->op_next;
4314     }
4315 }
4316
4317 PP(pp_leaveeval)
4318 {
4319     dSP;
4320     SV **newsp;
4321     PMOP *newpm;
4322     I32 gimme;
4323     PERL_CONTEXT *cx;
4324     OP *retop;
4325     const U8 save_flags = PL_op -> op_flags;
4326     I32 optype;
4327     SV *namesv;
4328     CV *evalcv;
4329
4330     PERL_ASYNC_CHECK();
4331     POPBLOCK(cx,newpm);
4332     POPEVAL(cx);
4333     namesv = cx->blk_eval.old_namesv;
4334     retop = cx->blk_eval.retop;
4335     evalcv = cx->blk_eval.cv;
4336
4337     SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
4338                                 gimme, SVs_TEMP, FALSE);
4339     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4340
4341 #ifdef DEBUGGING
4342     assert(CvDEPTH(evalcv) == 1);
4343 #endif
4344     CvDEPTH(evalcv) = 0;
4345
4346     if (optype == OP_REQUIRE &&
4347         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4348     {
4349         /* Unassume the success we assumed earlier. */
4350         (void)hv_delete(GvHVn(PL_incgv),
4351                         SvPVX_const(namesv),
4352                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4353                         G_DISCARD);
4354         Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4355         NOT_REACHED; /* NOTREACHED */
4356         /* die_unwind() did LEAVE, or we won't be here */
4357     }
4358     else {
4359         LEAVE_with_name("eval");
4360         if (!(save_flags & OPf_SPECIAL)) {
4361             CLEAR_ERRSV();
4362         }
4363     }
4364
4365     RETURNOP(retop);
4366 }
4367
4368 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4369    close to the related Perl_create_eval_scope.  */
4370 void
4371 Perl_delete_eval_scope(pTHX)
4372 {
4373     SV **newsp;
4374     PMOP *newpm;
4375     I32 gimme;
4376     PERL_CONTEXT *cx;
4377     I32 optype;
4378         
4379     POPBLOCK(cx,newpm);
4380     POPEVAL(cx);
4381     PL_curpm = newpm;
4382     LEAVE_with_name("eval_scope");
4383     PERL_UNUSED_VAR(newsp);
4384     PERL_UNUSED_VAR(gimme);
4385     PERL_UNUSED_VAR(optype);
4386 }
4387
4388 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4389    also needed by Perl_fold_constants.  */
4390 PERL_CONTEXT *
4391 Perl_create_eval_scope(pTHX_ U32 flags)
4392 {
4393     PERL_CONTEXT *cx;
4394     const I32 gimme = GIMME_V;
4395         
4396     ENTER_with_name("eval_scope");
4397     SAVETMPS;
4398
4399     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4400     PUSHEVAL(cx, 0);
4401
4402     PL_in_eval = EVAL_INEVAL;
4403     if (flags & G_KEEPERR)
4404         PL_in_eval |= EVAL_KEEPERR;
4405     else
4406         CLEAR_ERRSV();
4407     if (flags & G_FAKINGEVAL) {
4408         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4409     }
4410     return cx;
4411 }
4412     
4413 PP(pp_entertry)
4414 {
4415     PERL_CONTEXT * const cx = create_eval_scope(0);
4416     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4417     return DOCATCH(PL_op->op_next);
4418 }
4419
4420 PP(pp_leavetry)
4421 {
4422     dSP;
4423     SV **newsp;
4424     PMOP *newpm;
4425     I32 gimme;
4426     PERL_CONTEXT *cx;
4427     I32 optype;
4428
4429     PERL_ASYNC_CHECK();
4430     POPBLOCK(cx,newpm);
4431     POPEVAL(cx);
4432     PERL_UNUSED_VAR(optype);
4433
4434     SP = leave_common(newsp, SP, newsp, gimme,
4435                                SVs_PADTMP|SVs_TEMP, FALSE);
4436     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4437
4438     LEAVE_with_name("eval_scope");
4439     CLEAR_ERRSV();
4440     RETURN;
4441 }
4442
4443 PP(pp_entergiven)
4444 {
4445     dSP;
4446     PERL_CONTEXT *cx;
4447     const I32 gimme = GIMME_V;
4448     
4449     ENTER_with_name("given");
4450     SAVETMPS;
4451
4452     if (PL_op->op_targ) {
4453         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4454         SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4455         PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4456     }
4457     else {
4458         SAVE_DEFSV;
4459         DEFSV_set(POPs);
4460     }
4461
4462     PUSHBLOCK(cx, CXt_GIVEN, SP);
4463     PUSHGIVEN(cx);
4464
4465     RETURN;
4466 }
4467
4468 PP(pp_leavegiven)
4469 {
4470     dSP;
4471     PERL_CONTEXT *cx;
4472     I32 gimme;
4473     SV **newsp;
4474     PMOP *newpm;
4475     PERL_UNUSED_CONTEXT;
4476
4477     POPBLOCK(cx,newpm);
4478     assert(CxTYPE(cx) == CXt_GIVEN);
4479
4480     SP = leave_common(newsp, SP, newsp, gimme,
4481                                SVs_PADTMP|SVs_TEMP, FALSE);
4482     PL_curpm = newpm;   /* Don't pop $1 et al till now&nb