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