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