This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
d69710ca1898ed6602c9fc1149b1a6bc35355210
[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 PP(pp_enteriter)
2094 {
2095     dSP; dMARK;
2096     PERL_CONTEXT *cx;
2097     const I32 gimme = GIMME_V;
2098     void *itervar; /* location of the iteration variable */
2099     U8 cxtype = CXt_LOOP_FOR;
2100
2101     ENTER_with_name("loop1");
2102     SAVETMPS;
2103
2104     if (PL_op->op_targ) {                        /* "my" variable */
2105         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2106             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2107             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2108                     SVs_PADSTALE, SVs_PADSTALE);
2109         }
2110         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2111 #ifdef USE_ITHREADS
2112         itervar = PL_comppad;
2113 #else
2114         itervar = &PAD_SVl(PL_op->op_targ);
2115 #endif
2116     }
2117     else if (LIKELY(isGV(TOPs))) {              /* symbol table variable */
2118         GV * const gv = MUTABLE_GV(POPs);
2119         SV** svp = &GvSV(gv);
2120         save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2121         *svp = newSV(0);
2122         itervar = (void *)gv;
2123         save_aliased_sv(gv);
2124     }
2125     else {
2126         SV * const sv = POPs;
2127         assert(SvTYPE(sv) == SVt_PVMG);
2128         assert(SvMAGIC(sv));
2129         assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2130         itervar = (void *)sv;
2131         cxtype |= CXp_FOR_LVREF;
2132     }
2133
2134     if (PL_op->op_private & OPpITER_DEF)
2135         cxtype |= CXp_FOR_DEF;
2136
2137     ENTER_with_name("loop2");
2138
2139     PUSHBLOCK(cx, cxtype, SP);
2140     PUSHLOOP_FOR(cx, itervar, MARK);
2141     if (PL_op->op_flags & OPf_STACKED) {
2142         SV *maybe_ary = POPs;
2143         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2144             dPOPss;
2145             SV * const right = maybe_ary;
2146             if (UNLIKELY(cxtype & CXp_FOR_LVREF))
2147                 DIE(aTHX_ "Assigned value is not a reference");
2148             SvGETMAGIC(sv);
2149             SvGETMAGIC(right);
2150             if (RANGE_IS_NUMERIC(sv,right)) {
2151                 NV nv;
2152                 cx->cx_type &= ~CXTYPEMASK;
2153                 cx->cx_type |= CXt_LOOP_LAZYIV;
2154                 /* Make sure that no-one re-orders cop.h and breaks our
2155                    assumptions */
2156                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2157 #ifdef NV_PRESERVES_UV
2158                 if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) < (NV)IV_MIN) ||
2159                                   (nv > (NV)IV_MAX)))
2160                         ||
2161                     (SvOK(right) && (((nv = SvNV_nomg(right)) > (NV)IV_MAX) ||
2162                                      (nv < (NV)IV_MIN))))
2163 #else
2164                 if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) <= (NV)IV_MIN)
2165                                   ||
2166                                   ((nv > 0) &&
2167                                         ((nv > (NV)UV_MAX) ||
2168                                          (SvUV_nomg(sv) > (UV)IV_MAX)))))
2169                         ||
2170                     (SvOK(right) && (((nv = SvNV_nomg(right)) <= (NV)IV_MIN)
2171                                      ||
2172                                      ((nv > 0) &&
2173                                         ((nv > (NV)UV_MAX) ||
2174                                          (SvUV_nomg(right) > (UV)IV_MAX))
2175                                      ))))
2176 #endif
2177                     DIE(aTHX_ "Range iterator outside integer range");
2178                 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2179                 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2180 #ifdef DEBUGGING
2181                 /* for correct -Dstv display */
2182                 cx->blk_oldsp = sp - PL_stack_base;
2183 #endif
2184             }
2185             else {
2186                 cx->cx_type &= ~CXTYPEMASK;
2187                 cx->cx_type |= CXt_LOOP_LAZYSV;
2188                 /* Make sure that no-one re-orders cop.h and breaks our
2189                    assumptions */
2190                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2191                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2192                 cx->blk_loop.state_u.lazysv.end = right;
2193                 SvREFCNT_inc(right);
2194                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2195                 /* This will do the upgrade to SVt_PV, and warn if the value
2196                    is uninitialised.  */
2197                 (void) SvPV_nolen_const(right);
2198                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2199                    to replace !SvOK() with a pointer to "".  */
2200                 if (!SvOK(right)) {
2201                     SvREFCNT_dec(right);
2202                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2203                 }
2204             }
2205         }
2206         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2207             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2208             SvREFCNT_inc(maybe_ary);
2209             cx->blk_loop.state_u.ary.ix =
2210                 (PL_op->op_private & OPpITER_REVERSED) ?
2211                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2212                 -1;
2213         }
2214     }
2215     else { /* iterating over items on the stack */
2216         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2217         if (PL_op->op_private & OPpITER_REVERSED) {
2218             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2219         }
2220         else {
2221             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2222         }
2223     }
2224
2225     RETURN;
2226 }
2227
2228 PP(pp_enterloop)
2229 {
2230     dSP;
2231     PERL_CONTEXT *cx;
2232     const I32 gimme = GIMME_V;
2233
2234     ENTER_with_name("loop1");
2235     SAVETMPS;
2236     ENTER_with_name("loop2");
2237
2238     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2239     PUSHLOOP_PLAIN(cx, SP);
2240
2241     RETURN;
2242 }
2243
2244 PP(pp_leaveloop)
2245 {
2246     dSP;
2247     PERL_CONTEXT *cx;
2248     I32 gimme;
2249     SV **newsp;
2250     PMOP *newpm;
2251     SV **mark;
2252
2253     POPBLOCK(cx,newpm);
2254     assert(CxTYPE_is_LOOP(cx));
2255     mark = newsp;
2256     newsp = PL_stack_base + cx->blk_loop.resetsp;
2257
2258     SP = leave_common(newsp, SP, MARK, gimme, 0,
2259                                PL_op->op_private & OPpLVALUE);
2260     PUTBACK;
2261
2262     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2263     PL_curpm = newpm;   /* ... and pop $1 et al */
2264
2265     LEAVE_with_name("loop2");
2266     LEAVE_with_name("loop1");
2267
2268     return NORMAL;
2269 }
2270
2271 STATIC void
2272 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2273                        PERL_CONTEXT *cx, PMOP *newpm)
2274 {
2275     const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2276     if (gimme == G_SCALAR) {
2277         if (CxLVAL(cx) && !ref) {     /* Leave it as it is if we can. */
2278             SV *sv;
2279             const char *what = NULL;
2280             if (MARK < SP) {
2281                 assert(MARK+1 == SP);
2282                 if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
2283                     !SvSMAGICAL(TOPs)) {
2284                     what =
2285                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2286                         : "a readonly value" : "a temporary";
2287                 }
2288                 else goto copy_sv;
2289             }
2290             else {
2291                 /* sub:lvalue{} will take us here. */
2292                 what = "undef";
2293             }
2294             LEAVE;
2295             cxstack_ix--;
2296             POPSUB(cx,sv);
2297             PL_curpm = newpm;
2298             LEAVESUB(sv);
2299             Perl_croak(aTHX_
2300                       "Can't return %s from lvalue subroutine", what
2301             );
2302         }
2303         if (MARK < SP) {
2304               copy_sv:
2305                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2306                     if (!SvPADTMP(*SP)) {
2307                         *++newsp = SvREFCNT_inc(*SP);
2308                         FREETMPS;
2309                         sv_2mortal(*newsp);
2310                     }
2311                     else {
2312                         /* FREETMPS could clobber it */
2313                         SV *sv = SvREFCNT_inc(*SP);
2314                         FREETMPS;
2315                         *++newsp = sv_mortalcopy(sv);
2316                         SvREFCNT_dec(sv);
2317                     }
2318                 }
2319                 else
2320                     *++newsp =
2321                       SvPADTMP(*SP)
2322                        ? sv_mortalcopy(*SP)
2323                        : !SvTEMP(*SP)
2324                           ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2325                           : *SP;
2326         }
2327         else {
2328             EXTEND(newsp,1);
2329             *++newsp = &PL_sv_undef;
2330         }
2331         if (CxLVAL(cx) & OPpDEREF) {
2332             SvGETMAGIC(TOPs);
2333             if (!SvOK(TOPs)) {
2334                 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2335             }
2336         }
2337     }
2338     else if (gimme == G_ARRAY) {
2339         assert (!(CxLVAL(cx) & OPpDEREF));
2340         if (ref || !CxLVAL(cx))
2341             while (++MARK <= SP)
2342                 *++newsp =
2343                        SvFLAGS(*MARK) & SVs_PADTMP
2344                            ? sv_mortalcopy(*MARK)
2345                      : SvTEMP(*MARK)
2346                            ? *MARK
2347                            : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2348         else while (++MARK <= SP) {
2349             if (*MARK != &PL_sv_undef
2350                     && (SvPADTMP(*MARK) || SvREADONLY(*MARK))
2351             ) {
2352                     const bool ro = cBOOL( SvREADONLY(*MARK) );
2353                     SV *sv;
2354                     /* Might be flattened array after $#array =  */
2355                     PUTBACK;
2356                     LEAVE;
2357                     cxstack_ix--;
2358                     POPSUB(cx,sv);
2359                     PL_curpm = newpm;
2360                     LEAVESUB(sv);
2361                /* diag_listed_as: Can't return %s from lvalue subroutine */
2362                     Perl_croak(aTHX_
2363                         "Can't return a %s from lvalue subroutine",
2364                          ro ? "readonly value" : "temporary");
2365             }
2366             else
2367                 *++newsp =
2368                     SvTEMP(*MARK)
2369                        ? *MARK
2370                        : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2371         }
2372     }
2373     PL_stack_sp = newsp;
2374 }
2375
2376 PP(pp_return)
2377 {
2378     dSP; dMARK;
2379     PERL_CONTEXT *cx;
2380     bool popsub2 = FALSE;
2381     bool clear_errsv = FALSE;
2382     bool lval = FALSE;
2383     I32 gimme;
2384     SV **newsp;
2385     PMOP *newpm;
2386     I32 optype = 0;
2387     SV *namesv;
2388     SV *sv;
2389     OP *retop = NULL;
2390
2391     const I32 cxix = dopoptosub(cxstack_ix);
2392
2393     if (cxix < 0) {
2394         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2395                                      * sort block, which is a CXt_NULL
2396                                      * not a CXt_SUB */
2397             dounwind(0);
2398             PL_stack_base[1] = *PL_stack_sp;
2399             PL_stack_sp = PL_stack_base + 1;
2400             return 0;
2401         }
2402         else
2403             DIE(aTHX_ "Can't return outside a subroutine");
2404     }
2405     if (cxix < cxstack_ix)
2406         dounwind(cxix);
2407
2408     if (CxMULTICALL(&cxstack[cxix])) {
2409         gimme = cxstack[cxix].blk_gimme;
2410         if (gimme == G_VOID)
2411             PL_stack_sp = PL_stack_base;
2412         else if (gimme == G_SCALAR) {
2413             PL_stack_base[1] = *PL_stack_sp;
2414             PL_stack_sp = PL_stack_base + 1;
2415         }
2416         return 0;
2417     }
2418
2419     POPBLOCK(cx,newpm);
2420     switch (CxTYPE(cx)) {
2421     case CXt_SUB:
2422         popsub2 = TRUE;
2423         lval = !!CvLVALUE(cx->blk_sub.cv);
2424         retop = cx->blk_sub.retop;
2425         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2426         break;
2427     case CXt_EVAL:
2428         if (!(PL_in_eval & EVAL_KEEPERR))
2429             clear_errsv = TRUE;
2430         POPEVAL(cx);
2431         namesv = cx->blk_eval.old_namesv;
2432         retop = cx->blk_eval.retop;
2433         if (CxTRYBLOCK(cx))
2434             break;
2435         if (optype == OP_REQUIRE &&
2436             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2437         {
2438             /* Unassume the success we assumed earlier. */
2439             (void)hv_delete(GvHVn(PL_incgv),
2440                             SvPVX_const(namesv),
2441                             SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2442                             G_DISCARD);
2443             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2444         }
2445         break;
2446     case CXt_FORMAT:
2447         retop = cx->blk_sub.retop;
2448         POPFORMAT(cx);
2449         break;
2450     default:
2451         DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2452     }
2453
2454     TAINT_NOT;
2455     if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2456     else {
2457       if (gimme == G_SCALAR) {
2458         if (MARK < SP) {
2459             if (popsub2) {
2460                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2461                     if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2462                          && !SvMAGICAL(TOPs)) {
2463                         *++newsp = SvREFCNT_inc(*SP);
2464                         FREETMPS;
2465                         sv_2mortal(*newsp);
2466                     }
2467                     else {
2468                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2469                         FREETMPS;
2470                         *++newsp = sv_mortalcopy(sv);
2471                         SvREFCNT_dec(sv);
2472                     }
2473                 }
2474                 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2475                           && !SvMAGICAL(*SP)) {
2476                     *++newsp = *SP;
2477                 }
2478                 else
2479                     *++newsp = sv_mortalcopy(*SP);
2480             }
2481             else
2482                 *++newsp = sv_mortalcopy(*SP);
2483         }
2484         else
2485             *++newsp = &PL_sv_undef;
2486       }
2487       else if (gimme == G_ARRAY) {
2488         while (++MARK <= SP) {
2489             *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2490                                && !SvGMAGICAL(*MARK)
2491                         ? *MARK : sv_mortalcopy(*MARK);
2492             TAINT_NOT;          /* Each item is independent */
2493         }
2494       }
2495       PL_stack_sp = newsp;
2496     }
2497
2498     LEAVE;
2499     /* Stack values are safe: */
2500     if (popsub2) {
2501         cxstack_ix--;
2502         POPSUB(cx,sv);  /* release CV and @_ ... */
2503     }
2504     else
2505         sv = NULL;
2506     PL_curpm = newpm;   /* ... and pop $1 et al */
2507
2508     LEAVESUB(sv);
2509     if (clear_errsv) {
2510         CLEAR_ERRSV();
2511     }
2512     return retop;
2513 }
2514
2515 /* This duplicates parts of pp_leavesub, so that it can share code with
2516  * pp_return */
2517 PP(pp_leavesublv)
2518 {
2519     dSP;
2520     SV **newsp;
2521     PMOP *newpm;
2522     I32 gimme;
2523     PERL_CONTEXT *cx;
2524     SV *sv;
2525
2526     if (CxMULTICALL(&cxstack[cxstack_ix]))
2527         return 0;
2528
2529     POPBLOCK(cx,newpm);
2530     cxstack_ix++; /* temporarily protect top context */
2531
2532     TAINT_NOT;
2533
2534     S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2535
2536     LEAVE;
2537     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2538     cxstack_ix--;
2539     PL_curpm = newpm;   /* ... and pop $1 et al */
2540
2541     LEAVESUB(sv);
2542     return cx->blk_sub.retop;
2543 }
2544
2545 static I32
2546 S_unwind_loop(pTHX_ const char * const opname)
2547 {
2548     I32 cxix;
2549     if (PL_op->op_flags & OPf_SPECIAL) {
2550         cxix = dopoptoloop(cxstack_ix);
2551         if (cxix < 0)
2552             /* diag_listed_as: Can't "last" outside a loop block */
2553             Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2554     }
2555     else {
2556         dSP;
2557         STRLEN label_len;
2558         const char * const label =
2559             PL_op->op_flags & OPf_STACKED
2560                 ? SvPV(TOPs,label_len)
2561                 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2562         const U32 label_flags =
2563             PL_op->op_flags & OPf_STACKED
2564                 ? SvUTF8(POPs)
2565                 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2566         PUTBACK;
2567         cxix = dopoptolabel(label, label_len, label_flags);
2568         if (cxix < 0)
2569             /* diag_listed_as: Label not found for "last %s" */
2570             Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2571                                        opname,
2572                                        SVfARG(PL_op->op_flags & OPf_STACKED
2573                                               && !SvGMAGICAL(TOPp1s)
2574                                               ? TOPp1s
2575                                               : newSVpvn_flags(label,
2576                                                     label_len,
2577                                                     label_flags | SVs_TEMP)));
2578     }
2579     if (cxix < cxstack_ix)
2580         dounwind(cxix);
2581     return cxix;
2582 }
2583
2584 PP(pp_last)
2585 {
2586     PERL_CONTEXT *cx;
2587     I32 pop2 = 0;
2588     I32 gimme;
2589     I32 optype;
2590     OP *nextop = NULL;
2591     SV **newsp;
2592     PMOP *newpm;
2593     SV *sv = NULL;
2594
2595     S_unwind_loop(aTHX_ "last");
2596
2597     POPBLOCK(cx,newpm);
2598     cxstack_ix++; /* temporarily protect top context */
2599     switch (CxTYPE(cx)) {
2600     case CXt_LOOP_LAZYIV:
2601     case CXt_LOOP_LAZYSV:
2602     case CXt_LOOP_FOR:
2603     case CXt_LOOP_PLAIN:
2604         pop2 = CxTYPE(cx);
2605         newsp = PL_stack_base + cx->blk_loop.resetsp;
2606         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2607         break;
2608     case CXt_SUB:
2609         pop2 = CXt_SUB;
2610         nextop = cx->blk_sub.retop;
2611         break;
2612     case CXt_EVAL:
2613         POPEVAL(cx);
2614         nextop = cx->blk_eval.retop;
2615         break;
2616     case CXt_FORMAT:
2617         POPFORMAT(cx);
2618         nextop = cx->blk_sub.retop;
2619         break;
2620     default:
2621         DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2622     }
2623
2624     TAINT_NOT;
2625     PL_stack_sp = newsp;
2626
2627     LEAVE;
2628     cxstack_ix--;
2629     /* Stack values are safe: */
2630     switch (pop2) {
2631     case CXt_LOOP_LAZYIV:
2632     case CXt_LOOP_PLAIN:
2633     case CXt_LOOP_LAZYSV:
2634     case CXt_LOOP_FOR:
2635         POPLOOP(cx);    /* release loop vars ... */
2636         LEAVE;
2637         break;
2638     case CXt_SUB:
2639         POPSUB(cx,sv);  /* release CV and @_ ... */
2640         break;
2641     }
2642     PL_curpm = newpm;   /* ... and pop $1 et al */
2643
2644     LEAVESUB(sv);
2645     PERL_UNUSED_VAR(optype);
2646     PERL_UNUSED_VAR(gimme);
2647     return nextop;
2648 }
2649
2650 PP(pp_next)
2651 {
2652     PERL_CONTEXT *cx;
2653     const I32 inner = PL_scopestack_ix;
2654
2655     S_unwind_loop(aTHX_ "next");
2656
2657     /* clear off anything above the scope we're re-entering, but
2658      * save the rest until after a possible continue block */
2659     TOPBLOCK(cx);
2660     if (PL_scopestack_ix < inner)
2661         leave_scope(PL_scopestack[PL_scopestack_ix]);
2662     PL_curcop = cx->blk_oldcop;
2663     PERL_ASYNC_CHECK();
2664     return (cx)->blk_loop.my_op->op_nextop;
2665 }
2666
2667 PP(pp_redo)
2668 {
2669     const I32 cxix = S_unwind_loop(aTHX_ "redo");
2670     PERL_CONTEXT *cx;
2671     I32 oldsave;
2672     OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2673
2674     if (redo_op->op_type == OP_ENTER) {
2675         /* pop one less context to avoid $x being freed in while (my $x..) */
2676         cxstack_ix++;
2677         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2678         redo_op = redo_op->op_next;
2679     }
2680
2681     TOPBLOCK(cx);
2682     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2683     LEAVE_SCOPE(oldsave);
2684     FREETMPS;
2685     PL_curcop = cx->blk_oldcop;
2686     PERL_ASYNC_CHECK();
2687     return redo_op;
2688 }
2689
2690 STATIC OP *
2691 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2692 {
2693     OP **ops = opstack;
2694     static const char* const too_deep = "Target of goto is too deeply nested";
2695
2696     PERL_ARGS_ASSERT_DOFINDLABEL;
2697
2698     if (ops >= oplimit)
2699         Perl_croak(aTHX_ "%s", too_deep);
2700     if (o->op_type == OP_LEAVE ||
2701         o->op_type == OP_SCOPE ||
2702         o->op_type == OP_LEAVELOOP ||
2703         o->op_type == OP_LEAVESUB ||
2704         o->op_type == OP_LEAVETRY)
2705     {
2706         *ops++ = cUNOPo->op_first;
2707         if (ops >= oplimit)
2708             Perl_croak(aTHX_ "%s", too_deep);
2709     }
2710     *ops = 0;
2711     if (o->op_flags & OPf_KIDS) {
2712         OP *kid;
2713         /* First try all the kids at this level, since that's likeliest. */
2714         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2715             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2716                 STRLEN kid_label_len;
2717                 U32 kid_label_flags;
2718                 const char *kid_label = CopLABEL_len_flags(kCOP,
2719                                                     &kid_label_len, &kid_label_flags);
2720                 if (kid_label && (
2721                     ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2722                         (flags & SVf_UTF8)
2723                             ? (bytes_cmp_utf8(
2724                                         (const U8*)kid_label, kid_label_len,
2725                                         (const U8*)label, len) == 0)
2726                             : (bytes_cmp_utf8(
2727                                         (const U8*)label, len,
2728                                         (const U8*)kid_label, kid_label_len) == 0)
2729                     : ( len == kid_label_len && ((kid_label == label)
2730                                     || memEQ(kid_label, label, len)))))
2731                     return kid;
2732             }
2733         }
2734         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2735             if (kid == PL_lastgotoprobe)
2736                 continue;
2737             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2738                 if (ops == opstack)
2739                     *ops++ = kid;
2740                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2741                          ops[-1]->op_type == OP_DBSTATE)
2742                     ops[-1] = kid;
2743                 else
2744                     *ops++ = kid;
2745             }
2746             if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2747                 return o;
2748         }
2749     }
2750     *ops = 0;
2751     return 0;
2752 }
2753
2754
2755 /* also used for: pp_dump() */
2756
2757 PP(pp_goto)
2758 {
2759     dVAR; dSP;
2760     OP *retop = NULL;
2761     I32 ix;
2762     PERL_CONTEXT *cx;
2763 #define GOTO_DEPTH 64
2764     OP *enterops[GOTO_DEPTH];
2765     const char *label = NULL;
2766     STRLEN label_len = 0;
2767     U32 label_flags = 0;
2768     const bool do_dump = (PL_op->op_type == OP_DUMP);
2769     static const char* const must_have_label = "goto must have label";
2770
2771     if (PL_op->op_flags & OPf_STACKED) {
2772         /* goto EXPR  or  goto &foo */
2773
2774         SV * const sv = POPs;
2775         SvGETMAGIC(sv);
2776
2777         /* This egregious kludge implements goto &subroutine */
2778         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2779             I32 cxix;
2780             PERL_CONTEXT *cx;
2781             CV *cv = MUTABLE_CV(SvRV(sv));
2782             AV *arg = GvAV(PL_defgv);
2783             I32 oldsave;
2784
2785         retry:
2786             if (!CvROOT(cv) && !CvXSUB(cv)) {
2787                 const GV * const gv = CvGV(cv);
2788                 if (gv) {
2789                     GV *autogv;
2790                     SV *tmpstr;
2791                     /* autoloaded stub? */
2792                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2793                         goto retry;
2794                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2795                                           GvNAMELEN(gv),
2796                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2797                     if (autogv && (cv = GvCV(autogv)))
2798                         goto retry;
2799                     tmpstr = sv_newmortal();
2800                     gv_efullname3(tmpstr, gv, NULL);
2801                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2802                 }
2803                 DIE(aTHX_ "Goto undefined subroutine");
2804             }
2805
2806             /* First do some returnish stuff. */
2807             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2808             FREETMPS;
2809             cxix = dopoptosub(cxstack_ix);
2810             if (cxix < cxstack_ix) {
2811                 if (cxix < 0) {
2812                     SvREFCNT_dec(cv);
2813                     DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2814                 }
2815                 dounwind(cxix);
2816             }
2817             TOPBLOCK(cx);
2818             SPAGAIN;
2819             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2820             if (CxTYPE(cx) == CXt_EVAL) {
2821                 SvREFCNT_dec(cv);
2822                 if (CxREALEVAL(cx))
2823                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2824                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2825                 else
2826                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2827                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2828             }
2829             else if (CxMULTICALL(cx))
2830             {
2831                 SvREFCNT_dec(cv);
2832                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2833             }
2834             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2835                 AV* av = cx->blk_sub.argarray;
2836
2837                 /* abandon the original @_ if it got reified or if it is
2838                    the same as the current @_ */
2839                 if (AvREAL(av) || av == arg) {
2840                     SvREFCNT_dec(av);
2841                     av = newAV();
2842                     AvREIFY_only(av);
2843                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2844                 }
2845                 else CLEAR_ARGARRAY(av);
2846             }
2847             /* We donate this refcount later to the callee’s pad. */
2848             SvREFCNT_inc_simple_void(arg);
2849             if (CxTYPE(cx) == CXt_SUB &&
2850                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2851                 SvREFCNT_dec(cx->blk_sub.cv);
2852             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2853             LEAVE_SCOPE(oldsave);
2854
2855             /* A destructor called during LEAVE_SCOPE could have undefined
2856              * our precious cv.  See bug #99850. */
2857             if (!CvROOT(cv) && !CvXSUB(cv)) {
2858                 const GV * const gv = CvGV(cv);
2859                 SvREFCNT_dec(arg);
2860                 if (gv) {
2861                     SV * const tmpstr = sv_newmortal();
2862                     gv_efullname3(tmpstr, gv, NULL);
2863                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2864                                SVfARG(tmpstr));
2865                 }
2866                 DIE(aTHX_ "Goto undefined subroutine");
2867             }
2868
2869             /* Now do some callish stuff. */
2870             SAVETMPS;
2871             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2872             if (CvISXSUB(cv)) {
2873                 SV **newsp;
2874                 I32 gimme;
2875                 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2876                 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2877                 SV** mark;
2878
2879                 PERL_UNUSED_VAR(newsp);
2880                 PERL_UNUSED_VAR(gimme);
2881
2882                 /* put GvAV(defgv) back onto stack */
2883                 if (items) {
2884                     EXTEND(SP, items+1); /* @_ could have been extended. */
2885                 }
2886                 mark = SP;
2887                 if (items) {
2888                     SSize_t index;
2889                     bool r = cBOOL(AvREAL(arg));
2890                     for (index=0; index<items; index++)
2891                     {
2892                         SV *sv;
2893                         if (m) {
2894                             SV ** const svp = av_fetch(arg, index, 0);
2895                             sv = svp ? *svp : NULL;
2896                         }
2897                         else sv = AvARRAY(arg)[index];
2898                         SP[index+1] = sv
2899                             ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2900                             : sv_2mortal(newSVavdefelem(arg, index, 1));
2901                     }
2902                 }
2903                 SP += items;
2904                 SvREFCNT_dec(arg);
2905                 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2906                     /* Restore old @_ */
2907                     arg = GvAV(PL_defgv);
2908                     GvAV(PL_defgv) = cx->blk_sub.savearray;
2909                     SvREFCNT_dec(arg);
2910                 }
2911
2912                 retop = cx->blk_sub.retop;
2913                 /* XS subs don't have a CxSUB, so pop it */
2914                 POPBLOCK(cx, PL_curpm);
2915                 /* Push a mark for the start of arglist */
2916                 PUSHMARK(mark);
2917                 PUTBACK;
2918                 (void)(*CvXSUB(cv))(aTHX_ cv);
2919                 LEAVE;
2920                 goto _return;
2921             }
2922             else {
2923                 PADLIST * const padlist = CvPADLIST(cv);
2924                 cx->blk_sub.cv = cv;
2925                 cx->blk_sub.olddepth = CvDEPTH(cv);
2926
2927                 CvDEPTH(cv)++;
2928                 if (CvDEPTH(cv) < 2)
2929                     SvREFCNT_inc_simple_void_NN(cv);
2930                 else {
2931                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2932                         sub_crush_depth(cv);
2933                     pad_push(padlist, CvDEPTH(cv));
2934                 }
2935                 PL_curcop = cx->blk_oldcop;
2936                 SAVECOMPPAD();
2937                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2938                 if (CxHASARGS(cx))
2939                 {
2940                     CX_CURPAD_SAVE(cx->blk_sub);
2941
2942                     /* cx->blk_sub.argarray has no reference count, so we
2943                        need something to hang on to our argument array so
2944                        that cx->blk_sub.argarray does not end up pointing
2945                        to freed memory as the result of undef *_.  So put
2946                        it in the callee’s pad, donating our refer-
2947                        ence count. */
2948                     if (arg) {
2949                         SvREFCNT_dec(PAD_SVl(0));
2950                         PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2951                     }
2952
2953                     /* GvAV(PL_defgv) might have been modified on scope
2954                        exit, so restore it. */
2955                     if (arg != GvAV(PL_defgv)) {
2956                         AV * const av = GvAV(PL_defgv);
2957                         GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2958                         SvREFCNT_dec(av);
2959                     }
2960                 }
2961                 else SvREFCNT_dec(arg);
2962                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2963                     Perl_get_db_sub(aTHX_ NULL, cv);
2964                     if (PERLDB_GOTO) {
2965                         CV * const gotocv = get_cvs("DB::goto", 0);
2966                         if (gotocv) {
2967                             PUSHMARK( PL_stack_sp );
2968                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2969                             PL_stack_sp--;
2970                         }
2971                     }
2972                 }
2973                 retop = CvSTART(cv);
2974                 goto putback_return;
2975             }
2976         }
2977         else {
2978             /* goto EXPR */
2979             label       = SvPV_nomg_const(sv, label_len);
2980             label_flags = SvUTF8(sv);
2981         }
2982     }
2983     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2984         /* goto LABEL  or  dump LABEL */
2985         label       = cPVOP->op_pv;
2986         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2987         label_len   = strlen(label);
2988     }
2989     if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2990
2991     PERL_ASYNC_CHECK();
2992
2993     if (label_len) {
2994         OP *gotoprobe = NULL;
2995         bool leaving_eval = FALSE;
2996         bool in_block = FALSE;
2997         PERL_CONTEXT *last_eval_cx = NULL;
2998
2999         /* find label */
3000
3001         PL_lastgotoprobe = NULL;
3002         *enterops = 0;
3003         for (ix = cxstack_ix; ix >= 0; ix--) {
3004             cx = &cxstack[ix];
3005             switch (CxTYPE(cx)) {
3006             case CXt_EVAL:
3007                 leaving_eval = TRUE;
3008                 if (!CxTRYBLOCK(cx)) {
3009                     gotoprobe = (last_eval_cx ?
3010                                 last_eval_cx->blk_eval.old_eval_root :
3011                                 PL_eval_root);
3012                     last_eval_cx = cx;
3013                     break;
3014                 }
3015                 /* else fall through */
3016             case CXt_LOOP_LAZYIV:
3017             case CXt_LOOP_LAZYSV:
3018             case CXt_LOOP_FOR:
3019             case CXt_LOOP_PLAIN:
3020             case CXt_GIVEN:
3021             case CXt_WHEN:
3022                 gotoprobe = OpSIBLING(cx->blk_oldcop);
3023                 break;
3024             case CXt_SUBST:
3025                 continue;
3026             case CXt_BLOCK:
3027                 if (ix) {
3028                     gotoprobe = OpSIBLING(cx->blk_oldcop);
3029                     in_block = TRUE;
3030                 } else
3031                     gotoprobe = PL_main_root;
3032                 break;
3033             case CXt_SUB:
3034                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3035                     gotoprobe = CvROOT(cx->blk_sub.cv);
3036                     break;
3037                 }
3038                 /* FALLTHROUGH */
3039             case CXt_FORMAT:
3040             case CXt_NULL:
3041                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3042             default:
3043                 if (ix)
3044                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3045                         CxTYPE(cx), (long) ix);
3046                 gotoprobe = PL_main_root;
3047                 break;
3048             }
3049             if (gotoprobe) {
3050                 OP *sibl1, *sibl2;
3051
3052                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3053                                     enterops, enterops + GOTO_DEPTH);
3054                 if (retop)
3055                     break;
3056                 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3057                      sibl1->op_type == OP_UNSTACK &&
3058                      (sibl2 = OpSIBLING(sibl1)))
3059                 {
3060                     retop = dofindlabel(sibl2,
3061                                         label, label_len, label_flags, enterops,
3062                                         enterops + GOTO_DEPTH);
3063                     if (retop)
3064                         break;
3065                 }
3066             }
3067             PL_lastgotoprobe = gotoprobe;
3068         }
3069         if (!retop)
3070             DIE(aTHX_ "Can't find label %"UTF8f, 
3071                        UTF8fARG(label_flags, label_len, label));
3072
3073         /* if we're leaving an eval, check before we pop any frames
3074            that we're not going to punt, otherwise the error
3075            won't be caught */
3076
3077         if (leaving_eval && *enterops && enterops[1]) {
3078             I32 i;
3079             for (i = 1; enterops[i]; i++)
3080                 if (enterops[i]->op_type == OP_ENTERITER)
3081                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3082         }
3083
3084         if (*enterops && enterops[1]) {
3085             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3086             if (enterops[i])
3087                 deprecate("\"goto\" to jump into a construct");
3088         }
3089
3090         /* pop unwanted frames */
3091
3092         if (ix < cxstack_ix) {
3093             I32 oldsave;
3094
3095             if (ix < 0)
3096                 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3097             dounwind(ix);
3098             TOPBLOCK(cx);
3099             oldsave = PL_scopestack[PL_scopestack_ix];
3100             LEAVE_SCOPE(oldsave);
3101         }
3102
3103         /* push wanted frames */
3104
3105         if (*enterops && enterops[1]) {
3106             OP * const oldop = PL_op;
3107             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3108             for (; enterops[ix]; ix++) {
3109                 PL_op = enterops[ix];
3110                 /* Eventually we may want to stack the needed arguments
3111                  * for each op.  For now, we punt on the hard ones. */
3112                 if (PL_op->op_type == OP_ENTERITER)
3113                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3114                 PL_op->op_ppaddr(aTHX);
3115             }
3116             PL_op = oldop;
3117         }
3118     }
3119
3120     else {
3121         assert(do_dump);
3122 #ifdef VMS
3123         if (!retop) retop = PL_main_start;
3124 #endif
3125         PL_restartop = retop;
3126         PL_do_undump = TRUE;
3127
3128         my_unexec();
3129
3130         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3131         PL_do_undump = FALSE;
3132     }
3133
3134     putback_return:
3135     PL_stack_sp = sp;
3136     _return:
3137     PERL_ASYNC_CHECK();
3138     return retop;
3139 }
3140
3141 PP(pp_exit)
3142 {
3143     dSP;
3144     I32 anum;
3145
3146     if (MAXARG < 1)
3147         anum = 0;
3148     else if (!TOPs) {
3149         anum = 0; (void)POPs;
3150     }
3151     else {
3152         anum = SvIVx(POPs);
3153 #ifdef VMS
3154         if (anum == 1
3155          && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3156             anum = 0;
3157         VMSISH_HUSHED  =
3158             VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3159 #endif
3160     }
3161     PL_exit_flags |= PERL_EXIT_EXPECTED;
3162     my_exit(anum);
3163     PUSHs(&PL_sv_undef);
3164     RETURN;
3165 }
3166
3167 /* Eval. */
3168
3169 STATIC void
3170 S_save_lines(pTHX_ AV *array, SV *sv)
3171 {
3172     const char *s = SvPVX_const(sv);
3173     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3174     I32 line = 1;
3175
3176     PERL_ARGS_ASSERT_SAVE_LINES;
3177
3178     while (s && s < send) {
3179         const char *t;
3180         SV * const tmpstr = newSV_type(SVt_PVMG);
3181
3182         t = (const char *)memchr(s, '\n', send - s);
3183         if (t)
3184             t++;
3185         else
3186             t = send;
3187
3188         sv_setpvn(tmpstr, s, t - s);
3189         av_store(array, line++, tmpstr);
3190         s = t;
3191     }
3192 }
3193
3194 /*
3195 =for apidoc docatch
3196
3197 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3198
3199 0 is used as continue inside eval,
3200
3201 3 is used for a die caught by an inner eval - continue inner loop
3202
3203 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3204 establish a local jmpenv to handle exception traps.
3205
3206 =cut
3207 */
3208 STATIC OP *
3209 S_docatch(pTHX_ OP *o)
3210 {
3211     int ret;
3212     OP * const oldop = PL_op;
3213     dJMPENV;
3214
3215 #ifdef DEBUGGING
3216     assert(CATCH_GET == TRUE);
3217 #endif
3218     PL_op = o;
3219
3220     JMPENV_PUSH(ret);
3221     switch (ret) {
3222     case 0:
3223         assert(cxstack_ix >= 0);
3224         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3225         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3226  redo_body:
3227         CALLRUNOPS(aTHX);
3228         break;
3229     case 3:
3230         /* die caught by an inner eval - continue inner loop */
3231         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3232             PL_restartjmpenv = NULL;
3233             PL_op = PL_restartop;
3234             PL_restartop = 0;
3235             goto redo_body;
3236         }
3237         /* FALLTHROUGH */
3238     default:
3239         JMPENV_POP;
3240         PL_op = oldop;
3241         JMPENV_JUMP(ret);
3242         NOT_REACHED; /* NOTREACHED */
3243     }
3244     JMPENV_POP;
3245     PL_op = oldop;
3246     return NULL;
3247 }
3248
3249
3250 /*
3251 =for apidoc find_runcv
3252
3253 Locate the CV corresponding to the currently executing sub or eval.
3254 If db_seqp is non_null, skip CVs that are in the DB package and populate
3255 *db_seqp with the cop sequence number at the point that the DB:: code was
3256 entered.  (This allows debuggers to eval in the scope of the breakpoint
3257 rather than in the scope of the debugger itself.)
3258
3259 =cut
3260 */
3261
3262 CV*
3263 Perl_find_runcv(pTHX_ U32 *db_seqp)
3264 {
3265     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3266 }
3267
3268 /* If this becomes part of the API, it might need a better name. */
3269 CV *
3270 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3271 {
3272     PERL_SI      *si;
3273     int          level = 0;
3274
3275     if (db_seqp)
3276         *db_seqp =
3277             PL_curcop == &PL_compiling
3278                 ? PL_cop_seqmax
3279                 : PL_curcop->cop_seq;
3280
3281     for (si = PL_curstackinfo; si; si = si->si_prev) {
3282         I32 ix;
3283         for (ix = si->si_cxix; ix >= 0; ix--) {
3284             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3285             CV *cv = NULL;
3286             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3287                 cv = cx->blk_sub.cv;
3288                 /* skip DB:: code */
3289                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3290                     *db_seqp = cx->blk_oldcop->cop_seq;
3291                     continue;
3292                 }
3293                 if (cx->cx_type & CXp_SUB_RE)
3294                     continue;
3295             }
3296             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3297                 cv = cx->blk_eval.cv;
3298             if (cv) {
3299                 switch (cond) {
3300                 case FIND_RUNCV_padid_eq:
3301                     if (!CvPADLIST(cv)
3302                      || CvPADLIST(cv)->xpadl_id != (U32)arg)
3303                         continue;
3304                     return cv;
3305                 case FIND_RUNCV_level_eq:
3306                     if (level++ != arg) continue;
3307                     /* GERONIMO! */
3308                 default:
3309                     return cv;
3310                 }
3311             }
3312         }
3313     }
3314     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3315 }
3316
3317
3318 /* Run yyparse() in a setjmp wrapper. Returns:
3319  *   0: yyparse() successful
3320  *   1: yyparse() failed
3321  *   3: yyparse() died
3322  */
3323 STATIC int
3324 S_try_yyparse(pTHX_ int gramtype)
3325 {
3326     int ret;
3327     dJMPENV;
3328
3329     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3330     JMPENV_PUSH(ret);
3331     switch (ret) {
3332     case 0:
3333         ret = yyparse(gramtype) ? 1 : 0;
3334         break;
3335     case 3:
3336         break;
3337     default:
3338         JMPENV_POP;
3339         JMPENV_JUMP(ret);
3340         NOT_REACHED; /* NOTREACHED */
3341     }
3342     JMPENV_POP;
3343     return ret;
3344 }
3345
3346
3347 /* Compile a require/do or an eval ''.
3348  *
3349  * outside is the lexically enclosing CV (if any) that invoked us.
3350  * seq     is the current COP scope value.
3351  * hh      is the saved hints hash, if any.
3352  *
3353  * Returns a bool indicating whether the compile was successful; if so,
3354  * PL_eval_start contains the first op of the compiled code; otherwise,
3355  * pushes undef.
3356  *
3357  * This function is called from two places: pp_require and pp_entereval.
3358  * These can be distinguished by whether PL_op is entereval.
3359  */
3360
3361 STATIC bool
3362 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3363 {
3364     dSP;
3365     OP * const saveop = PL_op;
3366     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3367     COP * const oldcurcop = PL_curcop;
3368     bool in_require = (saveop->op_type == OP_REQUIRE);
3369     int yystatus;
3370     CV *evalcv;
3371
3372     PL_in_eval = (in_require
3373                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3374                   : (EVAL_INEVAL |
3375                         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3376                             ? EVAL_RE_REPARSING : 0)));
3377
3378     PUSHMARK(SP);
3379
3380     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3381     CvEVAL_on(evalcv);
3382     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3383     cxstack[cxstack_ix].blk_eval.cv = evalcv;
3384     cxstack[cxstack_ix].blk_gimme = gimme;
3385
3386     CvOUTSIDE_SEQ(evalcv) = seq;
3387     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3388
3389     /* set up a scratch pad */
3390
3391     CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3392     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3393
3394
3395     SAVEMORTALIZESV(evalcv);    /* must remain until end of current statement */
3396
3397     /* make sure we compile in the right package */
3398
3399     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3400         SAVEGENERICSV(PL_curstash);
3401         PL_curstash = (HV *)CopSTASH(PL_curcop);
3402         if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3403         else SvREFCNT_inc_simple_void(PL_curstash);
3404     }
3405     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3406     SAVESPTR(PL_beginav);
3407     PL_beginav = newAV();
3408     SAVEFREESV(PL_beginav);
3409     SAVESPTR(PL_unitcheckav);
3410     PL_unitcheckav = newAV();
3411     SAVEFREESV(PL_unitcheckav);
3412
3413
3414     ENTER_with_name("evalcomp");
3415     SAVESPTR(PL_compcv);
3416     PL_compcv = evalcv;
3417
3418     /* try to compile it */
3419
3420     PL_eval_root = NULL;
3421     PL_curcop = &PL_compiling;
3422     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3423         PL_in_eval |= EVAL_KEEPERR;
3424     else
3425         CLEAR_ERRSV();
3426
3427     SAVEHINTS();
3428     if (clear_hints) {
3429         PL_hints = 0;
3430         hv_clear(GvHV(PL_hintgv));
3431     }
3432     else {
3433         PL_hints = saveop->op_private & OPpEVAL_COPHH
3434                      ? oldcurcop->cop_hints : saveop->op_targ;
3435
3436         /* making 'use re eval' not be in scope when compiling the
3437          * qr/mabye_has_runtime_code_block/ ensures that we don't get
3438          * infinite recursion when S_has_runtime_code() gives a false
3439          * positive: the second time round, HINT_RE_EVAL isn't set so we
3440          * don't bother calling S_has_runtime_code() */
3441         if (PL_in_eval & EVAL_RE_REPARSING)
3442             PL_hints &= ~HINT_RE_EVAL;
3443
3444         if (hh) {
3445             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3446             SvREFCNT_dec(GvHV(PL_hintgv));
3447             GvHV(PL_hintgv) = hh;
3448         }
3449     }
3450     SAVECOMPILEWARNINGS();
3451     if (clear_hints) {
3452         if (PL_dowarn & G_WARN_ALL_ON)
3453             PL_compiling.cop_warnings = pWARN_ALL ;
3454         else if (PL_dowarn & G_WARN_ALL_OFF)
3455             PL_compiling.cop_warnings = pWARN_NONE ;
3456         else
3457             PL_compiling.cop_warnings = pWARN_STD ;
3458     }
3459     else {
3460         PL_compiling.cop_warnings =
3461             DUP_WARNINGS(oldcurcop->cop_warnings);
3462         cophh_free(CopHINTHASH_get(&PL_compiling));
3463         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3464             /* The label, if present, is the first entry on the chain. So rather
3465                than writing a blank label in front of it (which involves an
3466                allocation), just use the next entry in the chain.  */
3467             PL_compiling.cop_hints_hash
3468                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3469             /* Check the assumption that this removed the label.  */
3470             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3471         }
3472         else
3473             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3474     }
3475
3476     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3477
3478     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3479      * so honour CATCH_GET and trap it here if necessary */
3480
3481     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3482
3483     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3484         SV **newsp;                     /* Used by POPBLOCK. */
3485         PERL_CONTEXT *cx;
3486         I32 optype;                     /* Used by POPEVAL. */
3487         SV *namesv;
3488         SV *errsv = NULL;
3489
3490         cx = NULL;
3491         namesv = NULL;
3492         PERL_UNUSED_VAR(newsp);
3493         PERL_UNUSED_VAR(optype);
3494
3495         /* note that if yystatus == 3, then the EVAL CX block has already
3496          * been popped, and various vars restored */
3497         PL_op = saveop;
3498         if (yystatus != 3) {
3499             if (PL_eval_root) {
3500                 op_free(PL_eval_root);
3501                 PL_eval_root = NULL;
3502             }
3503             SP = PL_stack_base + POPMARK;       /* pop original mark */
3504             POPBLOCK(cx,PL_curpm);
3505             POPEVAL(cx);
3506             namesv = cx->blk_eval.old_namesv;
3507             /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3508             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3509         }
3510
3511         errsv = ERRSV;
3512         if (in_require) {
3513             if (!cx) {
3514                 /* If cx is still NULL, it means that we didn't go in the
3515                  * POPEVAL branch. */
3516                 cx = &cxstack[cxstack_ix];
3517                 assert(CxTYPE(cx) == CXt_EVAL);
3518                 namesv = cx->blk_eval.old_namesv;
3519             }
3520             (void)hv_store(GvHVn(PL_incgv),
3521                            SvPVX_const(namesv),
3522                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3523                            &PL_sv_undef, 0);
3524             Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3525                        SVfARG(errsv
3526                                 ? errsv
3527                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3528         }
3529         else {
3530             if (!*(SvPV_nolen_const(errsv))) {
3531                 sv_setpvs(errsv, "Compilation error");
3532             }
3533         }
3534         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3535         PUTBACK;
3536         return FALSE;
3537     }
3538     else
3539         LEAVE_with_name("evalcomp");
3540
3541     CopLINE_set(&PL_compiling, 0);
3542     SAVEFREEOP(PL_eval_root);
3543     cv_forget_slab(evalcv);
3544
3545     DEBUG_x(dump_eval());
3546
3547     /* Register with debugger: */
3548     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3549         CV * const cv = get_cvs("DB::postponed", 0);
3550         if (cv) {
3551             dSP;
3552             PUSHMARK(SP);
3553             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3554             PUTBACK;
3555             call_sv(MUTABLE_SV(cv), G_DISCARD);
3556         }
3557     }
3558
3559     if (PL_unitcheckav) {
3560         OP *es = PL_eval_start;
3561         call_list(PL_scopestack_ix, PL_unitcheckav);
3562         PL_eval_start = es;
3563     }
3564
3565     /* compiled okay, so do it */
3566
3567     CvDEPTH(evalcv) = 1;
3568     SP = PL_stack_base + POPMARK;               /* pop original mark */
3569     PL_op = saveop;                     /* The caller may need it. */
3570     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3571
3572     PUTBACK;
3573     return TRUE;
3574 }
3575
3576 STATIC PerlIO *
3577 S_check_type_and_open(pTHX_ SV *name)
3578 {
3579     Stat_t st;
3580     STRLEN len;
3581     PerlIO * retio;
3582     const char *p = SvPV_const(name, len);
3583     int st_rc;
3584
3585     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3586
3587     /* checking here captures a reasonable error message when
3588      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3589      * user gets a confusing message about looking for the .pmc file
3590      * rather than for the .pm file.
3591      * This check prevents a \0 in @INC causing problems.
3592      */
3593     if (!IS_SAFE_PATHNAME(p, len, "require"))
3594         return NULL;
3595
3596     /* on Win32 stat is expensive (it does an open() and close() twice and
3597        a couple other IO calls), the open will fail with a dir on its own with
3598        errno EACCES, so only do a stat to separate a dir from a real EACCES
3599        caused by user perms */
3600 #ifndef WIN32
3601     /* we use the value of errno later to see how stat() or open() failed.
3602      * We don't want it set if the stat succeeded but we still failed,
3603      * such as if the name exists, but is a directory */
3604     errno = 0;
3605
3606     st_rc = PerlLIO_stat(p, &st);
3607
3608     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3609         return NULL;
3610     }
3611 #endif
3612
3613 #if !defined(PERLIO_IS_STDIO)
3614     retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3615 #else
3616     retio = PerlIO_open(p, PERL_SCRIPT_MODE);
3617 #endif
3618 #ifdef WIN32
3619     /* EACCES stops the INC search early in pp_require to implement
3620        feature RT #113422 */
3621     if(!retio && errno == EACCES) { /* exists but probably a directory */
3622         int eno;
3623         st_rc = PerlLIO_stat(p, &st);
3624         if (st_rc >= 0) {
3625             if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3626                 eno = 0;
3627             else
3628                 eno = EACCES;
3629             errno = eno;
3630         }
3631     }
3632 #endif
3633     return retio;
3634 }
3635
3636 #ifndef PERL_DISABLE_PMC
3637 STATIC PerlIO *
3638 S_doopen_pm(pTHX_ SV *name)
3639 {
3640     STRLEN namelen;
3641     const char *p = SvPV_const(name, namelen);
3642
3643     PERL_ARGS_ASSERT_DOOPEN_PM;
3644
3645     /* check the name before trying for the .pmc name to avoid the
3646      * warning referring to the .pmc which the user probably doesn't
3647      * know or care about
3648      */
3649     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3650         return NULL;
3651
3652     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3653         SV *const pmcsv = sv_newmortal();
3654         Stat_t pmcstat;
3655
3656         SvSetSV_nosteal(pmcsv,name);
3657         sv_catpvs(pmcsv, "c");
3658
3659         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3660             return check_type_and_open(pmcsv);
3661     }
3662     return check_type_and_open(name);
3663 }
3664 #else
3665 #  define doopen_pm(name) check_type_and_open(name)
3666 #endif /* !PERL_DISABLE_PMC */
3667
3668 /* require doesn't search for absolute names, or when the name is
3669    explicity relative the current directory */
3670 PERL_STATIC_INLINE bool
3671 S_path_is_searchable(const char *name)
3672 {
3673     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3674
3675     if (PERL_FILE_IS_ABSOLUTE(name)
3676 #ifdef WIN32
3677         || (*name == '.' && ((name[1] == '/' ||
3678                              (name[1] == '.' && name[2] == '/'))
3679                          || (name[1] == '\\' ||
3680                              ( name[1] == '.' && name[2] == '\\')))
3681             )
3682 #else
3683         || (*name == '.' && (name[1] == '/' ||
3684                              (name[1] == '.' && name[2] == '/')))
3685 #endif
3686          )
3687     {
3688         return FALSE;
3689     }
3690     else
3691         return TRUE;
3692 }
3693
3694
3695 /* also used for: pp_dofile() */
3696
3697 PP(pp_require)
3698 {
3699     dSP;
3700     PERL_CONTEXT *cx;
3701     SV *sv;
3702     const char *name;
3703     STRLEN len;
3704     char * unixname;
3705     STRLEN unixlen;
3706 #ifdef VMS
3707     int vms_unixname = 0;
3708     char *unixdir;
3709 #endif
3710     const char *tryname = NULL;
3711     SV *namesv = NULL;
3712     const I32 gimme = GIMME_V;
3713     int filter_has_file = 0;
3714     PerlIO *tryrsfp = NULL;
3715     SV *filter_cache = NULL;
3716     SV *filter_state = NULL;
3717     SV *filter_sub = NULL;
3718     SV *hook_sv = NULL;
3719     OP *op;
3720     int saved_errno;
3721     bool path_searchable;
3722
3723     sv = POPs;
3724     SvGETMAGIC(sv);
3725     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3726         sv = sv_2mortal(new_version(sv));
3727         if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3728             upg_version(PL_patchlevel, TRUE);
3729         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3730             if ( vcmp(sv,PL_patchlevel) <= 0 )
3731                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3732                     SVfARG(sv_2mortal(vnormal(sv))),
3733                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3734                 );
3735         }
3736         else {
3737             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3738                 I32 first = 0;
3739                 AV *lav;
3740                 SV * const req = SvRV(sv);
3741                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3742
3743                 /* get the left hand term */
3744                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3745
3746                 first  = SvIV(*av_fetch(lav,0,0));
3747                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3748                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3749                     || av_tindex(lav) > 1            /* FP with > 3 digits */
3750                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3751                    ) {
3752                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3753                         "%"SVf", stopped",
3754                         SVfARG(sv_2mortal(vnormal(req))),
3755                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3756                     );
3757                 }
3758                 else { /* probably 'use 5.10' or 'use 5.8' */
3759                     SV *hintsv;
3760                     I32 second = 0;
3761
3762                     if (av_tindex(lav)>=1)
3763                         second = SvIV(*av_fetch(lav,1,0));
3764
3765                     second /= second >= 600  ? 100 : 10;
3766                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3767                                            (int)first, (int)second);
3768                     upg_version(hintsv, TRUE);
3769
3770                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3771                         "--this is only %"SVf", stopped",
3772                         SVfARG(sv_2mortal(vnormal(req))),
3773                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3774                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3775                     );
3776                 }
3777             }
3778         }
3779
3780         RETPUSHYES;
3781     }
3782     if (!SvOK(sv))
3783         DIE(aTHX_ "Missing or undefined argument to require");
3784     name = SvPV_nomg_const(sv, len);
3785     if (!(name && len > 0 && *name))
3786         DIE(aTHX_ "Missing or undefined argument to require");
3787
3788     if (!IS_SAFE_PATHNAME(name, len, "require")) {
3789         DIE(aTHX_ "Can't locate %s:   %s",
3790             pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3791                       SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3792             Strerror(ENOENT));
3793     }
3794     TAINT_PROPER("require");
3795
3796     path_searchable = path_is_searchable(name);
3797
3798 #ifdef VMS
3799     /* The key in the %ENV hash is in the syntax of file passed as the argument
3800      * usually this is in UNIX format, but sometimes in VMS format, which
3801      * can result in a module being pulled in more than once.
3802      * To prevent this, the key must be stored in UNIX format if the VMS
3803      * name can be translated to UNIX.
3804      */
3805     
3806     if ((unixname =
3807           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3808          != NULL) {
3809         unixlen = strlen(unixname);
3810         vms_unixname = 1;
3811     }
3812     else
3813 #endif
3814     {
3815         /* if not VMS or VMS name can not be translated to UNIX, pass it
3816          * through.
3817          */
3818         unixname = (char *) name;
3819         unixlen = len;
3820     }
3821     if (PL_op->op_type == OP_REQUIRE) {
3822         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3823                                           unixname, unixlen, 0);
3824         if ( svp ) {
3825             if (*svp != &PL_sv_undef)
3826                 RETPUSHYES;
3827             else
3828                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3829                             "Compilation failed in require", unixname);
3830         }
3831     }
3832
3833     LOADING_FILE_PROBE(unixname);
3834
3835     /* prepare to compile file */
3836
3837     if (!path_searchable) {
3838         /* At this point, name is SvPVX(sv)  */
3839         tryname = name;
3840         tryrsfp = doopen_pm(sv);
3841     }
3842     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3843         AV * const ar = GvAVn(PL_incgv);
3844         SSize_t i;
3845 #ifdef VMS
3846         if (vms_unixname)
3847 #endif
3848         {
3849             SV *nsv = sv;
3850             namesv = newSV_type(SVt_PV);
3851             for (i = 0; i <= AvFILL(ar); i++) {
3852                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3853
3854                 SvGETMAGIC(dirsv);
3855                 if (SvROK(dirsv)) {
3856                     int count;
3857                     SV **svp;
3858                     SV *loader = dirsv;
3859
3860                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3861                         && !SvOBJECT(SvRV(loader)))
3862                     {
3863                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3864                         SvGETMAGIC(loader);
3865                     }
3866
3867                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3868                                    PTR2UV(SvRV(dirsv)), name);
3869                     tryname = SvPVX_const(namesv);
3870                     tryrsfp = NULL;
3871
3872                     if (SvPADTMP(nsv)) {
3873                         nsv = sv_newmortal();
3874                         SvSetSV_nosteal(nsv,sv);
3875                     }
3876
3877                     ENTER_with_name("call_INC");
3878                     SAVETMPS;
3879                     EXTEND(SP, 2);
3880
3881                     PUSHMARK(SP);
3882                     PUSHs(dirsv);
3883                     PUSHs(nsv);
3884                     PUTBACK;
3885                     if (SvGMAGICAL(loader)) {
3886                         SV *l = sv_newmortal();
3887                         sv_setsv_nomg(l, loader);
3888                         loader = l;
3889                     }
3890                     if (sv_isobject(loader))
3891                         count = call_method("INC", G_ARRAY);
3892                     else
3893                         count = call_sv(loader, G_ARRAY);
3894                     SPAGAIN;
3895
3896                     if (count > 0) {
3897                         int i = 0;
3898                         SV *arg;
3899
3900                         SP -= count - 1;
3901                         arg = SP[i++];
3902
3903                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3904                             && !isGV_with_GP(SvRV(arg))) {
3905                             filter_cache = SvRV(arg);
3906
3907                             if (i < count) {
3908                                 arg = SP[i++];
3909                             }
3910                         }
3911
3912                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3913                             arg = SvRV(arg);
3914                         }
3915
3916                         if (isGV_with_GP(arg)) {
3917                             IO * const io = GvIO((const GV *)arg);
3918
3919                             ++filter_has_file;
3920
3921                             if (io) {
3922                                 tryrsfp = IoIFP(io);
3923                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3924                                     PerlIO_close(IoOFP(io));
3925                                 }
3926                                 IoIFP(io) = NULL;
3927                                 IoOFP(io) = NULL;
3928                             }
3929
3930                             if (i < count) {
3931                                 arg = SP[i++];
3932                             }
3933                         }
3934
3935                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3936                             filter_sub = arg;
3937                             SvREFCNT_inc_simple_void_NN(filter_sub);
3938
3939                             if (i < count) {
3940                                 filter_state = SP[i];
3941                                 SvREFCNT_inc_simple_void(filter_state);
3942                             }
3943                         }
3944
3945                         if (!tryrsfp && (filter_cache || filter_sub)) {
3946                             tryrsfp = PerlIO_open(BIT_BUCKET,
3947                                                   PERL_SCRIPT_MODE);
3948                         }
3949                         SP--;
3950                     }
3951
3952                     /* FREETMPS may free our filter_cache */
3953                     SvREFCNT_inc_simple_void(filter_cache);
3954
3955                     PUTBACK;
3956                     FREETMPS;
3957                     LEAVE_with_name("call_INC");
3958
3959                     /* Now re-mortalize it. */
3960                     sv_2mortal(filter_cache);
3961
3962                     /* Adjust file name if the hook has set an %INC entry.
3963                        This needs to happen after the FREETMPS above.  */
3964                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3965                     if (svp)
3966                         tryname = SvPV_nolen_const(*svp);
3967
3968                     if (tryrsfp) {
3969                         hook_sv = dirsv;
3970                         break;
3971                     }
3972
3973                     filter_has_file = 0;
3974                     filter_cache = NULL;
3975                     if (filter_state) {
3976                         SvREFCNT_dec_NN(filter_state);
3977                         filter_state = NULL;
3978                     }
3979                     if (filter_sub) {
3980                         SvREFCNT_dec_NN(filter_sub);
3981                         filter_sub = NULL;
3982                     }
3983                 }
3984                 else {
3985                   if (path_searchable) {
3986                     const char *dir;
3987                     STRLEN dirlen;
3988
3989                     if (SvOK(dirsv)) {
3990                         dir = SvPV_nomg_const(dirsv, dirlen);
3991                     } else {
3992                         dir = "";
3993                         dirlen = 0;
3994                     }
3995
3996                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3997                         continue;
3998 #ifdef VMS
3999                     if ((unixdir =
4000                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4001                          == NULL)
4002                         continue;
4003                     sv_setpv(namesv, unixdir);
4004                     sv_catpv(namesv, unixname);
4005 #else
4006 #  ifdef __SYMBIAN32__
4007                     if (PL_origfilename[0] &&
4008                         PL_origfilename[1] == ':' &&
4009                         !(dir[0] && dir[1] == ':'))
4010                         Perl_sv_setpvf(aTHX_ namesv,
4011                                        "%c:%s\\%s",
4012                                        PL_origfilename[0],
4013                                        dir, name);
4014                     else
4015                         Perl_sv_setpvf(aTHX_ namesv,
4016                                        "%s\\%s",
4017                                        dir, name);
4018 #  else
4019                     /* The equivalent of                    
4020                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4021                        but without the need to parse the format string, or
4022                        call strlen on either pointer, and with the correct
4023                        allocation up front.  */
4024                     {
4025                         char *tmp = SvGROW(namesv, dirlen + len + 2);
4026
4027                         memcpy(tmp, dir, dirlen);
4028                         tmp +=dirlen;
4029
4030                         /* Avoid '<dir>//<file>' */
4031                         if (!dirlen || *(tmp-1) != '/') {
4032                             *tmp++ = '/';
4033                         } else {
4034                             /* So SvCUR_set reports the correct length below */
4035                             dirlen--;
4036                         }
4037
4038                         /* name came from an SV, so it will have a '\0' at the
4039                            end that we can copy as part of this memcpy().  */
4040                         memcpy(tmp, name, len + 1);
4041
4042                         SvCUR_set(namesv, dirlen + len + 1);
4043                         SvPOK_on(namesv);
4044                     }
4045 #  endif
4046 #endif
4047                     TAINT_PROPER("require");
4048                     tryname = SvPVX_const(namesv);
4049                     tryrsfp = doopen_pm(namesv);
4050                     if (tryrsfp) {
4051                         if (tryname[0] == '.' && tryname[1] == '/') {
4052                             ++tryname;
4053                             while (*++tryname == '/') {}
4054                         }
4055                         break;
4056                     }
4057                     else if (errno == EMFILE || errno == EACCES) {
4058                         /* no point in trying other paths if out of handles;
4059                          * on the other hand, if we couldn't open one of the
4060                          * files, then going on with the search could lead to
4061                          * unexpected results; see perl #113422
4062                          */
4063                         break;
4064                     }
4065                   }
4066                 }
4067             }
4068         }
4069     }
4070     saved_errno = errno; /* sv_2mortal can realloc things */
4071     sv_2mortal(namesv);
4072     if (!tryrsfp) {
4073         if (PL_op->op_type == OP_REQUIRE) {
4074             if(saved_errno == EMFILE || saved_errno == EACCES) {
4075                 /* diag_listed_as: Can't locate %s */
4076                 DIE(aTHX_ "Can't locate %s:   %s: %s",
4077                     name, tryname, Strerror(saved_errno));
4078             } else {
4079                 if (namesv) {                   /* did we lookup @INC? */
4080                     AV * const ar = GvAVn(PL_incgv);
4081                     SSize_t i;
4082                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
4083                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4084                     for (i = 0; i <= AvFILL(ar); i++) {
4085                         sv_catpvs(inc, " ");
4086                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4087                     }
4088                     if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4089                         const char *c, *e = name + len - 3;
4090                         sv_catpv(msg, " (you may need to install the ");
4091                         for (c = name; c < e; c++) {
4092                             if (*c == '/') {
4093                                 sv_catpvs(msg, "::");
4094                             }
4095                             else {
4096                                 sv_catpvn(msg, c, 1);
4097                             }
4098                         }
4099                         sv_catpv(msg, " module)");
4100                     }
4101                     else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4102                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4103                     }
4104                     else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4105                         sv_catpv(msg, " (did you run h2ph?)");
4106                     }
4107
4108                     /* diag_listed_as: Can't locate %s */
4109                     DIE(aTHX_
4110                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4111                         name, msg, inc);
4112                 }
4113             }
4114             DIE(aTHX_ "Can't locate %s", name);
4115         }
4116
4117         CLEAR_ERRSV();
4118         RETPUSHUNDEF;
4119     }
4120     else
4121         SETERRNO(0, SS_NORMAL);
4122
4123     /* Assume success here to prevent recursive requirement. */
4124     /* name is never assigned to again, so len is still strlen(name)  */
4125     /* Check whether a hook in @INC has already filled %INC */
4126     if (!hook_sv) {
4127         (void)hv_store(GvHVn(PL_incgv),
4128                        unixname, unixlen, newSVpv(tryname,0),0);
4129     } else {
4130         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4131         if (!svp)
4132             (void)hv_store(GvHVn(PL_incgv),
4133                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4134     }
4135
4136     ENTER_with_name("eval");
4137     SAVETMPS;
4138     SAVECOPFILE_FREE(&PL_compiling);
4139     CopFILE_set(&PL_compiling, tryname);
4140     lex_start(NULL, tryrsfp, 0);
4141
4142     if (filter_sub || filter_cache) {
4143         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4144            than hanging another SV from it. In turn, filter_add() optionally
4145            takes the SV to use as the filter (or creates a new SV if passed
4146            NULL), so simply pass in whatever value filter_cache has.  */
4147         SV * const fc = filter_cache ? newSV(0) : NULL;
4148         SV *datasv;
4149         if (fc) sv_copypv(fc, filter_cache);
4150         datasv = filter_add(S_run_user_filter, fc);
4151         IoLINES(datasv) = filter_has_file;
4152         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4153         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4154     }
4155
4156     /* switch to eval mode */
4157     PUSHBLOCK(cx, CXt_EVAL, SP);
4158     PUSHEVAL(cx, name);
4159     cx->blk_eval.retop = PL_op->op_next;
4160
4161     SAVECOPLINE(&PL_compiling);
4162     CopLINE_set(&PL_compiling, 0);
4163
4164     PUTBACK;
4165
4166     if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4167         op = DOCATCH(PL_eval_start);
4168     else
4169         op = PL_op->op_next;
4170
4171     LOADED_FILE_PROBE(unixname);
4172
4173     return op;
4174 }
4175
4176 /* This is a op added to hold the hints hash for
4177    pp_entereval. The hash can be modified by the code
4178    being eval'ed, so we return a copy instead. */
4179
4180 PP(pp_hintseval)
4181 {
4182     dSP;
4183     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4184     RETURN;
4185 }
4186
4187
4188 PP(pp_entereval)
4189 {
4190     dSP;
4191     PERL_CONTEXT *cx;
4192     SV *sv;
4193     const I32 gimme = GIMME_V;
4194     const U32 was = PL_breakable_sub_gen;
4195     char tbuf[TYPE_DIGITS(long) + 12];
4196     bool saved_delete = FALSE;
4197     char *tmpbuf = tbuf;
4198     STRLEN len;
4199     CV* runcv;
4200     U32 seq, lex_flags = 0;
4201     HV *saved_hh = NULL;
4202     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4203
4204     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4205         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4206     }
4207     else if (PL_hints & HINT_LOCALIZE_HH || (
4208                 PL_op->op_private & OPpEVAL_COPHH
4209              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4210             )) {
4211         saved_hh = cop_hints_2hv(PL_curcop, 0);
4212         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4213     }
4214     sv = POPs;
4215     if (!SvPOK(sv)) {
4216         /* make sure we've got a plain PV (no overload etc) before testing
4217          * for taint. Making a copy here is probably overkill, but better
4218          * safe than sorry */
4219         STRLEN len;
4220         const char * const p = SvPV_const(sv, len);
4221
4222         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4223         lex_flags |= LEX_START_COPIED;
4224
4225         if (bytes && SvUTF8(sv))
4226             SvPVbyte_force(sv, len);
4227     }
4228     else if (bytes && SvUTF8(sv)) {
4229         /* Don't modify someone else's scalar */
4230         STRLEN len;
4231         sv = newSVsv(sv);
4232         (void)sv_2mortal(sv);
4233         SvPVbyte_force(sv,len);
4234         lex_flags |= LEX_START_COPIED;
4235     }
4236
4237     TAINT_IF(SvTAINTED(sv));
4238     TAINT_PROPER("eval");
4239
4240     ENTER_with_name("eval");
4241     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4242                            ? LEX_IGNORE_UTF8_HINTS
4243                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4244                         )
4245              );
4246     SAVETMPS;
4247
4248     /* switch to eval mode */
4249
4250     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4251         SV * const temp_sv = sv_newmortal();
4252         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4253                        (unsigned long)++PL_evalseq,
4254                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4255         tmpbuf = SvPVX(temp_sv);
4256         len = SvCUR(temp_sv);
4257     }
4258     else
4259         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4260     SAVECOPFILE_FREE(&PL_compiling);
4261     CopFILE_set(&PL_compiling, tmpbuf+2);
4262     SAVECOPLINE(&PL_compiling);
4263     CopLINE_set(&PL_compiling, 1);
4264     /* special case: an eval '' executed within the DB package gets lexically
4265      * placed in the first non-DB CV rather than the current CV - this
4266      * allows the debugger to execute code, find lexicals etc, in the
4267      * scope of the code being debugged. Passing &seq gets find_runcv
4268      * to do the dirty work for us */
4269     runcv = find_runcv(&seq);
4270
4271     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4272     PUSHEVAL(cx, 0);
4273     cx->blk_eval.retop = PL_op->op_next;
4274
4275     /* prepare to compile string */
4276
4277     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4278         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4279     else {
4280         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4281            deleting the eval's FILEGV from the stash before gv_check() runs
4282            (i.e. before run-time proper). To work around the coredump that
4283            ensues, we always turn GvMULTI_on for any globals that were
4284            introduced within evals. See force_ident(). GSAR 96-10-12 */
4285         char *const safestr = savepvn(tmpbuf, len);
4286         SAVEDELETE(PL_defstash, safestr, len);
4287         saved_delete = TRUE;
4288     }
4289     
4290     PUTBACK;
4291
4292     if (doeval(gimme, runcv, seq, saved_hh)) {
4293         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4294             ? (PERLDB_LINE || PERLDB_SAVESRC)
4295             :  PERLDB_SAVESRC_NOSUBS) {
4296             /* Retain the filegv we created.  */
4297         } else if (!saved_delete) {
4298             char *const safestr = savepvn(tmpbuf, len);
4299             SAVEDELETE(PL_defstash, safestr, len);
4300         }
4301         return DOCATCH(PL_eval_start);
4302     } else {
4303         /* We have already left the scope set up earlier thanks to the LEAVE
4304            in doeval().  */
4305         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4306             ? (PERLDB_LINE || PERLDB_SAVESRC)
4307             :  PERLDB_SAVESRC_INVALID) {
4308             /* Retain the filegv we created.  */
4309         } else if (!saved_delete) {
4310             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4311         }
4312         return PL_op->op_next;
4313     }
4314 }
4315
4316 PP(pp_leaveeval)
4317 {
4318     dSP;
4319     SV **newsp;
4320     PMOP *newpm;
4321     I32 gimme;
4322     PERL_CONTEXT *cx;
4323     OP *retop;
4324     const U8 save_flags = PL_op -> op_flags;
4325     I32 optype;
4326     SV *namesv;
4327     CV *evalcv;
4328
4329     PERL_ASYNC_CHECK();
4330     POPBLOCK(cx,newpm);
4331     POPEVAL(cx);
4332     namesv = cx->blk_eval.old_namesv;
4333     retop = cx->blk_eval.retop;
4334     evalcv = cx->blk_eval.cv;
4335
4336     SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
4337                                 gimme, SVs_TEMP, FALSE);
4338     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4339
4340 #ifdef DEBUGGING
4341     assert(CvDEPTH(evalcv) == 1);
4342 #endif
4343     CvDEPTH(evalcv) = 0;
4344
4345     if (optype == OP_REQUIRE &&
4346         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4347     {
4348         /* Unassume the success we assumed earlier. */
4349         (void)hv_delete(GvHVn(PL_incgv),
4350                         SvPVX_const(namesv),
4351                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4352                         G_DISCARD);
4353         Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4354         NOT_REACHED; /* NOTREACHED */
4355         /* die_unwind() did LEAVE, or we won't be here */
4356     }
4357     else {
4358         LEAVE_with_name("eval");
4359         if (!(save_flags & OPf_SPECIAL)) {
4360             CLEAR_ERRSV();
4361         }
4362     }
4363
4364     RETURNOP(retop);
4365 }
4366
4367 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4368    close to the related Perl_create_eval_scope.  */
4369 void
4370 Perl_delete_eval_scope(pTHX)
4371 {
4372     SV **newsp;
4373     PMOP *newpm;
4374     I32 gimme;
4375     PERL_CONTEXT *cx;
4376     I32 optype;
4377         
4378     POPBLOCK(cx,newpm);
4379     POPEVAL(cx);
4380     PL_curpm = newpm;
4381     LEAVE_with_name("eval_scope");
4382     PERL_UNUSED_VAR(newsp);
4383     PERL_UNUSED_VAR(gimme);
4384     PERL_UNUSED_VAR(optype);
4385 }
4386
4387 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4388    also needed by Perl_fold_constants.  */
4389 PERL_CONTEXT *
4390 Perl_create_eval_scope(pTHX_ U32 flags)
4391 {
4392     PERL_CONTEXT *cx;
4393     const I32 gimme = GIMME_V;
4394         
4395     ENTER_with_name("eval_scope");
4396     SAVETMPS;
4397
4398     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4399     PUSHEVAL(cx, 0);
4400
4401     PL_in_eval = EVAL_INEVAL;
4402     if (flags & G_KEEPERR)
4403         PL_in_eval |= EVAL_KEEPERR;
4404     else
4405         CLEAR_ERRSV();
4406     if (flags & G_FAKINGEVAL) {
4407         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4408     }
4409     return cx;
4410 }
4411     
4412 PP(pp_entertry)
4413 {
4414     PERL_CONTEXT * const cx = create_eval_scope(0);
4415     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4416     return DOCATCH(PL_op->op_next);
4417 }
4418
4419 PP(pp_leavetry)
4420 {
4421     dSP;
4422     SV **newsp;
4423     PMOP *newpm;
4424     I32 gimme;
4425     PERL_CONTEXT *cx;
4426     I32 optype;
4427
4428     PERL_ASYNC_CHECK();
4429     POPBLOCK(cx,newpm);
4430     POPEVAL(cx);
4431     PERL_UNUSED_VAR(optype);
4432
4433     SP = leave_common(newsp, SP, newsp, gimme,
4434                                SVs_PADTMP|SVs_TEMP, FALSE);
4435     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4436
4437     LEAVE_with_name("eval_scope");
4438     CLEAR_ERRSV();
4439     RETURN;
4440 }
4441
4442 PP(pp_entergiven)
4443 {
4444     dSP;
4445     PERL_CONTEXT *cx;
4446     const I32 gimme = GIMME_V;
4447