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