Add various *BSD O_ constants.
[perl.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_private & OPpTARGET_MY)
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 I32 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             assert(0); /* 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             {
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                 if (!len)
705                     break;
706                 trans = 0;
707                 gotsome = TRUE;
708                 chophere = s + len;
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 == 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 == 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 == 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             }
1215         }
1216         else {
1217             STRLEN len, llen;
1218             const char * const lpv = SvPV_nomg_const(left, llen);
1219             const char * const tmps = SvPV_nomg_const(right, len);
1220
1221             SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1222             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1223                 XPUSHs(sv);
1224                 if (strEQ(SvPVX_const(sv),tmps))
1225                     break;
1226                 sv = sv_2mortal(newSVsv(sv));
1227                 sv_inc(sv);
1228             }
1229         }
1230     }
1231     else {
1232         dTOPss;
1233         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1234         int flop = 0;
1235         sv_inc(targ);
1236
1237         if (PL_op->op_private & OPpFLIP_LINENUM) {
1238             if (GvIO(PL_last_in_gv)) {
1239                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1240             }
1241             else {
1242                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1243                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1244             }
1245         }
1246         else {
1247             flop = SvTRUE(sv);
1248         }
1249
1250         if (flop) {
1251             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1252             sv_catpvs(targ, "E0");
1253         }
1254         SETs(targ);
1255     }
1256
1257     RETURN;
1258 }
1259
1260 /* Control. */
1261
1262 static const char * const context_name[] = {
1263     "pseudo-block",
1264     NULL, /* CXt_WHEN never actually needs "block" */
1265     NULL, /* CXt_BLOCK never actually needs "block" */
1266     NULL, /* CXt_GIVEN never actually needs "block" */
1267     NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1268     NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1269     NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1270     NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1271     "subroutine",
1272     "format",
1273     "eval",
1274     "substitution",
1275 };
1276
1277 STATIC I32
1278 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1279 {
1280     I32 i;
1281
1282     PERL_ARGS_ASSERT_DOPOPTOLABEL;
1283
1284     for (i = cxstack_ix; i >= 0; i--) {
1285         const PERL_CONTEXT * const cx = &cxstack[i];
1286         switch (CxTYPE(cx)) {
1287         case CXt_SUBST:
1288         case CXt_SUB:
1289         case CXt_FORMAT:
1290         case CXt_EVAL:
1291         case CXt_NULL:
1292             /* diag_listed_as: Exiting subroutine via %s */
1293             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1294                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1295             if (CxTYPE(cx) == CXt_NULL)
1296                 return -1;
1297             break;
1298         case CXt_LOOP_LAZYIV:
1299         case CXt_LOOP_LAZYSV:
1300         case CXt_LOOP_FOR:
1301         case CXt_LOOP_PLAIN:
1302           {
1303             STRLEN cx_label_len = 0;
1304             U32 cx_label_flags = 0;
1305             const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1306             if (!cx_label || !(
1307                     ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1308                         (flags & SVf_UTF8)
1309                             ? (bytes_cmp_utf8(
1310                                         (const U8*)cx_label, cx_label_len,
1311                                         (const U8*)label, len) == 0)
1312                             : (bytes_cmp_utf8(
1313                                         (const U8*)label, len,
1314                                         (const U8*)cx_label, cx_label_len) == 0)
1315                     : (len == cx_label_len && ((cx_label == label)
1316                                     || memEQ(cx_label, label, len))) )) {
1317                 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1318                         (long)i, cx_label));
1319                 continue;
1320             }
1321             DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1322             return i;
1323           }
1324         }
1325     }
1326     return i;
1327 }
1328
1329
1330
1331 I32
1332 Perl_dowantarray(pTHX)
1333 {
1334     const I32 gimme = block_gimme();
1335     return (gimme == G_VOID) ? G_SCALAR : gimme;
1336 }
1337
1338 I32
1339 Perl_block_gimme(pTHX)
1340 {
1341     const I32 cxix = dopoptosub(cxstack_ix);
1342     if (cxix < 0)
1343         return G_VOID;
1344
1345     switch (cxstack[cxix].blk_gimme) {
1346     case G_VOID:
1347         return G_VOID;
1348     case G_SCALAR:
1349         return G_SCALAR;
1350     case G_ARRAY:
1351         return G_ARRAY;
1352     default:
1353         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1354     }
1355     NOT_REACHED; /* NOTREACHED */
1356 }
1357
1358 I32
1359 Perl_is_lvalue_sub(pTHX)
1360 {
1361     const I32 cxix = dopoptosub(cxstack_ix);
1362     assert(cxix >= 0);  /* We should only be called from inside subs */
1363
1364     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1365         return CxLVAL(cxstack + cxix);
1366     else
1367         return 0;
1368 }
1369
1370 /* only used by PUSHSUB */
1371 I32
1372 Perl_was_lvalue_sub(pTHX)
1373 {
1374     const I32 cxix = dopoptosub(cxstack_ix-1);
1375     assert(cxix >= 0);  /* We should only be called from inside subs */
1376
1377     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1378         return CxLVAL(cxstack + cxix);
1379     else
1380         return 0;
1381 }
1382
1383 STATIC I32
1384 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1385 {
1386     I32 i;
1387
1388     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1389 #ifndef DEBUGGING
1390     PERL_UNUSED_CONTEXT;
1391 #endif
1392
1393     for (i = startingblock; i >= 0; i--) {
1394         const PERL_CONTEXT * const cx = &cxstk[i];
1395         switch (CxTYPE(cx)) {
1396         default:
1397             continue;
1398         case CXt_SUB:
1399             /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1400              * twice; the first for the normal foo() call, and the second
1401              * for a faked up re-entry into the sub to execute the
1402              * code block. Hide this faked entry from the world. */
1403             if (cx->cx_type & CXp_SUB_RE_FAKE)
1404                 continue;
1405             /* FALLTHROUGH */
1406         case CXt_EVAL:
1407         case CXt_FORMAT:
1408             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1409             return i;
1410         }
1411     }
1412     return i;
1413 }
1414
1415 STATIC I32
1416 S_dopoptoeval(pTHX_ I32 startingblock)
1417 {
1418     I32 i;
1419     for (i = startingblock; i >= 0; i--) {
1420         const PERL_CONTEXT *cx = &cxstack[i];
1421         switch (CxTYPE(cx)) {
1422         default:
1423             continue;
1424         case CXt_EVAL:
1425             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1426             return i;
1427         }
1428     }
1429     return i;
1430 }
1431
1432 STATIC I32
1433 S_dopoptoloop(pTHX_ I32 startingblock)
1434 {
1435     I32 i;
1436     for (i = startingblock; i >= 0; i--) {
1437         const PERL_CONTEXT * const cx = &cxstack[i];
1438         switch (CxTYPE(cx)) {
1439         case CXt_SUBST:
1440         case CXt_SUB:
1441         case CXt_FORMAT:
1442         case CXt_EVAL:
1443         case CXt_NULL:
1444             /* diag_listed_as: Exiting subroutine via %s */
1445             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1446                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1447             if ((CxTYPE(cx)) == CXt_NULL)
1448                 return -1;
1449             break;
1450         case CXt_LOOP_LAZYIV:
1451         case CXt_LOOP_LAZYSV:
1452         case CXt_LOOP_FOR:
1453         case CXt_LOOP_PLAIN:
1454             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1455             return i;
1456         }
1457     }
1458     return i;
1459 }
1460
1461 STATIC I32
1462 S_dopoptogiven(pTHX_ I32 startingblock)
1463 {
1464     I32 i;
1465     for (i = startingblock; i >= 0; i--) {
1466         const PERL_CONTEXT *cx = &cxstack[i];
1467         switch (CxTYPE(cx)) {
1468         default:
1469             continue;
1470         case CXt_GIVEN:
1471             DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1472             return i;
1473         case CXt_LOOP_PLAIN:
1474             assert(!CxFOREACHDEF(cx));
1475             break;
1476         case CXt_LOOP_LAZYIV:
1477         case CXt_LOOP_LAZYSV:
1478         case CXt_LOOP_FOR:
1479             if (CxFOREACHDEF(cx)) {
1480                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1481                 return i;
1482             }
1483         }
1484     }
1485     return i;
1486 }
1487
1488 STATIC I32
1489 S_dopoptowhen(pTHX_ I32 startingblock)
1490 {
1491     I32 i;
1492     for (i = startingblock; i >= 0; i--) {
1493         const PERL_CONTEXT *cx = &cxstack[i];
1494         switch (CxTYPE(cx)) {
1495         default:
1496             continue;
1497         case CXt_WHEN:
1498             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1499             return i;
1500         }
1501     }
1502     return i;
1503 }
1504
1505 void
1506 Perl_dounwind(pTHX_ I32 cxix)
1507 {
1508     I32 optype;
1509
1510     if (!PL_curstackinfo) /* can happen if die during thread cloning */
1511         return;
1512
1513     while (cxstack_ix > cxix) {
1514         SV *sv;
1515         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1516         DEBUG_CX("UNWIND");                                             \
1517         /* Note: we don't need to restore the base context info till the end. */
1518         switch (CxTYPE(cx)) {
1519         case CXt_SUBST:
1520             POPSUBST(cx);
1521             continue;  /* not break */
1522         case CXt_SUB:
1523             POPSUB(cx,sv);
1524             LEAVESUB(sv);
1525             break;
1526         case CXt_EVAL:
1527             POPEVAL(cx);
1528             break;
1529         case CXt_LOOP_LAZYIV:
1530         case CXt_LOOP_LAZYSV:
1531         case CXt_LOOP_FOR:
1532         case CXt_LOOP_PLAIN:
1533             POPLOOP(cx);
1534             break;
1535         case CXt_NULL:
1536             break;
1537         case CXt_FORMAT:
1538             POPFORMAT(cx);
1539             break;
1540         }
1541         cxstack_ix--;
1542     }
1543     PERL_UNUSED_VAR(optype);
1544 }
1545
1546 void
1547 Perl_qerror(pTHX_ SV *err)
1548 {
1549     PERL_ARGS_ASSERT_QERROR;
1550
1551     if (PL_in_eval) {
1552         if (PL_in_eval & EVAL_KEEPERR) {
1553                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1554                                                     SVfARG(err));
1555         }
1556         else
1557             sv_catsv(ERRSV, err);
1558     }
1559     else if (PL_errors)
1560         sv_catsv(PL_errors, err);
1561     else
1562         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1563     if (PL_parser)
1564         ++PL_parser->error_count;
1565 }
1566
1567 void
1568 Perl_die_unwind(pTHX_ SV *msv)
1569 {
1570     SV *exceptsv = sv_mortalcopy(msv);
1571     U8 in_eval = PL_in_eval;
1572     PERL_ARGS_ASSERT_DIE_UNWIND;
1573
1574     if (in_eval) {
1575         I32 cxix;
1576         I32 gimme;
1577
1578         /*
1579          * Historically, perl used to set ERRSV ($@) early in the die
1580          * process and rely on it not getting clobbered during unwinding.
1581          * That sucked, because it was liable to get clobbered, so the
1582          * setting of ERRSV used to emit the exception from eval{} has
1583          * been moved to much later, after unwinding (see just before
1584          * JMPENV_JUMP below).  However, some modules were relying on the
1585          * early setting, by examining $@ during unwinding to use it as
1586          * a flag indicating whether the current unwinding was caused by
1587          * an exception.  It was never a reliable flag for that purpose,
1588          * being totally open to false positives even without actual
1589          * clobberage, but was useful enough for production code to
1590          * semantically rely on it.
1591          *
1592          * We'd like to have a proper introspective interface that
1593          * explicitly describes the reason for whatever unwinding
1594          * operations are currently in progress, so that those modules
1595          * work reliably and $@ isn't further overloaded.  But we don't
1596          * have one yet.  In its absence, as a stopgap measure, ERRSV is
1597          * now *additionally* set here, before unwinding, to serve as the
1598          * (unreliable) flag that it used to.
1599          *
1600          * This behaviour is temporary, and should be removed when a
1601          * proper way to detect exceptional unwinding has been developed.
1602          * As of 2010-12, the authors of modules relying on the hack
1603          * are aware of the issue, because the modules failed on
1604          * perls 5.13.{1..7} which had late setting of $@ without this
1605          * early-setting hack.
1606          */
1607         if (!(in_eval & EVAL_KEEPERR)) {
1608             SvTEMP_off(exceptsv);
1609             sv_setsv(ERRSV, exceptsv);
1610         }
1611
1612         if (in_eval & EVAL_KEEPERR) {
1613             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1614                            SVfARG(exceptsv));
1615         }
1616
1617         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1618                && PL_curstackinfo->si_prev)
1619         {
1620             dounwind(-1);
1621             POPSTACK;
1622         }
1623
1624         if (cxix >= 0) {
1625             I32 optype;
1626             SV *namesv;
1627             PERL_CONTEXT *cx;
1628             SV **newsp;
1629 #ifdef DEBUGGING
1630             COP *oldcop;
1631 #endif
1632             JMPENV *restartjmpenv;
1633             OP *restartop;
1634
1635             if (cxix < cxstack_ix)
1636                 dounwind(cxix);
1637
1638             POPBLOCK(cx,PL_curpm);
1639             if (CxTYPE(cx) != CXt_EVAL) {
1640                 STRLEN msglen;
1641                 const char* message = SvPVx_const(exceptsv, msglen);
1642                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1643                 PerlIO_write(Perl_error_log, message, msglen);
1644                 my_exit(1);
1645             }
1646             POPEVAL(cx);
1647             namesv = cx->blk_eval.old_namesv;
1648 #ifdef DEBUGGING
1649             oldcop = cx->blk_oldcop;
1650 #endif
1651             restartjmpenv = cx->blk_eval.cur_top_env;
1652             restartop = cx->blk_eval.retop;
1653
1654             if (gimme == G_SCALAR)
1655                 *++newsp = &PL_sv_undef;
1656             PL_stack_sp = newsp;
1657
1658             LEAVE;
1659
1660             if (optype == OP_REQUIRE) {
1661                 assert (PL_curcop == oldcop);
1662                 (void)hv_store(GvHVn(PL_incgv),
1663                                SvPVX_const(namesv),
1664                                SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1665                                &PL_sv_undef, 0);
1666                 /* note that unlike pp_entereval, pp_require isn't
1667                  * supposed to trap errors. So now that we've popped the
1668                  * EVAL that pp_require pushed, and processed the error
1669                  * message, rethrow the error */
1670                 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1671                            SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1672                                                                     SVs_TEMP)));
1673             }
1674             if (!(in_eval & EVAL_KEEPERR))
1675                 sv_setsv(ERRSV, exceptsv);
1676             PL_restartjmpenv = restartjmpenv;
1677             PL_restartop = restartop;
1678             JMPENV_JUMP(3);
1679             assert(0); /* NOTREACHED */
1680         }
1681     }
1682
1683     write_to_stderr(exceptsv);
1684     my_failure_exit();
1685     assert(0); /* NOTREACHED */
1686 }
1687
1688 PP(pp_xor)
1689 {
1690     dSP; dPOPTOPssrl;
1691     if (SvTRUE(left) != SvTRUE(right))
1692         RETSETYES;
1693     else
1694         RETSETNO;
1695 }
1696
1697 /*
1698
1699 =head1 CV Manipulation Functions
1700
1701 =for apidoc caller_cx
1702
1703 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>.  The
1704 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1705 information returned to Perl by C<caller>.  Note that XSUBs don't get a
1706 stack frame, so C<caller_cx(0, NULL)> will return information for the
1707 immediately-surrounding Perl code.
1708
1709 This function skips over the automatic calls to C<&DB::sub> made on the
1710 behalf of the debugger.  If the stack frame requested was a sub called by
1711 C<DB::sub>, the return value will be the frame for the call to
1712 C<DB::sub>, since that has the correct line number/etc. for the call
1713 site.  If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1714 frame for the sub call itself.
1715
1716 =cut
1717 */
1718
1719 const PERL_CONTEXT *
1720 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1721 {
1722     I32 cxix = dopoptosub(cxstack_ix);
1723     const PERL_CONTEXT *cx;
1724     const PERL_CONTEXT *ccstack = cxstack;
1725     const PERL_SI *top_si = PL_curstackinfo;
1726
1727     for (;;) {
1728         /* we may be in a higher stacklevel, so dig down deeper */
1729         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1730             top_si = top_si->si_prev;
1731             ccstack = top_si->si_cxstack;
1732             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1733         }
1734         if (cxix < 0)
1735             return NULL;
1736         /* caller() should not report the automatic calls to &DB::sub */
1737         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1738                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1739             count++;
1740         if (!count--)
1741             break;
1742         cxix = dopoptosub_at(ccstack, cxix - 1);
1743     }
1744
1745     cx = &ccstack[cxix];
1746     if (dbcxp) *dbcxp = cx;
1747
1748     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1749         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1750         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1751            field below is defined for any cx. */
1752         /* caller() should not report the automatic calls to &DB::sub */
1753         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1754             cx = &ccstack[dbcxix];
1755     }
1756
1757     return cx;
1758 }
1759
1760 PP(pp_caller)
1761 {
1762     dSP;
1763     const PERL_CONTEXT *cx;
1764     const PERL_CONTEXT *dbcx;
1765     I32 gimme;
1766     const HEK *stash_hek;
1767     I32 count = 0;
1768     bool has_arg = MAXARG && TOPs;
1769     const COP *lcop;
1770
1771     if (MAXARG) {
1772       if (has_arg)
1773         count = POPi;
1774       else (void)POPs;
1775     }
1776
1777     cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1778     if (!cx) {
1779         if (GIMME != G_ARRAY) {
1780             EXTEND(SP, 1);
1781             RETPUSHUNDEF;
1782         }
1783         RETURN;
1784     }
1785
1786     DEBUG_CX("CALLER");
1787     assert(CopSTASH(cx->blk_oldcop));
1788     stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1789       ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1790       : NULL;
1791     if (GIMME != G_ARRAY) {
1792         EXTEND(SP, 1);
1793         if (!stash_hek)
1794             PUSHs(&PL_sv_undef);
1795         else {
1796             dTARGET;
1797             sv_sethek(TARG, stash_hek);
1798             PUSHs(TARG);
1799         }
1800         RETURN;
1801     }
1802
1803     EXTEND(SP, 11);
1804
1805     if (!stash_hek)
1806         PUSHs(&PL_sv_undef);
1807     else {
1808         dTARGET;
1809         sv_sethek(TARG, stash_hek);
1810         PUSHTARG;
1811     }
1812     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1813     lcop = closest_cop(cx->blk_oldcop, OP_SIBLING(cx->blk_oldcop),
1814                        cx->blk_sub.retop, TRUE);
1815     if (!lcop)
1816         lcop = cx->blk_oldcop;
1817     mPUSHi((I32)CopLINE(lcop));
1818     if (!has_arg)
1819         RETURN;
1820     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1821         /* So is ccstack[dbcxix]. */
1822         if (CvHASGV(dbcx->blk_sub.cv)) {
1823             PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1824             PUSHs(boolSV(CxHASARGS(cx)));
1825         }
1826         else {
1827             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1828             PUSHs(boolSV(CxHASARGS(cx)));
1829         }
1830     }
1831     else {
1832         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1833         mPUSHi(0);
1834     }
1835     gimme = (I32)cx->blk_gimme;
1836     if (gimme == G_VOID)
1837         PUSHs(&PL_sv_undef);
1838     else
1839         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1840     if (CxTYPE(cx) == CXt_EVAL) {
1841         /* eval STRING */
1842         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1843             SV *cur_text = cx->blk_eval.cur_text;
1844             if (SvCUR(cur_text) >= 2) {
1845                 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1846                                      SvUTF8(cur_text)|SVs_TEMP));
1847             }
1848             else {
1849                 /* I think this is will always be "", but be sure */
1850                 PUSHs(sv_2mortal(newSVsv(cur_text)));
1851             }
1852
1853             PUSHs(&PL_sv_no);
1854         }
1855         /* require */
1856         else if (cx->blk_eval.old_namesv) {
1857             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1858             PUSHs(&PL_sv_yes);
1859         }
1860         /* eval BLOCK (try blocks have old_namesv == 0) */
1861         else {
1862             PUSHs(&PL_sv_undef);
1863             PUSHs(&PL_sv_undef);
1864         }
1865     }
1866     else {
1867         PUSHs(&PL_sv_undef);
1868         PUSHs(&PL_sv_undef);
1869     }
1870     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1871         && CopSTASH_eq(PL_curcop, PL_debstash))
1872     {
1873         AV * const ary = cx->blk_sub.argarray;
1874         const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1875
1876         Perl_init_dbargs(aTHX);
1877
1878         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1879             av_extend(PL_dbargs, AvFILLp(ary) + off);
1880         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1881         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1882     }
1883     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1884     {
1885         SV * mask ;
1886         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1887
1888         if  (old_warnings == pWARN_NONE)
1889             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1890         else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1891             mask = &PL_sv_undef ;
1892         else if (old_warnings == pWARN_ALL ||
1893                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1894             /* Get the bit mask for $warnings::Bits{all}, because
1895              * it could have been extended by warnings::register */
1896             SV **bits_all;
1897             HV * const bits = get_hv("warnings::Bits", 0);
1898             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1899                 mask = newSVsv(*bits_all);
1900             }
1901             else {
1902                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1903             }
1904         }
1905         else
1906             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1907         mPUSHs(mask);
1908     }
1909
1910     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1911           sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1912           : &PL_sv_undef);
1913     RETURN;
1914 }
1915
1916 PP(pp_reset)
1917 {
1918     dSP;
1919     const char * tmps;
1920     STRLEN len = 0;
1921     if (MAXARG < 1 || (!TOPs && !POPs))
1922         tmps = NULL, len = 0;
1923     else
1924         tmps = SvPVx_const(POPs, len);
1925     sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1926     PUSHs(&PL_sv_yes);
1927     RETURN;
1928 }
1929
1930 /* like pp_nextstate, but used instead when the debugger is active */
1931
1932 PP(pp_dbstate)
1933 {
1934     PL_curcop = (COP*)PL_op;
1935     TAINT_NOT;          /* Each statement is presumed innocent */
1936     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1937     FREETMPS;
1938
1939     PERL_ASYNC_CHECK();
1940
1941     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1942             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1943     {
1944         dSP;
1945         PERL_CONTEXT *cx;
1946         const I32 gimme = G_ARRAY;
1947         U8 hasargs;
1948         GV * const gv = PL_DBgv;
1949         CV * cv = NULL;
1950
1951         if (gv && isGV_with_GP(gv))
1952             cv = GvCV(gv);
1953
1954         if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1955             DIE(aTHX_ "No DB::DB routine defined");
1956
1957         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1958             /* don't do recursive DB::DB call */
1959             return NORMAL;
1960
1961         ENTER;
1962         SAVETMPS;
1963
1964         SAVEI32(PL_debug);
1965         SAVESTACK_POS();
1966         PL_debug = 0;
1967         hasargs = 0;
1968         SPAGAIN;
1969
1970         if (CvISXSUB(cv)) {
1971             PUSHMARK(SP);
1972             (void)(*CvXSUB(cv))(aTHX_ cv);
1973             FREETMPS;
1974             LEAVE;
1975             return NORMAL;
1976         }
1977         else {
1978             PUSHBLOCK(cx, CXt_SUB, SP);
1979             PUSHSUB_DB(cx);
1980             cx->blk_sub.retop = PL_op->op_next;
1981             CvDEPTH(cv)++;
1982             if (CvDEPTH(cv) >= 2) {
1983                 PERL_STACK_OVERFLOW_CHECK();
1984                 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1985             }
1986             SAVECOMPPAD();
1987             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1988             RETURNOP(CvSTART(cv));
1989         }
1990     }
1991     else
1992         return NORMAL;
1993 }
1994
1995 /* S_leave_common: Common code that many functions in this file use on
1996                    scope exit.  */
1997
1998 /* SVs on the stack that have any of the flags passed in are left as is.
1999    Other SVs are protected via the mortals stack if lvalue is true, and
2000    copied otherwise.
2001
2002    Also, taintedness is cleared.
2003 */
2004
2005 STATIC SV **
2006 S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
2007                               U32 flags, bool lvalue)
2008 {
2009     bool padtmp = 0;
2010     PERL_ARGS_ASSERT_LEAVE_COMMON;
2011
2012     TAINT_NOT;
2013     if (flags & SVs_PADTMP) {
2014         flags &= ~SVs_PADTMP;
2015         padtmp = 1;
2016     }
2017     if (gimme == G_SCALAR) {
2018         if (MARK < SP)
2019             *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2020                             ? *SP
2021                             : lvalue
2022                                 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2023                                 : sv_mortalcopy(*SP);
2024         else {
2025             /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2026             MARK = newsp;
2027             MEXTEND(MARK, 1);
2028             *++MARK = &PL_sv_undef;
2029             return MARK;
2030         }
2031     }
2032     else if (gimme == G_ARRAY) {
2033         /* in case LEAVE wipes old return values */
2034         while (++MARK <= SP) {
2035             if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2036                 *++newsp = *MARK;
2037             else {
2038                 *++newsp = lvalue
2039                             ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
2040                             : sv_mortalcopy(*MARK);
2041                 TAINT_NOT;      /* Each item is independent */
2042             }
2043         }
2044         /* When this function was called with MARK == newsp, we reach this
2045          * point with SP == newsp. */
2046     }
2047
2048     return newsp;
2049 }
2050
2051 PP(pp_enter)
2052 {
2053     dSP;
2054     PERL_CONTEXT *cx;
2055     I32 gimme = GIMME_V;
2056
2057     ENTER_with_name("block");
2058
2059     SAVETMPS;
2060     PUSHBLOCK(cx, CXt_BLOCK, SP);
2061
2062     RETURN;
2063 }
2064
2065 PP(pp_leave)
2066 {
2067     dSP;
2068     PERL_CONTEXT *cx;
2069     SV **newsp;
2070     PMOP *newpm;
2071     I32 gimme;
2072
2073     if (PL_op->op_flags & OPf_SPECIAL) {
2074         cx = &cxstack[cxstack_ix];
2075         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
2076     }
2077
2078     POPBLOCK(cx,newpm);
2079
2080     gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2081
2082     SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
2083                                PL_op->op_private & OPpLVALUE);
2084     PL_curpm = newpm;   /* Don't pop $1 et al till now */
2085
2086     LEAVE_with_name("block");
2087
2088     RETURN;
2089 }
2090
2091 PP(pp_enteriter)
2092 {
2093     dSP; dMARK;
2094     PERL_CONTEXT *cx;
2095     const I32 gimme = GIMME_V;
2096     void *itervar; /* location of the iteration variable */
2097     U8 cxtype = CXt_LOOP_FOR;
2098
2099     ENTER_with_name("loop1");
2100     SAVETMPS;
2101
2102     if (PL_op->op_targ) {                        /* "my" variable */
2103         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2104             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2105             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2106                     SVs_PADSTALE, SVs_PADSTALE);
2107         }
2108         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2109 #ifdef USE_ITHREADS
2110         itervar = PL_comppad;
2111 #else
2112         itervar = &PAD_SVl(PL_op->op_targ);
2113 #endif
2114     }
2115     else {                                      /* symbol table variable */
2116         GV * const gv = MUTABLE_GV(POPs);
2117         SV** svp = &GvSV(gv);
2118         save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2119         *svp = newSV(0);
2120         itervar = (void *)gv;
2121         save_aliased_sv(gv);
2122     }
2123
2124     if (PL_op->op_private & OPpITER_DEF)
2125         cxtype |= CXp_FOR_DEF;
2126
2127     ENTER_with_name("loop2");
2128
2129     PUSHBLOCK(cx, cxtype, SP);
2130     PUSHLOOP_FOR(cx, itervar, MARK);
2131     if (PL_op->op_flags & OPf_STACKED) {
2132         SV *maybe_ary = POPs;
2133         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2134             dPOPss;
2135             SV * const right = maybe_ary;
2136             SvGETMAGIC(sv);
2137             SvGETMAGIC(right);
2138             if (RANGE_IS_NUMERIC(sv,right)) {
2139                 NV nv;
2140                 cx->cx_type &= ~CXTYPEMASK;
2141                 cx->cx_type |= CXt_LOOP_LAZYIV;
2142                 /* Make sure that no-one re-orders cop.h and breaks our
2143                    assumptions */
2144                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2145 #ifdef NV_PRESERVES_UV
2146                 if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) < (NV)IV_MIN) ||
2147                                   (nv > (NV)IV_MAX)))
2148                         ||
2149                     (SvOK(right) && (((nv = SvNV_nomg(right)) > (NV)IV_MAX) ||
2150                                      (nv < (NV)IV_MIN))))
2151 #else
2152                 if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) <= (NV)IV_MIN)
2153                                   ||
2154                                   ((nv > 0) &&
2155                                         ((nv > (NV)UV_MAX) ||
2156                                          (SvUV_nomg(sv) > (UV)IV_MAX)))))
2157                         ||
2158                     (SvOK(right) && (((nv = SvNV_nomg(right)) <= (NV)IV_MIN)
2159                                      ||
2160                                      ((nv > 0) &&
2161                                         ((nv > (NV)UV_MAX) ||
2162                                          (SvUV_nomg(right) > (UV)IV_MAX))
2163                                      ))))
2164 #endif
2165                     DIE(aTHX_ "Range iterator outside integer range");
2166                 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2167                 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2168 #ifdef DEBUGGING
2169                 /* for correct -Dstv display */
2170                 cx->blk_oldsp = sp - PL_stack_base;
2171 #endif
2172             }
2173             else {
2174                 cx->cx_type &= ~CXTYPEMASK;
2175                 cx->cx_type |= CXt_LOOP_LAZYSV;
2176                 /* Make sure that no-one re-orders cop.h and breaks our
2177                    assumptions */
2178                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2179                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2180                 cx->blk_loop.state_u.lazysv.end = right;
2181                 SvREFCNT_inc(right);
2182                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2183                 /* This will do the upgrade to SVt_PV, and warn if the value
2184                    is uninitialised.  */
2185                 (void) SvPV_nolen_const(right);
2186                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2187                    to replace !SvOK() with a pointer to "".  */
2188                 if (!SvOK(right)) {
2189                     SvREFCNT_dec(right);
2190                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2191                 }
2192             }
2193         }
2194         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2195             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2196             SvREFCNT_inc(maybe_ary);
2197             cx->blk_loop.state_u.ary.ix =
2198                 (PL_op->op_private & OPpITER_REVERSED) ?
2199                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2200                 -1;
2201         }
2202     }
2203     else { /* iterating over items on the stack */
2204         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2205         if (PL_op->op_private & OPpITER_REVERSED) {
2206             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2207         }
2208         else {
2209             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2210         }
2211     }
2212
2213     RETURN;
2214 }
2215
2216 PP(pp_enterloop)
2217 {
2218     dSP;
2219     PERL_CONTEXT *cx;
2220     const I32 gimme = GIMME_V;
2221
2222     ENTER_with_name("loop1");
2223     SAVETMPS;
2224     ENTER_with_name("loop2");
2225
2226     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2227     PUSHLOOP_PLAIN(cx, SP);
2228
2229     RETURN;
2230 }
2231
2232 PP(pp_leaveloop)
2233 {
2234     dSP;
2235     PERL_CONTEXT *cx;
2236     I32 gimme;
2237     SV **newsp;
2238     PMOP *newpm;
2239     SV **mark;
2240
2241     POPBLOCK(cx,newpm);
2242     assert(CxTYPE_is_LOOP(cx));
2243     mark = newsp;
2244     newsp = PL_stack_base + cx->blk_loop.resetsp;
2245
2246     SP = leave_common(newsp, SP, MARK, gimme, 0,
2247                                PL_op->op_private & OPpLVALUE);
2248     PUTBACK;
2249
2250     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2251     PL_curpm = newpm;   /* ... and pop $1 et al */
2252
2253     LEAVE_with_name("loop2");
2254     LEAVE_with_name("loop1");
2255
2256     return NORMAL;
2257 }
2258
2259 STATIC void
2260 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2261                        PERL_CONTEXT *cx, PMOP *newpm)
2262 {
2263     const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2264     if (gimme == G_SCALAR) {
2265         if (CxLVAL(cx) && !ref) {     /* Leave it as it is if we can. */
2266             SV *sv;
2267             const char *what = NULL;
2268             if (MARK < SP) {
2269                 assert(MARK+1 == SP);
2270                 if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
2271                     !SvSMAGICAL(TOPs)) {
2272                     what =
2273                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2274                         : "a readonly value" : "a temporary";
2275                 }
2276                 else goto copy_sv;
2277             }
2278             else {
2279                 /* sub:lvalue{} will take us here. */
2280                 what = "undef";
2281             }
2282             LEAVE;
2283             cxstack_ix--;
2284             POPSUB(cx,sv);
2285             PL_curpm = newpm;
2286             LEAVESUB(sv);
2287             Perl_croak(aTHX_
2288                       "Can't return %s from lvalue subroutine", what
2289             );
2290         }
2291         if (MARK < SP) {
2292               copy_sv:
2293                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2294                     if (!SvPADTMP(*SP)) {
2295                         *++newsp = SvREFCNT_inc(*SP);
2296                         FREETMPS;
2297                         sv_2mortal(*newsp);
2298                     }
2299                     else {
2300                         /* FREETMPS could clobber it */
2301                         SV *sv = SvREFCNT_inc(*SP);
2302                         FREETMPS;
2303                         *++newsp = sv_mortalcopy(sv);
2304                         SvREFCNT_dec(sv);
2305                     }
2306                 }
2307                 else
2308                     *++newsp =
2309                       SvPADTMP(*SP)
2310                        ? sv_mortalcopy(*SP)
2311                        : !SvTEMP(*SP)
2312                           ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2313                           : *SP;
2314         }
2315         else {
2316             EXTEND(newsp,1);
2317             *++newsp = &PL_sv_undef;
2318         }
2319         if (CxLVAL(cx) & OPpDEREF) {
2320             SvGETMAGIC(TOPs);
2321             if (!SvOK(TOPs)) {
2322                 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2323             }
2324         }
2325     }
2326     else if (gimme == G_ARRAY) {
2327         assert (!(CxLVAL(cx) & OPpDEREF));
2328         if (ref || !CxLVAL(cx))
2329             while (++MARK <= SP)
2330                 *++newsp =
2331                        SvFLAGS(*MARK) & SVs_PADTMP
2332                            ? sv_mortalcopy(*MARK)
2333                      : SvTEMP(*MARK)
2334                            ? *MARK
2335                            : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2336         else while (++MARK <= SP) {
2337             if (*MARK != &PL_sv_undef
2338                     && (SvPADTMP(*MARK) || SvREADONLY(*MARK))
2339             ) {
2340                     const bool ro = cBOOL( SvREADONLY(*MARK) );
2341                     SV *sv;
2342                     /* Might be flattened array after $#array =  */
2343                     PUTBACK;
2344                     LEAVE;
2345                     cxstack_ix--;
2346                     POPSUB(cx,sv);
2347                     PL_curpm = newpm;
2348                     LEAVESUB(sv);
2349                /* diag_listed_as: Can't return %s from lvalue subroutine */
2350                     Perl_croak(aTHX_
2351                         "Can't return a %s from lvalue subroutine",
2352                          ro ? "readonly value" : "temporary");
2353             }
2354             else
2355                 *++newsp =
2356                     SvTEMP(*MARK)
2357                        ? *MARK
2358                        : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2359         }
2360     }
2361     PL_stack_sp = newsp;
2362 }
2363
2364 PP(pp_return)
2365 {
2366     dSP; dMARK;
2367     PERL_CONTEXT *cx;
2368     bool popsub2 = FALSE;
2369     bool clear_errsv = FALSE;
2370     bool lval = FALSE;
2371     I32 gimme;
2372     SV **newsp;
2373     PMOP *newpm;
2374     I32 optype = 0;
2375     SV *namesv;
2376     SV *sv;
2377     OP *retop = NULL;
2378
2379     const I32 cxix = dopoptosub(cxstack_ix);
2380
2381     if (cxix < 0) {
2382         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2383                                      * sort block, which is a CXt_NULL
2384                                      * not a CXt_SUB */
2385             dounwind(0);
2386             PL_stack_base[1] = *PL_stack_sp;
2387             PL_stack_sp = PL_stack_base + 1;
2388             return 0;
2389         }
2390         else
2391             DIE(aTHX_ "Can't return outside a subroutine");
2392     }
2393     if (cxix < cxstack_ix)
2394         dounwind(cxix);
2395
2396     if (CxMULTICALL(&cxstack[cxix])) {
2397         gimme = cxstack[cxix].blk_gimme;
2398         if (gimme == G_VOID)
2399             PL_stack_sp = PL_stack_base;
2400         else if (gimme == G_SCALAR) {
2401             PL_stack_base[1] = *PL_stack_sp;
2402             PL_stack_sp = PL_stack_base + 1;
2403         }
2404         return 0;
2405     }
2406
2407     POPBLOCK(cx,newpm);
2408     switch (CxTYPE(cx)) {
2409     case CXt_SUB:
2410         popsub2 = TRUE;
2411         lval = !!CvLVALUE(cx->blk_sub.cv);
2412         retop = cx->blk_sub.retop;
2413         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2414         break;
2415     case CXt_EVAL:
2416         if (!(PL_in_eval & EVAL_KEEPERR))
2417             clear_errsv = TRUE;
2418         POPEVAL(cx);
2419         namesv = cx->blk_eval.old_namesv;
2420         retop = cx->blk_eval.retop;
2421         if (CxTRYBLOCK(cx))
2422             break;
2423         if (optype == OP_REQUIRE &&
2424             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2425         {
2426             /* Unassume the success we assumed earlier. */
2427             (void)hv_delete(GvHVn(PL_incgv),
2428                             SvPVX_const(namesv),
2429                             SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2430                             G_DISCARD);
2431             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2432         }
2433         break;
2434     case CXt_FORMAT:
2435         retop = cx->blk_sub.retop;
2436         POPFORMAT(cx);
2437         break;
2438     default:
2439         DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2440     }
2441
2442     TAINT_NOT;
2443     if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2444     else {
2445       if (gimme == G_SCALAR) {
2446         if (MARK < SP) {
2447             if (popsub2) {
2448                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2449                     if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2450                          && !SvMAGICAL(TOPs)) {
2451                         *++newsp = SvREFCNT_inc(*SP);
2452                         FREETMPS;
2453                         sv_2mortal(*newsp);
2454                     }
2455                     else {
2456                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2457                         FREETMPS;
2458                         *++newsp = sv_mortalcopy(sv);
2459                         SvREFCNT_dec(sv);
2460                     }
2461                 }
2462                 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2463                           && !SvMAGICAL(*SP)) {
2464                     *++newsp = *SP;
2465                 }
2466                 else
2467                     *++newsp = sv_mortalcopy(*SP);
2468             }
2469             else
2470                 *++newsp = sv_mortalcopy(*SP);
2471         }
2472         else
2473             *++newsp = &PL_sv_undef;
2474       }
2475       else if (gimme == G_ARRAY) {
2476         while (++MARK <= SP) {
2477             *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2478                                && !SvGMAGICAL(*MARK)
2479                         ? *MARK : sv_mortalcopy(*MARK);
2480             TAINT_NOT;          /* Each item is independent */
2481         }
2482       }
2483       PL_stack_sp = newsp;
2484     }
2485
2486     LEAVE;
2487     /* Stack values are safe: */
2488     if (popsub2) {
2489         cxstack_ix--;
2490         POPSUB(cx,sv);  /* release CV and @_ ... */
2491     }
2492     else
2493         sv = NULL;
2494     PL_curpm = newpm;   /* ... and pop $1 et al */
2495
2496     LEAVESUB(sv);
2497     if (clear_errsv) {
2498         CLEAR_ERRSV();
2499     }
2500     return retop;
2501 }
2502
2503 /* This duplicates parts of pp_leavesub, so that it can share code with
2504  * pp_return */
2505 PP(pp_leavesublv)
2506 {
2507     dSP;
2508     SV **newsp;
2509     PMOP *newpm;
2510     I32 gimme;
2511     PERL_CONTEXT *cx;
2512     SV *sv;
2513
2514     if (CxMULTICALL(&cxstack[cxstack_ix]))
2515         return 0;
2516
2517     POPBLOCK(cx,newpm);
2518     cxstack_ix++; /* temporarily protect top context */
2519
2520     TAINT_NOT;
2521
2522     S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2523
2524     LEAVE;
2525     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2526     cxstack_ix--;
2527     PL_curpm = newpm;   /* ... and pop $1 et al */
2528
2529     LEAVESUB(sv);
2530     return cx->blk_sub.retop;
2531 }
2532
2533 static I32
2534 S_unwind_loop(pTHX_ const char * const opname)
2535 {
2536     I32 cxix;
2537     if (PL_op->op_flags & OPf_SPECIAL) {
2538         cxix = dopoptoloop(cxstack_ix);
2539         if (cxix < 0)
2540             /* diag_listed_as: Can't "last" outside a loop block */
2541             Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2542     }
2543     else {
2544         dSP;
2545         STRLEN label_len;
2546         const char * const label =
2547             PL_op->op_flags & OPf_STACKED
2548                 ? SvPV(TOPs,label_len)
2549                 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2550         const U32 label_flags =
2551             PL_op->op_flags & OPf_STACKED
2552                 ? SvUTF8(POPs)
2553                 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2554         PUTBACK;
2555         cxix = dopoptolabel(label, label_len, label_flags);
2556         if (cxix < 0)
2557             /* diag_listed_as: Label not found for "last %s" */
2558             Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2559                                        opname,
2560                                        SVfARG(PL_op->op_flags & OPf_STACKED
2561                                               && !SvGMAGICAL(TOPp1s)
2562                                               ? TOPp1s
2563                                               : newSVpvn_flags(label,
2564                                                     label_len,
2565                                                     label_flags | SVs_TEMP)));
2566     }
2567     if (cxix < cxstack_ix)
2568         dounwind(cxix);
2569     return cxix;
2570 }
2571
2572 PP(pp_last)
2573 {
2574     PERL_CONTEXT *cx;
2575     I32 pop2 = 0;
2576     I32 gimme;
2577     I32 optype;
2578     OP *nextop = NULL;
2579     SV **newsp;
2580     PMOP *newpm;
2581     SV *sv = NULL;
2582
2583     S_unwind_loop(aTHX_ "last");
2584
2585     POPBLOCK(cx,newpm);
2586     cxstack_ix++; /* temporarily protect top context */
2587     switch (CxTYPE(cx)) {
2588     case CXt_LOOP_LAZYIV:
2589     case CXt_LOOP_LAZYSV:
2590     case CXt_LOOP_FOR:
2591     case CXt_LOOP_PLAIN:
2592         pop2 = CxTYPE(cx);
2593         newsp = PL_stack_base + cx->blk_loop.resetsp;
2594         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2595         break;
2596     case CXt_SUB:
2597         pop2 = CXt_SUB;
2598         nextop = cx->blk_sub.retop;
2599         break;
2600     case CXt_EVAL:
2601         POPEVAL(cx);
2602         nextop = cx->blk_eval.retop;
2603         break;
2604     case CXt_FORMAT:
2605         POPFORMAT(cx);
2606         nextop = cx->blk_sub.retop;
2607         break;
2608     default:
2609         DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2610     }
2611
2612     TAINT_NOT;
2613     PL_stack_sp = newsp;
2614
2615     LEAVE;
2616     cxstack_ix--;
2617     /* Stack values are safe: */
2618     switch (pop2) {
2619     case CXt_LOOP_LAZYIV:
2620     case CXt_LOOP_PLAIN:
2621     case CXt_LOOP_LAZYSV:
2622     case CXt_LOOP_FOR:
2623         POPLOOP(cx);    /* release loop vars ... */
2624         LEAVE;
2625         break;
2626     case CXt_SUB:
2627         POPSUB(cx,sv);  /* release CV and @_ ... */
2628         break;
2629     }
2630     PL_curpm = newpm;   /* ... and pop $1 et al */
2631
2632     LEAVESUB(sv);
2633     PERL_UNUSED_VAR(optype);
2634     PERL_UNUSED_VAR(gimme);
2635     return nextop;
2636 }
2637
2638 PP(pp_next)
2639 {
2640     PERL_CONTEXT *cx;
2641     const I32 inner = PL_scopestack_ix;
2642
2643     S_unwind_loop(aTHX_ "next");
2644
2645     /* clear off anything above the scope we're re-entering, but
2646      * save the rest until after a possible continue block */
2647     TOPBLOCK(cx);
2648     if (PL_scopestack_ix < inner)
2649         leave_scope(PL_scopestack[PL_scopestack_ix]);
2650     PL_curcop = cx->blk_oldcop;
2651     PERL_ASYNC_CHECK();
2652     return (cx)->blk_loop.my_op->op_nextop;
2653 }
2654
2655 PP(pp_redo)
2656 {
2657     const I32 cxix = S_unwind_loop(aTHX_ "redo");
2658     PERL_CONTEXT *cx;
2659     I32 oldsave;
2660     OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2661
2662     if (redo_op->op_type == OP_ENTER) {
2663         /* pop one less context to avoid $x being freed in while (my $x..) */
2664         cxstack_ix++;
2665         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2666         redo_op = redo_op->op_next;
2667     }
2668
2669     TOPBLOCK(cx);
2670     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2671     LEAVE_SCOPE(oldsave);
2672     FREETMPS;
2673     PL_curcop = cx->blk_oldcop;
2674     PERL_ASYNC_CHECK();
2675     return redo_op;
2676 }
2677
2678 STATIC OP *
2679 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2680 {
2681     OP **ops = opstack;
2682     static const char* const too_deep = "Target of goto is too deeply nested";
2683
2684     PERL_ARGS_ASSERT_DOFINDLABEL;
2685
2686     if (ops >= oplimit)
2687         Perl_croak(aTHX_ "%s", too_deep);
2688     if (o->op_type == OP_LEAVE ||
2689         o->op_type == OP_SCOPE ||
2690         o->op_type == OP_LEAVELOOP ||
2691         o->op_type == OP_LEAVESUB ||
2692         o->op_type == OP_LEAVETRY)
2693     {
2694         *ops++ = cUNOPo->op_first;
2695         if (ops >= oplimit)
2696             Perl_croak(aTHX_ "%s", too_deep);
2697     }
2698     *ops = 0;
2699     if (o->op_flags & OPf_KIDS) {
2700         OP *kid;
2701         /* First try all the kids at this level, since that's likeliest. */
2702         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2703             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2704                 STRLEN kid_label_len;
2705                 U32 kid_label_flags;
2706                 const char *kid_label = CopLABEL_len_flags(kCOP,
2707                                                     &kid_label_len, &kid_label_flags);
2708                 if (kid_label && (
2709                     ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2710                         (flags & SVf_UTF8)
2711                             ? (bytes_cmp_utf8(
2712                                         (const U8*)kid_label, kid_label_len,
2713                                         (const U8*)label, len) == 0)
2714                             : (bytes_cmp_utf8(
2715                                         (const U8*)label, len,
2716                                         (const U8*)kid_label, kid_label_len) == 0)
2717                     : ( len == kid_label_len && ((kid_label == label)
2718                                     || memEQ(kid_label, label, len)))))
2719                     return kid;
2720             }
2721         }
2722         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2723             if (kid == PL_lastgotoprobe)
2724                 continue;
2725             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2726                 if (ops == opstack)
2727                     *ops++ = kid;
2728                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2729                          ops[-1]->op_type == OP_DBSTATE)
2730                     ops[-1] = kid;
2731                 else
2732                     *ops++ = kid;
2733             }
2734             if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2735                 return o;
2736         }
2737     }
2738     *ops = 0;
2739     return 0;
2740 }
2741
2742
2743 /* also used for: pp_dump() */
2744
2745 PP(pp_goto)
2746 {
2747     dVAR; dSP;
2748     OP *retop = NULL;
2749     I32 ix;
2750     PERL_CONTEXT *cx;
2751 #define GOTO_DEPTH 64
2752     OP *enterops[GOTO_DEPTH];
2753     const char *label = NULL;
2754     STRLEN label_len = 0;
2755     U32 label_flags = 0;
2756     const bool do_dump = (PL_op->op_type == OP_DUMP);
2757     static const char* const must_have_label = "goto must have label";
2758
2759     if (PL_op->op_flags & OPf_STACKED) {
2760         /* goto EXPR  or  goto &foo */
2761
2762         SV * const sv = POPs;
2763         SvGETMAGIC(sv);
2764
2765         /* This egregious kludge implements goto &subroutine */
2766         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2767             I32 cxix;
2768             PERL_CONTEXT *cx;
2769             CV *cv = MUTABLE_CV(SvRV(sv));
2770             AV *arg = GvAV(PL_defgv);
2771             I32 oldsave;
2772
2773         retry:
2774             if (!CvROOT(cv) && !CvXSUB(cv)) {
2775                 const GV * const gv = CvGV(cv);
2776                 if (gv) {
2777                     GV *autogv;
2778                     SV *tmpstr;
2779                     /* autoloaded stub? */
2780                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2781                         goto retry;
2782                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2783                                           GvNAMELEN(gv),
2784                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2785                     if (autogv && (cv = GvCV(autogv)))
2786                         goto retry;
2787                     tmpstr = sv_newmortal();
2788                     gv_efullname3(tmpstr, gv, NULL);
2789                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2790                 }
2791                 DIE(aTHX_ "Goto undefined subroutine");
2792             }
2793
2794             /* First do some returnish stuff. */
2795             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2796             FREETMPS;
2797             cxix = dopoptosub(cxstack_ix);
2798             if (cxix < cxstack_ix) {
2799                 if (cxix < 0) {
2800                     SvREFCNT_dec(cv);
2801                     DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2802                 }
2803                 dounwind(cxix);
2804             }
2805             TOPBLOCK(cx);
2806             SPAGAIN;
2807             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2808             if (CxTYPE(cx) == CXt_EVAL) {
2809                 SvREFCNT_dec(cv);
2810                 if (CxREALEVAL(cx))
2811                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2812                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2813                 else
2814                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2815                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2816             }
2817             else if (CxMULTICALL(cx))
2818             {
2819                 SvREFCNT_dec(cv);
2820                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2821             }
2822             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2823                 AV* av = cx->blk_sub.argarray;
2824
2825                 /* abandon the original @_ if it got reified or if it is
2826                    the same as the current @_ */
2827                 if (AvREAL(av) || av == arg) {
2828                     SvREFCNT_dec(av);
2829                     av = newAV();
2830                     AvREIFY_only(av);
2831                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2832                 }
2833                 else CLEAR_ARGARRAY(av);
2834             }
2835             /* We donate this refcount later to the callee’s pad. */
2836             SvREFCNT_inc_simple_void(arg);
2837             if (CxTYPE(cx) == CXt_SUB &&
2838                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2839                 SvREFCNT_dec(cx->blk_sub.cv);
2840             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2841             LEAVE_SCOPE(oldsave);
2842
2843             /* A destructor called during LEAVE_SCOPE could have undefined
2844              * our precious cv.  See bug #99850. */
2845             if (!CvROOT(cv) && !CvXSUB(cv)) {
2846                 const GV * const gv = CvGV(cv);
2847                 SvREFCNT_dec(arg);
2848                 if (gv) {
2849                     SV * const tmpstr = sv_newmortal();
2850                     gv_efullname3(tmpstr, gv, NULL);
2851                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2852                                SVfARG(tmpstr));
2853                 }
2854                 DIE(aTHX_ "Goto undefined subroutine");
2855             }
2856
2857             /* Now do some callish stuff. */
2858             SAVETMPS;
2859             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2860             if (CvISXSUB(cv)) {
2861                 OP* const retop = cx->blk_sub.retop;
2862                 SV **newsp;
2863                 I32 gimme;
2864                 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2865                 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2866                 SV** mark;
2867
2868                 PERL_UNUSED_VAR(newsp);
2869                 PERL_UNUSED_VAR(gimme);
2870
2871                 /* put GvAV(defgv) back onto stack */
2872                 if (items) {
2873                     EXTEND(SP, items+1); /* @_ could have been extended. */
2874                 }
2875                 mark = SP;
2876                 if (items) {
2877                     SSize_t index;
2878                     bool r = cBOOL(AvREAL(arg));
2879                     for (index=0; index<items; index++)
2880                     {
2881                         SV *sv;
2882                         if (m) {
2883                             SV ** const svp = av_fetch(arg, index, 0);
2884                             sv = svp ? *svp : NULL;
2885                         }
2886                         else sv = AvARRAY(arg)[index];
2887                         SP[index+1] = sv
2888                             ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2889                             : sv_2mortal(newSVavdefelem(arg, index, 1));
2890                     }
2891                 }
2892                 SP += items;
2893                 SvREFCNT_dec(arg);
2894                 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2895                     /* Restore old @_ */
2896                     arg = GvAV(PL_defgv);
2897                     GvAV(PL_defgv) = cx->blk_sub.savearray;
2898                     SvREFCNT_dec(arg);
2899                 }
2900
2901                 /* XS subs don't have a CxSUB, so pop it */
2902                 POPBLOCK(cx, PL_curpm);
2903                 /* Push a mark for the start of arglist */
2904                 PUSHMARK(mark);
2905                 PUTBACK;
2906                 (void)(*CvXSUB(cv))(aTHX_ cv);
2907                 LEAVE;
2908                 PERL_ASYNC_CHECK();
2909                 return retop;
2910             }
2911             else {
2912                 PADLIST * const padlist = CvPADLIST(cv);
2913                 cx->blk_sub.cv = cv;
2914                 cx->blk_sub.olddepth = CvDEPTH(cv);
2915
2916                 CvDEPTH(cv)++;
2917                 if (CvDEPTH(cv) < 2)
2918                     SvREFCNT_inc_simple_void_NN(cv);
2919                 else {
2920                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2921                         sub_crush_depth(cv);
2922                     pad_push(padlist, CvDEPTH(cv));
2923                 }
2924                 PL_curcop = cx->blk_oldcop;
2925                 SAVECOMPPAD();
2926                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2927                 if (CxHASARGS(cx))
2928                 {
2929                     CX_CURPAD_SAVE(cx->blk_sub);
2930
2931                     /* cx->blk_sub.argarray has no reference count, so we
2932                        need something to hang on to our argument array so
2933                        that cx->blk_sub.argarray does not end up pointing
2934                        to freed memory as the result of undef *_.  So put
2935                        it in the callee’s pad, donating our refer-
2936                        ence count. */
2937                     if (arg) {
2938                         SvREFCNT_dec(PAD_SVl(0));
2939                         PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2940                     }
2941
2942                     /* GvAV(PL_defgv) might have been modified on scope
2943                        exit, so restore it. */
2944                     if (arg != GvAV(PL_defgv)) {
2945                         AV * const av = GvAV(PL_defgv);
2946                         GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2947                         SvREFCNT_dec(av);
2948                     }
2949                 }
2950                 else SvREFCNT_dec(arg);
2951                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2952                     Perl_get_db_sub(aTHX_ NULL, cv);
2953                     if (PERLDB_GOTO) {
2954                         CV * const gotocv = get_cvs("DB::goto", 0);
2955                         if (gotocv) {
2956                             PUSHMARK( PL_stack_sp );
2957                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2958                             PL_stack_sp--;
2959                         }
2960                     }
2961                 }
2962                 PERL_ASYNC_CHECK();
2963                 RETURNOP(CvSTART(cv));
2964             }
2965         }
2966         else {
2967             /* goto EXPR */
2968             label       = SvPV_nomg_const(sv, label_len);
2969             label_flags = SvUTF8(sv);
2970         }
2971     }
2972     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2973         /* goto LABEL  or  dump LABEL */
2974         label       = cPVOP->op_pv;
2975         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2976         label_len   = strlen(label);
2977     }
2978     if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2979
2980     PERL_ASYNC_CHECK();
2981
2982     if (label_len) {
2983         OP *gotoprobe = NULL;
2984         bool leaving_eval = FALSE;
2985         bool in_block = FALSE;
2986         PERL_CONTEXT *last_eval_cx = NULL;
2987
2988         /* find label */
2989
2990         PL_lastgotoprobe = NULL;
2991         *enterops = 0;
2992         for (ix = cxstack_ix; ix >= 0; ix--) {
2993             cx = &cxstack[ix];
2994             switch (CxTYPE(cx)) {
2995             case CXt_EVAL:
2996                 leaving_eval = TRUE;
2997                 if (!CxTRYBLOCK(cx)) {
2998                     gotoprobe = (last_eval_cx ?
2999                                 last_eval_cx->blk_eval.old_eval_root :
3000                                 PL_eval_root);
3001                     last_eval_cx = cx;
3002                     break;
3003                 }
3004                 /* else fall through */
3005             case CXt_LOOP_LAZYIV:
3006             case CXt_LOOP_LAZYSV:
3007             case CXt_LOOP_FOR:
3008             case CXt_LOOP_PLAIN:
3009             case CXt_GIVEN:
3010             case CXt_WHEN:
3011                 gotoprobe = OP_SIBLING(cx->blk_oldcop);
3012                 break;
3013             case CXt_SUBST:
3014                 continue;
3015             case CXt_BLOCK:
3016                 if (ix) {
3017                     gotoprobe = OP_SIBLING(cx->blk_oldcop);
3018                     in_block = TRUE;
3019                 } else
3020                     gotoprobe = PL_main_root;
3021                 break;
3022             case CXt_SUB:
3023                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3024                     gotoprobe = CvROOT(cx->blk_sub.cv);
3025                     break;
3026                 }
3027                 /* FALLTHROUGH */
3028             case CXt_FORMAT:
3029             case CXt_NULL:
3030                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3031             default:
3032                 if (ix)
3033                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3034                         CxTYPE(cx), (long) ix);
3035                 gotoprobe = PL_main_root;
3036                 break;
3037             }
3038             if (gotoprobe) {
3039                 OP *sibl1, *sibl2;
3040
3041                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3042                                     enterops, enterops + GOTO_DEPTH);
3043                 if (retop)
3044                     break;
3045                 if ( (sibl1 = OP_SIBLING(gotoprobe)) &&
3046                      sibl1->op_type == OP_UNSTACK &&
3047                      (sibl2 = OP_SIBLING(sibl1)))
3048                 {
3049                     retop = dofindlabel(sibl2,
3050                                         label, label_len, label_flags, enterops,
3051                                         enterops + GOTO_DEPTH);
3052                     if (retop)
3053                         break;
3054                 }
3055             }
3056             PL_lastgotoprobe = gotoprobe;
3057         }
3058         if (!retop)
3059             DIE(aTHX_ "Can't find label %"UTF8f, 
3060                        UTF8fARG(label_flags, label_len, label));
3061
3062         /* if we're leaving an eval, check before we pop any frames
3063            that we're not going to punt, otherwise the error
3064            won't be caught */
3065
3066         if (leaving_eval && *enterops && enterops[1]) {
3067             I32 i;
3068             for (i = 1; enterops[i]; i++)
3069                 if (enterops[i]->op_type == OP_ENTERITER)
3070                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3071         }
3072
3073         if (*enterops && enterops[1]) {
3074             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3075             if (enterops[i])
3076                 deprecate("\"goto\" to jump into a construct");
3077         }
3078
3079         /* pop unwanted frames */
3080
3081         if (ix < cxstack_ix) {
3082             I32 oldsave;
3083
3084             if (ix < 0)
3085                 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3086             dounwind(ix);
3087             TOPBLOCK(cx);
3088             oldsave = PL_scopestack[PL_scopestack_ix];
3089             LEAVE_SCOPE(oldsave);
3090         }
3091
3092         /* push wanted frames */
3093
3094         if (*enterops && enterops[1]) {
3095             OP * const oldop = PL_op;
3096             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3097             for (; enterops[ix]; ix++) {
3098                 PL_op = enterops[ix];
3099                 /* Eventually we may want to stack the needed arguments
3100                  * for each op.  For now, we punt on the hard ones. */
3101                 if (PL_op->op_type == OP_ENTERITER)
3102                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3103                 PL_op->op_ppaddr(aTHX);
3104             }
3105             PL_op = oldop;
3106         }
3107     }
3108
3109     if (do_dump) {
3110 #ifdef VMS
3111         if (!retop) retop = PL_main_start;
3112 #endif
3113         PL_restartop = retop;
3114         PL_do_undump = TRUE;
3115
3116         my_unexec();
3117
3118         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3119         PL_do_undump = FALSE;
3120     }
3121
3122     PERL_ASYNC_CHECK();
3123     RETURNOP(retop);
3124 }
3125
3126 PP(pp_exit)
3127 {
3128     dSP;
3129     I32 anum;
3130
3131     if (MAXARG < 1)
3132         anum = 0;
3133     else if (!TOPs) {
3134         anum = 0; (void)POPs;
3135     }
3136     else {
3137         anum = SvIVx(POPs);
3138 #ifdef VMS
3139         if (anum == 1
3140          && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3141             anum = 0;
3142         VMSISH_HUSHED  =
3143             VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3144 #endif
3145     }
3146     PL_exit_flags |= PERL_EXIT_EXPECTED;
3147     my_exit(anum);
3148     PUSHs(&PL_sv_undef);
3149     RETURN;
3150 }
3151
3152 /* Eval. */
3153
3154 STATIC void
3155 S_save_lines(pTHX_ AV *array, SV *sv)
3156 {
3157     const char *s = SvPVX_const(sv);
3158     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3159     I32 line = 1;
3160
3161     PERL_ARGS_ASSERT_SAVE_LINES;
3162
3163     while (s && s < send) {
3164         const char *t;
3165         SV * const tmpstr = newSV_type(SVt_PVMG);
3166
3167         t = (const char *)memchr(s, '\n', send - s);
3168         if (t)
3169             t++;
3170         else
3171             t = send;
3172
3173         sv_setpvn(tmpstr, s, t - s);
3174         av_store(array, line++, tmpstr);
3175         s = t;
3176     }
3177 }
3178
3179 /*
3180 =for apidoc docatch
3181
3182 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3183
3184 0 is used as continue inside eval,
3185
3186 3 is used for a die caught by an inner eval - continue inner loop
3187
3188 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3189 establish a local jmpenv to handle exception traps.
3190
3191 =cut
3192 */
3193 STATIC OP *
3194 S_docatch(pTHX_ OP *o)
3195 {
3196     int ret;
3197     OP * const oldop = PL_op;
3198     dJMPENV;
3199
3200 #ifdef DEBUGGING
3201     assert(CATCH_GET == TRUE);
3202 #endif
3203     PL_op = o;
3204
3205     JMPENV_PUSH(ret);
3206     switch (ret) {
3207     case 0:
3208         assert(cxstack_ix >= 0);
3209         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3210         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3211  redo_body:
3212         CALLRUNOPS(aTHX);
3213         break;
3214     case 3:
3215         /* die caught by an inner eval - continue inner loop */
3216         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3217             PL_restartjmpenv = NULL;
3218             PL_op = PL_restartop;
3219             PL_restartop = 0;
3220             goto redo_body;
3221         }
3222         /* FALLTHROUGH */
3223     default:
3224         JMPENV_POP;
3225         PL_op = oldop;
3226         JMPENV_JUMP(ret);
3227         assert(0); /* NOTREACHED */
3228     }
3229     JMPENV_POP;
3230     PL_op = oldop;
3231     return NULL;
3232 }
3233
3234
3235 /*
3236 =for apidoc find_runcv
3237
3238 Locate the CV corresponding to the currently executing sub or eval.
3239 If db_seqp is non_null, skip CVs that are in the DB package and populate
3240 *db_seqp with the cop sequence number at the point that the DB:: code was
3241 entered.  (This allows debuggers to eval in the scope of the breakpoint
3242 rather than in the scope of the debugger itself.)
3243
3244 =cut
3245 */
3246
3247 CV*
3248 Perl_find_runcv(pTHX_ U32 *db_seqp)
3249 {
3250     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3251 }
3252
3253 /* If this becomes part of the API, it might need a better name. */
3254 CV *
3255 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3256 {
3257     PERL_SI      *si;
3258     int          level = 0;
3259
3260     if (db_seqp)
3261         *db_seqp =
3262             PL_curcop == &PL_compiling
3263                 ? PL_cop_seqmax
3264                 : PL_curcop->cop_seq;
3265
3266     for (si = PL_curstackinfo; si; si = si->si_prev) {
3267         I32 ix;
3268         for (ix = si->si_cxix; ix >= 0; ix--) {
3269             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3270             CV *cv = NULL;
3271             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3272                 cv = cx->blk_sub.cv;
3273                 /* skip DB:: code */
3274                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3275                     *db_seqp = cx->blk_oldcop->cop_seq;
3276                     continue;
3277                 }
3278                 if (cx->cx_type & CXp_SUB_RE)
3279                     continue;
3280             }
3281             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3282                 cv = cx->blk_eval.cv;
3283             if (cv) {
3284                 switch (cond) {
3285                 case FIND_RUNCV_padid_eq:
3286                     if (!CvPADLIST(cv)
3287                      || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
3288                         continue;
3289                     return cv;
3290                 case FIND_RUNCV_level_eq:
3291                     if (level++ != arg) continue;
3292                     /* GERONIMO! */
3293                 default:
3294                     return cv;
3295                 }
3296             }
3297         }
3298     }
3299     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3300 }
3301
3302
3303 /* Run yyparse() in a setjmp wrapper. Returns:
3304  *   0: yyparse() successful
3305  *   1: yyparse() failed
3306  *   3: yyparse() died
3307  */
3308 STATIC int
3309 S_try_yyparse(pTHX_ int gramtype)
3310 {
3311     int ret;
3312     dJMPENV;
3313
3314     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3315     JMPENV_PUSH(ret);
3316     switch (ret) {
3317     case 0:
3318         ret = yyparse(gramtype) ? 1 : 0;
3319         break;
3320     case 3:
3321         break;
3322     default:
3323         JMPENV_POP;
3324         JMPENV_JUMP(ret);
3325         assert(0); /* NOTREACHED */
3326     }
3327     JMPENV_POP;
3328     return ret;
3329 }
3330
3331
3332 /* Compile a require/do or an eval ''.
3333  *
3334  * outside is the lexically enclosing CV (if any) that invoked us.
3335  * seq     is the current COP scope value.
3336  * hh      is the saved hints hash, if any.
3337  *
3338  * Returns a bool indicating whether the compile was successful; if so,
3339  * PL_eval_start contains the first op of the compiled code; otherwise,
3340  * pushes undef.
3341  *
3342  * This function is called from two places: pp_require and pp_entereval.
3343  * These can be distinguished by whether PL_op is entereval.
3344  */
3345
3346 STATIC bool
3347 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3348 {
3349     dSP;
3350     OP * const saveop = PL_op;
3351     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3352     COP * const oldcurcop = PL_curcop;
3353     bool in_require = (saveop->op_type == OP_REQUIRE);
3354     int yystatus;
3355     CV *evalcv;
3356
3357     PL_in_eval = (in_require
3358                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3359                   : (EVAL_INEVAL |
3360                         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3361                             ? EVAL_RE_REPARSING : 0)));
3362
3363     PUSHMARK(SP);
3364
3365     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3366     CvEVAL_on(evalcv);
3367     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3368     cxstack[cxstack_ix].blk_eval.cv = evalcv;
3369     cxstack[cxstack_ix].blk_gimme = gimme;
3370
3371     CvOUTSIDE_SEQ(evalcv) = seq;
3372     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3373
3374     /* set up a scratch pad */
3375
3376     CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3377     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3378
3379
3380     SAVEMORTALIZESV(evalcv);    /* must remain until end of current statement */
3381
3382     /* make sure we compile in the right package */
3383
3384     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3385         SAVEGENERICSV(PL_curstash);
3386         PL_curstash = (HV *)CopSTASH(PL_curcop);
3387         if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3388         else SvREFCNT_inc_simple_void(PL_curstash);
3389     }
3390     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3391     SAVESPTR(PL_beginav);
3392     PL_beginav = newAV();
3393     SAVEFREESV(PL_beginav);
3394     SAVESPTR(PL_unitcheckav);
3395     PL_unitcheckav = newAV();
3396     SAVEFREESV(PL_unitcheckav);
3397
3398
3399     ENTER_with_name("evalcomp");
3400     SAVESPTR(PL_compcv);
3401     PL_compcv = evalcv;
3402
3403     /* try to compile it */
3404
3405     PL_eval_root = NULL;
3406     PL_curcop = &PL_compiling;
3407     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3408         PL_in_eval |= EVAL_KEEPERR;
3409     else
3410         CLEAR_ERRSV();
3411
3412     SAVEHINTS();
3413     if (clear_hints) {
3414         PL_hints = 0;
3415         hv_clear(GvHV(PL_hintgv));
3416     }
3417     else {
3418         PL_hints = saveop->op_private & OPpEVAL_COPHH
3419                      ? oldcurcop->cop_hints : saveop->op_targ;
3420
3421         /* making 'use re eval' not be in scope when compiling the
3422          * qr/mabye_has_runtime_code_block/ ensures that we don't get
3423          * infinite recursion when S_has_runtime_code() gives a false
3424          * positive: the second time round, HINT_RE_EVAL isn't set so we
3425          * don't bother calling S_has_runtime_code() */
3426         if (PL_in_eval & EVAL_RE_REPARSING)
3427             PL_hints &= ~HINT_RE_EVAL;
3428
3429         if (hh) {
3430             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3431             SvREFCNT_dec(GvHV(PL_hintgv));
3432             GvHV(PL_hintgv) = hh;
3433         }
3434     }
3435     SAVECOMPILEWARNINGS();
3436     if (clear_hints) {
3437         if (PL_dowarn & G_WARN_ALL_ON)
3438             PL_compiling.cop_warnings = pWARN_ALL ;
3439         else if (PL_dowarn & G_WARN_ALL_OFF)
3440             PL_compiling.cop_warnings = pWARN_NONE ;
3441         else
3442             PL_compiling.cop_warnings = pWARN_STD ;
3443     }
3444     else {
3445         PL_compiling.cop_warnings =
3446             DUP_WARNINGS(oldcurcop->cop_warnings);
3447         cophh_free(CopHINTHASH_get(&PL_compiling));
3448         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3449             /* The label, if present, is the first entry on the chain. So rather
3450                than writing a blank label in front of it (which involves an
3451                allocation), just use the next entry in the chain.  */
3452             PL_compiling.cop_hints_hash
3453                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3454             /* Check the assumption that this removed the label.  */
3455             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3456         }
3457         else
3458             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3459     }
3460
3461     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3462
3463     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3464      * so honour CATCH_GET and trap it here if necessary */
3465
3466     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3467
3468     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3469         SV **newsp;                     /* Used by POPBLOCK. */
3470         PERL_CONTEXT *cx;
3471         I32 optype;                     /* Used by POPEVAL. */
3472         SV *namesv;
3473         SV *errsv = NULL;
3474
3475         cx = NULL;
3476         namesv = NULL;
3477         PERL_UNUSED_VAR(newsp);
3478         PERL_UNUSED_VAR(optype);
3479
3480         /* note that if yystatus == 3, then the EVAL CX block has already
3481          * been popped, and various vars restored */
3482         PL_op = saveop;
3483         if (yystatus != 3) {
3484             if (PL_eval_root) {
3485                 op_free(PL_eval_root);
3486                 PL_eval_root = NULL;
3487             }
3488             SP = PL_stack_base + POPMARK;       /* pop original mark */
3489             POPBLOCK(cx,PL_curpm);
3490             POPEVAL(cx);
3491             namesv = cx->blk_eval.old_namesv;
3492             /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3493             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3494         }
3495
3496         errsv = ERRSV;
3497         if (in_require) {
3498             if (!cx) {
3499                 /* If cx is still NULL, it means that we didn't go in the
3500                  * POPEVAL branch. */
3501                 cx = &cxstack[cxstack_ix];
3502                 assert(CxTYPE(cx) == CXt_EVAL);
3503                 namesv = cx->blk_eval.old_namesv;
3504             }
3505             (void)hv_store(GvHVn(PL_incgv),
3506                            SvPVX_const(namesv),
3507                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3508                            &PL_sv_undef, 0);
3509             Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3510                        SVfARG(errsv
3511                                 ? errsv
3512                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3513         }
3514         else {
3515             if (!*(SvPV_nolen_const(errsv))) {
3516                 sv_setpvs(errsv, "Compilation error");
3517             }
3518         }
3519         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3520         PUTBACK;
3521         return FALSE;
3522     }
3523     else
3524         LEAVE_with_name("evalcomp");
3525
3526     CopLINE_set(&PL_compiling, 0);
3527     SAVEFREEOP(PL_eval_root);
3528     cv_forget_slab(evalcv);
3529
3530     DEBUG_x(dump_eval());
3531
3532     /* Register with debugger: */
3533     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3534         CV * const cv = get_cvs("DB::postponed", 0);
3535         if (cv) {
3536             dSP;
3537             PUSHMARK(SP);
3538             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3539             PUTBACK;
3540             call_sv(MUTABLE_SV(cv), G_DISCARD);
3541         }
3542     }
3543
3544     if (PL_unitcheckav) {
3545         OP *es = PL_eval_start;
3546         call_list(PL_scopestack_ix, PL_unitcheckav);
3547         PL_eval_start = es;
3548     }
3549
3550     /* compiled okay, so do it */
3551
3552     CvDEPTH(evalcv) = 1;
3553     SP = PL_stack_base + POPMARK;               /* pop original mark */
3554     PL_op = saveop;                     /* The caller may need it. */
3555     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3556
3557     PUTBACK;
3558     return TRUE;
3559 }
3560
3561 STATIC PerlIO *
3562 S_check_type_and_open(pTHX_ SV *name)
3563 {
3564     Stat_t st;
3565     STRLEN len;
3566     const char *p = SvPV_const(name, len);
3567     int st_rc;
3568
3569     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3570
3571     /* checking here captures a reasonable error message when
3572      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3573      * user gets a confusing message about looking for the .pmc file
3574      * rather than for the .pm file.
3575      * This check prevents a \0 in @INC causing problems.
3576      */
3577     if (!IS_SAFE_PATHNAME(p, len, "require"))
3578         return NULL;
3579
3580     /* we use the value of errno later to see how stat() or open() failed.
3581      * We don't want it set if the stat succeeded but we still failed,
3582      * such as if the name exists, but is a directory */
3583     errno = 0;
3584
3585     st_rc = PerlLIO_stat(p, &st);
3586
3587     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3588         return NULL;
3589     }
3590
3591 #if !defined(PERLIO_IS_STDIO)
3592     return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3593 #else
3594     return PerlIO_open(p, PERL_SCRIPT_MODE);
3595 #endif
3596 }
3597
3598 #ifndef PERL_DISABLE_PMC
3599 STATIC PerlIO *
3600 S_doopen_pm(pTHX_ SV *name)
3601 {
3602     STRLEN namelen;
3603     const char *p = SvPV_const(name, namelen);
3604
3605     PERL_ARGS_ASSERT_DOOPEN_PM;
3606
3607     /* check the name before trying for the .pmc name to avoid the
3608      * warning referring to the .pmc which the user probably doesn't
3609      * know or care about
3610      */
3611     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3612         return NULL;
3613
3614     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3615         SV *const pmcsv = sv_newmortal();
3616         Stat_t pmcstat;
3617
3618         SvSetSV_nosteal(pmcsv,name);
3619         sv_catpvs(pmcsv, "c");
3620
3621         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3622             return check_type_and_open(pmcsv);
3623     }
3624     return check_type_and_open(name);
3625 }
3626 #else
3627 #  define doopen_pm(name) check_type_and_open(name)
3628 #endif /* !PERL_DISABLE_PMC */
3629
3630 /* require doesn't search for absolute names, or when the name is
3631    explicity relative the current directory */
3632 PERL_STATIC_INLINE bool
3633 S_path_is_searchable(const char *name)
3634 {
3635     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3636
3637     if (PERL_FILE_IS_ABSOLUTE(name)
3638 #ifdef WIN32
3639         || (*name == '.' && ((name[1] == '/' ||
3640                              (name[1] == '.' && name[2] == '/'))
3641                          || (name[1] == '\\' ||
3642                              ( name[1] == '.' && name[2] == '\\')))
3643             )
3644 #else
3645         || (*name == '.' && (name[1] == '/' ||
3646                              (name[1] == '.' && name[2] == '/')))
3647 #endif
3648          )
3649     {
3650         return FALSE;
3651     }
3652     else
3653         return TRUE;
3654 }
3655
3656
3657 /* also used for: pp_dofile() */
3658
3659 PP(pp_require)
3660 {
3661     dSP;
3662     PERL_CONTEXT *cx;
3663     SV *sv;
3664     const char *name;
3665     STRLEN len;
3666     char * unixname;
3667     STRLEN unixlen;
3668 #ifdef VMS
3669     int vms_unixname = 0;
3670     char *unixdir;
3671 #endif
3672     const char *tryname = NULL;
3673     SV *namesv = NULL;
3674     const I32 gimme = GIMME_V;
3675     int filter_has_file = 0;
3676     PerlIO *tryrsfp = NULL;
3677     SV *filter_cache = NULL;
3678     SV *filter_state = NULL;
3679     SV *filter_sub = NULL;
3680     SV *hook_sv = NULL;
3681     SV *encoding;
3682     OP *op;
3683     int saved_errno;
3684     bool path_searchable;
3685
3686     sv = POPs;
3687     SvGETMAGIC(sv);
3688     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3689         sv = sv_2mortal(new_version(sv));
3690         if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3691             upg_version(PL_patchlevel, TRUE);
3692         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3693             if ( vcmp(sv,PL_patchlevel) <= 0 )
3694                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3695                     SVfARG(sv_2mortal(vnormal(sv))),
3696                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3697                 );
3698         }
3699         else {
3700             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3701                 I32 first = 0;
3702                 AV *lav;
3703                 SV * const req = SvRV(sv);
3704                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3705
3706                 /* get the left hand term */
3707                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3708
3709                 first  = SvIV(*av_fetch(lav,0,0));
3710                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3711                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3712                     || av_tindex(lav) > 1            /* FP with > 3 digits */
3713                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3714                    ) {
3715                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3716                         "%"SVf", stopped",
3717                         SVfARG(sv_2mortal(vnormal(req))),
3718                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3719                     );
3720                 }
3721                 else { /* probably 'use 5.10' or 'use 5.8' */
3722                     SV *hintsv;
3723                     I32 second = 0;
3724
3725                     if (av_tindex(lav)>=1)
3726                         second = SvIV(*av_fetch(lav,1,0));
3727
3728                     second /= second >= 600  ? 100 : 10;
3729                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3730                                            (int)first, (int)second);
3731                     upg_version(hintsv, TRUE);
3732
3733                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3734                         "--this is only %"SVf", stopped",
3735                         SVfARG(sv_2mortal(vnormal(req))),
3736                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3737                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3738                     );
3739                 }
3740             }
3741         }
3742
3743         RETPUSHYES;
3744     }
3745     if (!SvOK(sv))
3746         DIE(aTHX_ "Missing or undefined argument to require");
3747     name = SvPV_nomg_const(sv, len);
3748     if (!(name && len > 0 && *name))
3749         DIE(aTHX_ "Missing or undefined argument to require");
3750
3751     if (!IS_SAFE_PATHNAME(name, len, "require")) {
3752         DIE(aTHX_ "Can't locate %s:   %s",
3753             pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3754                       SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3755             Strerror(ENOENT));
3756     }
3757     TAINT_PROPER("require");
3758
3759     path_searchable = path_is_searchable(name);
3760
3761 #ifdef VMS
3762     /* The key in the %ENV hash is in the syntax of file passed as the argument
3763      * usually this is in UNIX format, but sometimes in VMS format, which
3764      * can result in a module being pulled in more than once.
3765      * To prevent this, the key must be stored in UNIX format if the VMS
3766      * name can be translated to UNIX.
3767      */
3768     
3769     if ((unixname =
3770           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3771          != NULL) {
3772         unixlen = strlen(unixname);
3773         vms_unixname = 1;
3774     }
3775     else
3776 #endif
3777     {
3778         /* if not VMS or VMS name can not be translated to UNIX, pass it
3779          * through.
3780          */
3781         unixname = (char *) name;
3782         unixlen = len;
3783     }
3784     if (PL_op->op_type == OP_REQUIRE) {
3785         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3786                                           unixname, unixlen, 0);
3787         if ( svp ) {
3788             if (*svp != &PL_sv_undef)
3789                 RETPUSHYES;
3790             else
3791                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3792                             "Compilation failed in require", unixname);
3793         }
3794     }
3795
3796     LOADING_FILE_PROBE(unixname);
3797
3798     /* prepare to compile file */
3799
3800     if (!path_searchable) {
3801         /* At this point, name is SvPVX(sv)  */
3802         tryname = name;
3803         tryrsfp = doopen_pm(sv);
3804     }
3805     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3806         AV * const ar = GvAVn(PL_incgv);
3807         SSize_t i;
3808 #ifdef VMS
3809         if (vms_unixname)
3810 #endif
3811         {
3812             SV *nsv = sv;
3813             namesv = newSV_type(SVt_PV);
3814             for (i = 0; i <= AvFILL(ar); i++) {
3815                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3816
3817                 SvGETMAGIC(dirsv);
3818                 if (SvROK(dirsv)) {
3819                     int count;
3820                     SV **svp;
3821                     SV *loader = dirsv;
3822
3823                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3824                         && !SvOBJECT(SvRV(loader)))
3825                     {
3826                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3827                         SvGETMAGIC(loader);
3828                     }
3829
3830                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3831                                    PTR2UV(SvRV(dirsv)), name);
3832                     tryname = SvPVX_const(namesv);
3833                     tryrsfp = NULL;
3834
3835                     if (SvPADTMP(nsv)) {
3836                         nsv = sv_newmortal();
3837                         SvSetSV_nosteal(nsv,sv);
3838                     }
3839
3840                     ENTER_with_name("call_INC");
3841                     SAVETMPS;
3842                     EXTEND(SP, 2);
3843
3844                     PUSHMARK(SP);
3845                     PUSHs(dirsv);
3846                     PUSHs(nsv);
3847                     PUTBACK;
3848                     if (SvGMAGICAL(loader)) {
3849                         SV *l = sv_newmortal();
3850                         sv_setsv_nomg(l, loader);
3851                         loader = l;
3852                     }
3853                     if (sv_isobject(loader))
3854                         count = call_method("INC", G_ARRAY);
3855                     else
3856                         count = call_sv(loader, G_ARRAY);
3857                     SPAGAIN;
3858
3859                     if (count > 0) {
3860                         int i = 0;
3861                         SV *arg;
3862
3863                         SP -= count - 1;
3864                         arg = SP[i++];
3865
3866                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3867                             && !isGV_with_GP(SvRV(arg))) {
3868                             filter_cache = SvRV(arg);
3869
3870                             if (i < count) {
3871                                 arg = SP[i++];
3872                             }
3873                         }
3874
3875                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3876                             arg = SvRV(arg);
3877                         }
3878
3879                         if (isGV_with_GP(arg)) {
3880                             IO * const io = GvIO((const GV *)arg);
3881
3882                             ++filter_has_file;
3883
3884                             if (io) {
3885                                 tryrsfp = IoIFP(io);
3886                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3887                                     PerlIO_close(IoOFP(io));
3888                                 }
3889                                 IoIFP(io) = NULL;
3890                                 IoOFP(io) = NULL;
3891                             }
3892
3893                             if (i < count) {
3894                                 arg = SP[i++];
3895                             }
3896                         }
3897
3898                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3899                             filter_sub = arg;
3900                             SvREFCNT_inc_simple_void_NN(filter_sub);
3901
3902                             if (i < count) {
3903                                 filter_state = SP[i];
3904                                 SvREFCNT_inc_simple_void(filter_state);
3905                             }
3906                         }
3907
3908                         if (!tryrsfp && (filter_cache || filter_sub)) {
3909                             tryrsfp = PerlIO_open(BIT_BUCKET,
3910                                                   PERL_SCRIPT_MODE);
3911                         }
3912                         SP--;
3913                     }
3914
3915                     /* FREETMPS may free our filter_cache */
3916                     SvREFCNT_inc_simple_void(filter_cache);
3917
3918                     PUTBACK;
3919                     FREETMPS;
3920                     LEAVE_with_name("call_INC");
3921
3922                     /* Now re-mortalize it. */
3923                     sv_2mortal(filter_cache);
3924
3925                     /* Adjust file name if the hook has set an %INC entry.
3926                        This needs to happen after the FREETMPS above.  */
3927                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3928                     if (svp)
3929                         tryname = SvPV_nolen_const(*svp);
3930
3931                     if (tryrsfp) {
3932                         hook_sv = dirsv;
3933                         break;
3934                     }
3935
3936                     filter_has_file = 0;
3937                     filter_cache = NULL;
3938                     if (filter_state) {
3939                         SvREFCNT_dec_NN(filter_state);
3940                         filter_state = NULL;
3941                     }
3942                     if (filter_sub) {
3943                         SvREFCNT_dec_NN(filter_sub);
3944                         filter_sub = NULL;
3945                     }
3946                 }
3947                 else {
3948                   if (path_searchable) {
3949                     const char *dir;
3950                     STRLEN dirlen;
3951
3952                     if (SvOK(dirsv)) {
3953                         dir = SvPV_nomg_const(dirsv, dirlen);
3954                     } else {
3955                         dir = "";
3956                         dirlen = 0;
3957                     }
3958
3959                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3960                         continue;
3961 #ifdef VMS
3962                     if ((unixdir =
3963                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3964                          == NULL)
3965                         continue;
3966                     sv_setpv(namesv, unixdir);
3967                     sv_catpv(namesv, unixname);
3968 #else
3969 #  ifdef __SYMBIAN32__
3970                     if (PL_origfilename[0] &&
3971                         PL_origfilename[1] == ':' &&
3972                         !(dir[0] && dir[1] == ':'))
3973                         Perl_sv_setpvf(aTHX_ namesv,
3974                                        "%c:%s\\%s",
3975                                        PL_origfilename[0],
3976                                        dir, name);
3977                     else
3978                         Perl_sv_setpvf(aTHX_ namesv,
3979                                        "%s\\%s",
3980                                        dir, name);
3981 #  else
3982                     /* The equivalent of                    
3983                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3984                        but without the need to parse the format string, or
3985                        call strlen on either pointer, and with the correct
3986                        allocation up front.  */
3987                     {
3988                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3989
3990                         memcpy(tmp, dir, dirlen);
3991                         tmp +=dirlen;
3992
3993                         /* Avoid '<dir>//<file>' */
3994                         if (!dirlen || *(tmp-1) != '/') {
3995                             *tmp++ = '/';
3996                         } else {
3997                             /* So SvCUR_set reports the correct length below */
3998                             dirlen--;
3999                         }
4000
4001                         /* name came from an SV, so it will have a '\0' at the
4002                            end that we can copy as part of this memcpy().  */
4003                         memcpy(tmp, name, len + 1);
4004
4005                         SvCUR_set(namesv, dirlen + len + 1);
4006                         SvPOK_on(namesv);
4007                     }
4008 #  endif
4009 #endif
4010                     TAINT_PROPER("require");
4011                     tryname = SvPVX_const(namesv);
4012                     tryrsfp = doopen_pm(namesv);
4013                     if (tryrsfp) {
4014                         if (tryname[0] == '.' && tryname[1] == '/') {
4015                             ++tryname;
4016                             while (*++tryname == '/') {}
4017                         }
4018                         break;
4019                     }
4020                     else if (errno == EMFILE || errno == EACCES) {
4021                         /* no point in trying other paths if out of handles;
4022                          * on the other hand, if we couldn't open one of the
4023                          * files, then going on with the search could lead to
4024                          * unexpected results; see perl #113422
4025                          */
4026                         break;
4027                     }
4028                   }
4029                 }
4030             }
4031         }
4032     }
4033     saved_errno = errno; /* sv_2mortal can realloc things */
4034     sv_2mortal(namesv);
4035     if (!tryrsfp) {
4036         if (PL_op->op_type == OP_REQUIRE) {
4037             if(saved_errno == EMFILE || saved_errno == EACCES) {
4038                 /* diag_listed_as: Can't locate %s */
4039                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(saved_errno));
4040             } else {
4041                 if (namesv) {                   /* did we lookup @INC? */
4042                     AV * const ar = GvAVn(PL_incgv);
4043                     SSize_t i;
4044                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
4045                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4046                     for (i = 0; i <= AvFILL(ar); i++) {
4047                         sv_catpvs(inc, " ");
4048                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4049                     }
4050                     if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4051                         const char *c, *e = name + len - 3;
4052                         sv_catpv(msg, " (you may need to install the ");
4053                         for (c = name; c < e; c++) {
4054                             if (*c == '/') {
4055                                 sv_catpvs(msg, "::");
4056                             }
4057                             else {
4058                                 sv_catpvn(msg, c, 1);
4059                             }
4060                         }
4061                         sv_catpv(msg, " module)");
4062                     }
4063                     else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4064                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4065                     }
4066                     else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4067                         sv_catpv(msg, " (did you run h2ph?)");
4068                     }
4069
4070                     /* diag_listed_as: Can't locate %s */
4071                     DIE(aTHX_
4072                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4073                         name, msg, inc);
4074                 }
4075             }
4076             DIE(aTHX_ "Can't locate %s", name);
4077         }
4078
4079         CLEAR_ERRSV();
4080         RETPUSHUNDEF;
4081     }
4082     else
4083         SETERRNO(0, SS_NORMAL);
4084
4085     /* Assume success here to prevent recursive requirement. */
4086     /* name is never assigned to again, so len is still strlen(name)  */
4087     /* Check whether a hook in @INC has already filled %INC */
4088     if (!hook_sv) {
4089         (void)hv_store(GvHVn(PL_incgv),
4090                        unixname, unixlen, newSVpv(tryname,0),0);
4091     } else {
4092         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4093         if (!svp)
4094             (void)hv_store(GvHVn(PL_incgv),
4095                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4096     }
4097
4098     ENTER_with_name("eval");
4099     SAVETMPS;
4100     SAVECOPFILE_FREE(&PL_compiling);
4101     CopFILE_set(&PL_compiling, tryname);
4102     lex_start(NULL, tryrsfp, 0);
4103
4104     if (filter_sub || filter_cache) {
4105         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4106            than hanging another SV from it. In turn, filter_add() optionally
4107            takes the SV to use as the filter (or creates a new SV if passed
4108            NULL), so simply pass in whatever value filter_cache has.  */
4109         SV * const fc = filter_cache ? newSV(0) : NULL;
4110         SV *datasv;
4111         if (fc) sv_copypv(fc, filter_cache);
4112         datasv = filter_add(S_run_user_filter, fc);
4113         IoLINES(datasv) = filter_has_file;
4114         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4115         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4116     }
4117
4118     /* switch to eval mode */
4119     PUSHBLOCK(cx, CXt_EVAL, SP);
4120     PUSHEVAL(cx, name);
4121     cx->blk_eval.retop = PL_op->op_next;
4122
4123     SAVECOPLINE(&PL_compiling);
4124     CopLINE_set(&PL_compiling, 0);
4125
4126     PUTBACK;
4127
4128     /* Store and reset encoding. */
4129     encoding = PL_encoding;
4130     PL_encoding = NULL;
4131
4132     if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4133         op = DOCATCH(PL_eval_start);
4134     else
4135         op = PL_op->op_next;
4136
4137     /* Restore encoding. */
4138     PL_encoding = encoding;
4139
4140     LOADED_FILE_PROBE(unixname);
4141
4142     return op;
4143 }
4144
4145 /* This is a op added to hold the hints hash for
4146    pp_entereval. The hash can be modified by the code
4147    being eval'ed, so we return a copy instead. */
4148
4149 PP(pp_hintseval)
4150 {
4151     dSP;
4152     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4153     RETURN;
4154 }
4155
4156
4157 PP(pp_entereval)
4158 {
4159     dSP;
4160     PERL_CONTEXT *cx;
4161     SV *sv;
4162     const I32 gimme = GIMME_V;
4163     const U32 was = PL_breakable_sub_gen;
4164     char tbuf[TYPE_DIGITS(long) + 12];
4165     bool saved_delete = FALSE;
4166     char *tmpbuf = tbuf;
4167     STRLEN len;
4168     CV* runcv;
4169     U32 seq, lex_flags = 0;
4170     HV *saved_hh = NULL;
4171     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4172
4173     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4174         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4175     }
4176     else if (PL_hints & HINT_LOCALIZE_HH || (
4177                 PL_op->op_private & OPpEVAL_COPHH
4178              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4179             )) {
4180         saved_hh = cop_hints_2hv(PL_curcop, 0);
4181         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4182     }
4183     sv = POPs;
4184     if (!SvPOK(sv)) {
4185         /* make sure we've got a plain PV (no overload etc) before testing
4186          * for taint. Making a copy here is probably overkill, but better
4187          * safe than sorry */
4188         STRLEN len;
4189         const char * const p = SvPV_const(sv, len);
4190
4191         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4192         lex_flags |= LEX_START_COPIED;
4193
4194         if (bytes && SvUTF8(sv))
4195             SvPVbyte_force(sv, len);
4196     }
4197     else if (bytes && SvUTF8(sv)) {
4198         /* Don't modify someone else's scalar */
4199         STRLEN len;
4200         sv = newSVsv(sv);
4201         (void)sv_2mortal(sv);
4202         SvPVbyte_force(sv,len);
4203         lex_flags |= LEX_START_COPIED;
4204     }
4205
4206     TAINT_IF(SvTAINTED(sv));
4207     TAINT_PROPER("eval");
4208
4209     ENTER_with_name("eval");
4210     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4211                            ? LEX_IGNORE_UTF8_HINTS
4212                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4213                         )
4214              );
4215     SAVETMPS;
4216
4217     /* switch to eval mode */
4218
4219     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4220         SV * const temp_sv = sv_newmortal();
4221         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4222                        (unsigned long)++PL_evalseq,
4223                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4224         tmpbuf = SvPVX(temp_sv);
4225         len = SvCUR(temp_sv);
4226     }
4227     else
4228         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4229     SAVECOPFILE_FREE(&PL_compiling);
4230     CopFILE_set(&PL_compiling, tmpbuf+2);
4231     SAVECOPLINE(&PL_compiling);
4232     CopLINE_set(&PL_compiling, 1);
4233     /* special case: an eval '' executed within the DB package gets lexically
4234      * placed in the first non-DB CV rather than the current CV - this
4235      * allows the debugger to execute code, find lexicals etc, in the
4236      * scope of the code being debugged. Passing &seq gets find_runcv
4237      * to do the dirty work for us */
4238     runcv = find_runcv(&seq);
4239
4240     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4241     PUSHEVAL(cx, 0);
4242     cx->blk_eval.retop = PL_op->op_next;
4243
4244     /* prepare to compile string */
4245
4246     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4247         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4248     else {
4249         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4250            deleting the eval's FILEGV from the stash before gv_check() runs
4251            (i.e. before run-time proper). To work around the coredump that
4252            ensues, we always turn GvMULTI_on for any globals that were
4253            introduced within evals. See force_ident(). GSAR 96-10-12 */
4254         char *const safestr = savepvn(tmpbuf, len);
4255         SAVEDELETE(PL_defstash, safestr, len);
4256         saved_delete = TRUE;
4257     }
4258     
4259     PUTBACK;
4260
4261     if (doeval(gimme, runcv, seq, saved_hh)) {
4262         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4263             ? (PERLDB_LINE || PERLDB_SAVESRC)
4264             :  PERLDB_SAVESRC_NOSUBS) {
4265             /* Retain the filegv we created.  */
4266         } else if (!saved_delete) {
4267             char *const safestr = savepvn(tmpbuf, len);
4268             SAVEDELETE(PL_defstash, safestr, len);
4269         }
4270         return DOCATCH(PL_eval_start);
4271     } else {
4272         /* We have already left the scope set up earlier thanks to the LEAVE
4273            in doeval().  */
4274         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4275             ? (PERLDB_LINE || PERLDB_SAVESRC)
4276             :  PERLDB_SAVESRC_INVALID) {
4277             /* Retain the filegv we created.  */
4278         } else if (!saved_delete) {
4279             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4280         }
4281         return PL_op->op_next;
4282     }
4283 }
4284
4285 PP(pp_leaveeval)
4286 {
4287     dSP;
4288     SV **newsp;
4289     PMOP *newpm;
4290     I32 gimme;
4291     PERL_CONTEXT *cx;
4292     OP *retop;
4293     const U8 save_flags = PL_op -> op_flags;
4294     I32 optype;
4295     SV *namesv;
4296     CV *evalcv;
4297
4298     PERL_ASYNC_CHECK();
4299     POPBLOCK(cx,newpm);
4300     POPEVAL(cx);
4301     namesv = cx->blk_eval.old_namesv;
4302     retop = cx->blk_eval.retop;
4303     evalcv = cx->blk_eval.cv;
4304
4305     SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
4306                                 gimme, SVs_TEMP, FALSE);
4307     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4308
4309 #ifdef DEBUGGING
4310     assert(CvDEPTH(evalcv) == 1);
4311 #endif
4312     CvDEPTH(evalcv) = 0;
4313
4314     if (optype == OP_REQUIRE &&
4315         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4316     {
4317         /* Unassume the success we assumed earlier. */
4318         (void)hv_delete(GvHVn(PL_incgv),
4319                         SvPVX_const(namesv),
4320                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4321                         G_DISCARD);
4322         Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4323         NOT_REACHED; /* NOTREACHED */
4324         /* die_unwind() did LEAVE, or we won't be here */
4325     }
4326     else {
4327         LEAVE_with_name("eval");
4328         if (!(save_flags & OPf_SPECIAL)) {
4329             CLEAR_ERRSV();
4330         }
4331     }
4332
4333     RETURNOP(retop);
4334 }
4335
4336 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4337    close to the related Perl_create_eval_scope.  */
4338 void
4339 Perl_delete_eval_scope(pTHX)
4340 {
4341     SV **newsp;
4342     PMOP *newpm;
4343     I32 gimme;
4344     PERL_CONTEXT *cx;
4345     I32 optype;
4346         
4347     POPBLOCK(cx,newpm);
4348     POPEVAL(cx);
4349     PL_curpm = newpm;
4350     LEAVE_with_name("eval_scope");
4351     PERL_UNUSED_VAR(newsp);
4352     PERL_UNUSED_VAR(gimme);
4353     PERL_UNUSED_VAR(optype);
4354 }
4355
4356 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4357    also needed by Perl_fold_constants.  */
4358 PERL_CONTEXT *
4359 Perl_create_eval_scope(pTHX_ U32 flags)
4360 {
4361     PERL_CONTEXT *cx;
4362     const I32 gimme = GIMME_V;
4363         
4364     ENTER_with_name("eval_scope");
4365     SAVETMPS;
4366
4367     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4368     PUSHEVAL(cx, 0);
4369
4370     PL_in_eval = EVAL_INEVAL;
4371     if (flags & G_KEEPERR)
4372         PL_in_eval |= EVAL_KEEPERR;
4373     else
4374         CLEAR_ERRSV();
4375     if (flags & G_FAKINGEVAL) {
4376         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4377     }
4378     return cx;
4379 }
4380     
4381 PP(pp_entertry)
4382 {
4383     PERL_CONTEXT * const cx = create_eval_scope(0);
4384     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4385     return DOCATCH(PL_op->op_next);
4386 }
4387
4388 PP(pp_leavetry)
4389 {
4390     dSP;
4391     SV **newsp;
4392     PMOP *newpm;
4393     I32 gimme;
4394     PERL_CONTEXT *cx;
4395     I32 optype;
4396
4397     PERL_ASYNC_CHECK();
4398     POPBLOCK(cx,newpm);
4399     POPEVAL(cx);
4400     PERL_UNUSED_VAR(optype);
4401
4402     SP = leave_common(newsp, SP, newsp, gimme,
4403                                SVs_PADTMP|SVs_TEMP, FALSE);
4404     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4405
4406     LEAVE_with_name("eval_scope");
4407     CLEAR_ERRSV();
4408     RETURN;
4409 }
4410
4411 PP(pp_entergiven)
4412 {
4413     dSP;
4414     PERL_CONTEXT *cx;
4415     const I32 gimme = GIMME_V;
4416     
4417     ENTER_with_name("given");
4418     SAVETMPS;
4419
4420     if (PL_op->op_targ) {
4421         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4422         SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4423         PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4424     }
4425     else {
4426         SAVE_DEFSV;
4427         DEFSV_set(POPs);
4428     }
4429
4430     PUSHBLOCK(cx, CXt_GIVEN, SP);
4431     PUSHGIVEN(cx);
4432
4433     RETURN;
4434 }
4435
4436 PP(pp_leavegiven)
4437 {
4438     dSP;
4439     PERL_CONTEXT *cx;
4440     I32 gimme;
4441     SV **newsp;
4442     PMOP *newpm;
4443     PERL_UNUSED_CONTEXT;
4444
4445     POPBLOCK(cx,newpm);
4446     assert(CxTYPE(cx) == CXt_GIVEN);
4447
4448     SP = leave_common(newsp, SP, newsp, gimme,
4449                                SVs_PADTMP|SVs_TEMP, FALSE);
4450     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4451
4452     LEAVE_with_name("given");
4453     RETURN;
4454 }
4455
4456 /* Helper routines used by pp_smartmatch */
4457 STATIC PMOP *
4458 S_make_matcher(pTHX_ REGEXP *re)
4459 {
4460     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4461
4462     PERL_ARGS_ASSERT_MAKE_MATCHER;
4463
4464     PM_SETRE(matcher, ReREFCNT_inc(re));
4465
4466     SAVEFREEOP((OP *) matcher);
4467     ENTER_with_name("matcher"); SAVETMPS;
4468     SAVEOP();
4469     return matcher;
4470 }
4471
4472 STATIC bool
4473 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4474 {
4475     dSP;
4476
4477     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4478     
4479     PL_op = (OP *) matcher;
4480     XPUSHs(sv);
4481     PUTBACK;
4482     (void) Perl_pp_match(aTHX);
4483     SPAGAIN;
4484     return (SvTRUEx(POPs));
4485 }
4486
4487 STATIC void
4488 S_destroy_matcher(pTHX_ PMOP *matcher)
4489 {
4490     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4491     PERL_UNUSED_ARG(matcher);
4492
4493     FREETMPS;
4494     LEAVE_with_name("matcher");
4495 }
4496
4497 /* Do a smart match */
4498 PP(pp_smartmatch)
4499 {
4500     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4501     return do_smartmatch(NULL, NULL, 0);
4502 }