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