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