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