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