This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pp_ctl.c:pp_goto: Don’t repeat yourself
[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         }
3048     }
3049     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
3050         label       = cPVOP->op_pv;
3051         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
3052         label_len   = strlen(label);
3053     }
3054     if (!(do_dump || label_len)) DIE(aTHX_ must_have_label);
3055
3056     PERL_ASYNC_CHECK();
3057
3058     if (label_len) {
3059         OP *gotoprobe = NULL;
3060         bool leaving_eval = FALSE;
3061         bool in_block = FALSE;
3062         PERL_CONTEXT *last_eval_cx = NULL;
3063
3064         /* find label */
3065
3066         PL_lastgotoprobe = NULL;
3067         *enterops = 0;
3068         for (ix = cxstack_ix; ix >= 0; ix--) {
3069             cx = &cxstack[ix];
3070             switch (CxTYPE(cx)) {
3071             case CXt_EVAL:
3072                 leaving_eval = TRUE;
3073                 if (!CxTRYBLOCK(cx)) {
3074                     gotoprobe = (last_eval_cx ?
3075                                 last_eval_cx->blk_eval.old_eval_root :
3076                                 PL_eval_root);
3077                     last_eval_cx = cx;
3078                     break;
3079                 }
3080                 /* else fall through */
3081             case CXt_LOOP_LAZYIV:
3082             case CXt_LOOP_LAZYSV:
3083             case CXt_LOOP_FOR:
3084             case CXt_LOOP_PLAIN:
3085             case CXt_GIVEN:
3086             case CXt_WHEN:
3087                 gotoprobe = cx->blk_oldcop->op_sibling;
3088                 break;
3089             case CXt_SUBST:
3090                 continue;
3091             case CXt_BLOCK:
3092                 if (ix) {
3093                     gotoprobe = cx->blk_oldcop->op_sibling;
3094                     in_block = TRUE;
3095                 } else
3096                     gotoprobe = PL_main_root;
3097                 break;
3098             case CXt_SUB:
3099                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3100                     gotoprobe = CvROOT(cx->blk_sub.cv);
3101                     break;
3102                 }
3103                 /* FALL THROUGH */
3104             case CXt_FORMAT:
3105             case CXt_NULL:
3106                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3107             default:
3108                 if (ix)
3109                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3110                         CxTYPE(cx), (long) ix);
3111                 gotoprobe = PL_main_root;
3112                 break;
3113             }
3114             if (gotoprobe) {
3115                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3116                                     enterops, enterops + GOTO_DEPTH);
3117                 if (retop)
3118                     break;
3119                 if (gotoprobe->op_sibling &&
3120                         gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3121                         gotoprobe->op_sibling->op_sibling) {
3122                     retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3123                                         label, label_len, label_flags, enterops,
3124                                         enterops + GOTO_DEPTH);
3125                     if (retop)
3126                         break;
3127                 }
3128             }
3129             PL_lastgotoprobe = gotoprobe;
3130         }
3131         if (!retop)
3132             DIE(aTHX_ "Can't find label %"SVf,
3133                             SVfARG(newSVpvn_flags(label, label_len,
3134                                         SVs_TEMP | label_flags)));
3135
3136         /* if we're leaving an eval, check before we pop any frames
3137            that we're not going to punt, otherwise the error
3138            won't be caught */
3139
3140         if (leaving_eval && *enterops && enterops[1]) {
3141             I32 i;
3142             for (i = 1; enterops[i]; i++)
3143                 if (enterops[i]->op_type == OP_ENTERITER)
3144                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3145         }
3146
3147         if (*enterops && enterops[1]) {
3148             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3149             if (enterops[i])
3150                 deprecate("\"goto\" to jump into a construct");
3151         }
3152
3153         /* pop unwanted frames */
3154
3155         if (ix < cxstack_ix) {
3156             I32 oldsave;
3157
3158             if (ix < 0)
3159                 ix = 0;
3160             dounwind(ix);
3161             TOPBLOCK(cx);
3162             oldsave = PL_scopestack[PL_scopestack_ix];
3163             LEAVE_SCOPE(oldsave);
3164         }
3165
3166         /* push wanted frames */
3167
3168         if (*enterops && enterops[1]) {
3169             OP * const oldop = PL_op;
3170             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3171             for (; enterops[ix]; ix++) {
3172                 PL_op = enterops[ix];
3173                 /* Eventually we may want to stack the needed arguments
3174                  * for each op.  For now, we punt on the hard ones. */
3175                 if (PL_op->op_type == OP_ENTERITER)
3176                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3177                 PL_op->op_ppaddr(aTHX);
3178             }
3179             PL_op = oldop;
3180         }
3181     }
3182
3183     if (do_dump) {
3184 #ifdef VMS
3185         if (!retop) retop = PL_main_start;
3186 #endif
3187         PL_restartop = retop;
3188         PL_do_undump = TRUE;
3189
3190         my_unexec();
3191
3192         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3193         PL_do_undump = FALSE;
3194     }
3195
3196     RETURNOP(retop);
3197 }
3198
3199 PP(pp_exit)
3200 {
3201     dVAR;
3202     dSP;
3203     I32 anum;
3204
3205     if (MAXARG < 1)
3206         anum = 0;
3207     else if (!TOPs) {
3208         anum = 0; (void)POPs;
3209     }
3210     else {
3211         anum = SvIVx(POPs);
3212 #ifdef VMS
3213         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3214             anum = 0;
3215         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3216 #endif
3217     }
3218     PL_exit_flags |= PERL_EXIT_EXPECTED;
3219 #ifdef PERL_MAD
3220     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3221     if (anum || !(PL_minus_c && PL_madskills))
3222         my_exit(anum);
3223 #else
3224     my_exit(anum);
3225 #endif
3226     PUSHs(&PL_sv_undef);
3227     RETURN;
3228 }
3229
3230 /* Eval. */
3231
3232 STATIC void
3233 S_save_lines(pTHX_ AV *array, SV *sv)
3234 {
3235     const char *s = SvPVX_const(sv);
3236     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3237     I32 line = 1;
3238
3239     PERL_ARGS_ASSERT_SAVE_LINES;
3240
3241     while (s && s < send) {
3242         const char *t;
3243         SV * const tmpstr = newSV_type(SVt_PVMG);
3244
3245         t = (const char *)memchr(s, '\n', send - s);
3246         if (t)
3247             t++;
3248         else
3249             t = send;
3250
3251         sv_setpvn(tmpstr, s, t - s);
3252         av_store(array, line++, tmpstr);
3253         s = t;
3254     }
3255 }
3256
3257 /*
3258 =for apidoc docatch
3259
3260 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3261
3262 0 is used as continue inside eval,
3263
3264 3 is used for a die caught by an inner eval - continue inner loop
3265
3266 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3267 establish a local jmpenv to handle exception traps.
3268
3269 =cut
3270 */
3271 STATIC OP *
3272 S_docatch(pTHX_ OP *o)
3273 {
3274     dVAR;
3275     int ret;
3276     OP * const oldop = PL_op;
3277     dJMPENV;
3278
3279 #ifdef DEBUGGING
3280     assert(CATCH_GET == TRUE);
3281 #endif
3282     PL_op = o;
3283
3284     JMPENV_PUSH(ret);
3285     switch (ret) {
3286     case 0:
3287         assert(cxstack_ix >= 0);
3288         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3289         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3290  redo_body:
3291         CALLRUNOPS(aTHX);
3292         break;
3293     case 3:
3294         /* die caught by an inner eval - continue inner loop */
3295         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3296             PL_restartjmpenv = NULL;
3297             PL_op = PL_restartop;
3298             PL_restartop = 0;
3299             goto redo_body;
3300         }
3301         /* FALL THROUGH */
3302     default:
3303         JMPENV_POP;
3304         PL_op = oldop;
3305         JMPENV_JUMP(ret);
3306         /* NOTREACHED */
3307     }
3308     JMPENV_POP;
3309     PL_op = oldop;
3310     return NULL;
3311 }
3312
3313 /* James Bond: Do you expect me to talk?
3314    Auric Goldfinger: No, Mr. Bond. I expect you to die.
3315
3316    This code is an ugly hack, doesn't work with lexicals in subroutines that are
3317    called more than once, and is only used by regcomp.c, for (?{}) blocks.
3318
3319    Currently it is not used outside the core code. Best if it stays that way.
3320
3321    Hence it's now deprecated, and will be removed.
3322 */
3323 OP *
3324 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
3325 /* sv Text to convert to OP tree. */
3326 /* startop op_free() this to undo. */
3327 /* code Short string id of the caller. */
3328 {
3329     PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3330     return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3331 }
3332
3333 /* Don't use this. It will go away without warning once the regexp engine is
3334    refactored not to use it.  */
3335 OP *
3336 Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3337                               PAD **padp)
3338 {
3339     dVAR; dSP;                          /* Make POPBLOCK work. */
3340     PERL_CONTEXT *cx;
3341     SV **newsp;
3342     I32 gimme = G_VOID;
3343     I32 optype;
3344     OP dummy;
3345     char tbuf[TYPE_DIGITS(long) + 12 + 10];
3346     char *tmpbuf = tbuf;
3347     char *safestr;
3348     int runtime;
3349     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
3350     STRLEN len;
3351     bool need_catch;
3352
3353     PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
3354
3355     ENTER_with_name("eval");
3356     lex_start(sv, NULL, LEX_START_SAME_FILTER);
3357     SAVETMPS;
3358     /* switch to eval mode */
3359
3360     if (IN_PERL_COMPILETIME) {
3361         SAVECOPSTASH_FREE(&PL_compiling);
3362         CopSTASH_set(&PL_compiling, PL_curstash);
3363     }
3364     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3365         SV * const sv = sv_newmortal();
3366         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3367                        code, (unsigned long)++PL_evalseq,
3368                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3369         tmpbuf = SvPVX(sv);
3370         len = SvCUR(sv);
3371     }
3372     else
3373         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3374                           (unsigned long)++PL_evalseq);
3375     SAVECOPFILE_FREE(&PL_compiling);
3376     CopFILE_set(&PL_compiling, tmpbuf+2);
3377     SAVECOPLINE(&PL_compiling);
3378     CopLINE_set(&PL_compiling, 1);
3379     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3380        deleting the eval's FILEGV from the stash before gv_check() runs
3381        (i.e. before run-time proper). To work around the coredump that
3382        ensues, we always turn GvMULTI_on for any globals that were
3383        introduced within evals. See force_ident(). GSAR 96-10-12 */
3384     safestr = savepvn(tmpbuf, len);
3385     SAVEDELETE(PL_defstash, safestr, len);
3386     SAVEHINTS();
3387 #ifdef OP_IN_REGISTER
3388     PL_opsave = op;
3389 #else
3390     SAVEVPTR(PL_op);
3391 #endif
3392
3393     /* we get here either during compilation, or via pp_regcomp at runtime */
3394     runtime = IN_PERL_RUNTIME;
3395     if (runtime)
3396     {
3397         runcv = find_runcv(NULL);
3398
3399         /* At run time, we have to fetch the hints from PL_curcop. */
3400         PL_hints = PL_curcop->cop_hints;
3401         if (PL_hints & HINT_LOCALIZE_HH) {
3402             /* SAVEHINTS created a new HV in PL_hintgv, which we
3403                need to GC */
3404             SvREFCNT_dec(GvHV(PL_hintgv));
3405             GvHV(PL_hintgv) =
3406              refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3407             hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3408         }
3409         SAVECOMPILEWARNINGS();
3410         PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3411         cophh_free(CopHINTHASH_get(&PL_compiling));
3412         /* XXX Does this need to avoid copying a label? */
3413         PL_compiling.cop_hints_hash
3414          = cophh_copy(PL_curcop->cop_hints_hash);
3415     }
3416
3417     PL_op = &dummy;
3418     PL_op->op_type = OP_ENTEREVAL;
3419     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
3420     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3421     PUSHEVAL(cx, 0);
3422     need_catch = CATCH_GET;
3423     CATCH_SET(TRUE);
3424
3425     if (runtime)
3426         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq, NULL);
3427     else
3428         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax, NULL);
3429     CATCH_SET(need_catch);
3430     POPBLOCK(cx,PL_curpm);
3431     POPEVAL(cx);
3432
3433     (*startop)->op_type = OP_NULL;
3434     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3435     /* XXX DAPM do this properly one year */
3436     *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3437     LEAVE_with_name("eval");
3438     if (IN_PERL_COMPILETIME)
3439         CopHINTS_set(&PL_compiling, PL_hints);
3440 #ifdef OP_IN_REGISTER
3441     op = PL_opsave;
3442 #endif
3443     PERL_UNUSED_VAR(newsp);
3444     PERL_UNUSED_VAR(optype);
3445
3446     return PL_eval_start;
3447 }
3448
3449
3450 /*
3451 =for apidoc find_runcv
3452
3453 Locate the CV corresponding to the currently executing sub or eval.
3454 If db_seqp is non_null, skip CVs that are in the DB package and populate
3455 *db_seqp with the cop sequence number at the point that the DB:: code was
3456 entered. (allows debuggers to eval in the scope of the breakpoint rather
3457 than in the scope of the debugger itself).
3458
3459 =cut
3460 */
3461
3462 CV*
3463 Perl_find_runcv(pTHX_ U32 *db_seqp)
3464 {
3465     dVAR;
3466     PERL_SI      *si;
3467
3468     if (db_seqp)
3469         *db_seqp = PL_curcop->cop_seq;
3470     for (si = PL_curstackinfo; si; si = si->si_prev) {
3471         I32 ix;
3472         for (ix = si->si_cxix; ix >= 0; ix--) {
3473             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3474             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3475                 CV * const cv = cx->blk_sub.cv;
3476                 /* skip DB:: code */
3477                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3478                     *db_seqp = cx->blk_oldcop->cop_seq;
3479                     continue;
3480                 }
3481                 return cv;
3482             }
3483             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3484                 return cx->blk_eval.cv;
3485         }
3486     }
3487     return PL_main_cv;
3488 }
3489
3490
3491 /* Run yyparse() in a setjmp wrapper. Returns:
3492  *   0: yyparse() successful
3493  *   1: yyparse() failed
3494  *   3: yyparse() died
3495  */
3496 STATIC int
3497 S_try_yyparse(pTHX_ int gramtype)
3498 {
3499     int ret;
3500     dJMPENV;
3501
3502     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3503     JMPENV_PUSH(ret);
3504     switch (ret) {
3505     case 0:
3506         ret = yyparse(gramtype) ? 1 : 0;
3507         break;
3508     case 3:
3509         break;
3510     default:
3511         JMPENV_POP;
3512         JMPENV_JUMP(ret);
3513         /* NOTREACHED */
3514     }
3515     JMPENV_POP;
3516     return ret;
3517 }
3518
3519
3520 /* Compile a require/do, an eval '', or a /(?{...})/.
3521  * In the last case, startop is non-null, and contains the address of
3522  * a pointer that should be set to the just-compiled code.
3523  * outside is the lexically enclosing CV (if any) that invoked us.
3524  * Returns a bool indicating whether the compile was successful; if so,
3525  * PL_eval_start contains the first op of the compiled ocde; otherwise,
3526  * pushes undef (also croaks if startop != NULL).
3527  */
3528
3529 /* This function is called from three places, sv_compile_2op, pp_require
3530  * and pp_entereval.  These can be distinguished as follows:
3531  *    sv_compile_2op - startop is non-null
3532  *    pp_require     - startop is null; saveop is not entereval
3533  *    pp_entereval   - startop is null; saveop is entereval
3534  */
3535
3536 STATIC bool
3537 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
3538 {
3539     dVAR; dSP;
3540     OP * const saveop = PL_op;
3541     COP * const oldcurcop = PL_curcop;
3542     bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3543     int yystatus;
3544     CV *evalcv;
3545
3546     PL_in_eval = (in_require
3547                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3548                   : EVAL_INEVAL);
3549
3550     PUSHMARK(SP);
3551
3552     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3553     CvEVAL_on(evalcv);
3554     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3555     cxstack[cxstack_ix].blk_eval.cv = evalcv;
3556     cxstack[cxstack_ix].blk_gimme = gimme;
3557
3558     CvOUTSIDE_SEQ(evalcv) = seq;
3559     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3560
3561     /* set up a scratch pad */
3562
3563     CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3564     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3565
3566
3567     if (!PL_madskills)
3568         SAVEMORTALIZESV(evalcv);        /* must remain until end of current statement */
3569
3570     /* make sure we compile in the right package */
3571
3572     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3573         SAVEGENERICSV(PL_curstash);
3574         PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop));
3575     }
3576     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3577     SAVESPTR(PL_beginav);
3578     PL_beginav = newAV();
3579     SAVEFREESV(PL_beginav);
3580     SAVESPTR(PL_unitcheckav);
3581     PL_unitcheckav = newAV();
3582     SAVEFREESV(PL_unitcheckav);
3583
3584 #ifdef PERL_MAD
3585     SAVEBOOL(PL_madskills);
3586     PL_madskills = 0;
3587 #endif
3588
3589     if (!startop) ENTER_with_name("evalcomp");
3590     SAVESPTR(PL_compcv);
3591     PL_compcv = evalcv;
3592
3593     /* try to compile it */
3594
3595     PL_eval_root = NULL;
3596     PL_curcop = &PL_compiling;
3597     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3598         PL_in_eval |= EVAL_KEEPERR;
3599     else
3600         CLEAR_ERRSV();
3601
3602     if (!startop) {
3603         bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3604         SAVEHINTS();
3605         if (clear_hints) {
3606             PL_hints = 0;
3607             hv_clear(GvHV(PL_hintgv));
3608         }
3609         else {
3610             PL_hints = saveop->op_private & OPpEVAL_COPHH
3611                          ? oldcurcop->cop_hints : saveop->op_targ;
3612             if (hh) {
3613                 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3614                 SvREFCNT_dec(GvHV(PL_hintgv));
3615                 GvHV(PL_hintgv) = hh;
3616             }
3617         }
3618         SAVECOMPILEWARNINGS();
3619         if (clear_hints) {
3620             if (PL_dowarn & G_WARN_ALL_ON)
3621                 PL_compiling.cop_warnings = pWARN_ALL ;
3622             else if (PL_dowarn & G_WARN_ALL_OFF)
3623                 PL_compiling.cop_warnings = pWARN_NONE ;
3624             else
3625                 PL_compiling.cop_warnings = pWARN_STD ;
3626         }
3627         else {
3628             PL_compiling.cop_warnings =
3629                 DUP_WARNINGS(oldcurcop->cop_warnings);
3630             cophh_free(CopHINTHASH_get(&PL_compiling));
3631             if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3632                 /* The label, if present, is the first entry on the chain. So rather
3633                    than writing a blank label in front of it (which involves an
3634                    allocation), just use the next entry in the chain.  */
3635                 PL_compiling.cop_hints_hash
3636                     = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3637                 /* Check the assumption that this removed the label.  */
3638                 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3639             }
3640             else
3641                 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3642         }
3643     }
3644
3645     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3646
3647     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3648      * so honour CATCH_GET and trap it here if necessary */
3649
3650     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3651
3652     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3653         SV **newsp;                     /* Used by POPBLOCK. */
3654         PERL_CONTEXT *cx;
3655         I32 optype;                     /* Used by POPEVAL. */
3656         SV *namesv;
3657
3658         cx = NULL;
3659         namesv = NULL;
3660         PERL_UNUSED_VAR(newsp);
3661         PERL_UNUSED_VAR(optype);
3662
3663         /* note that if yystatus == 3, then the EVAL CX block has already
3664          * been popped, and various vars restored */
3665         PL_op = saveop;
3666         if (yystatus != 3) {
3667             if (PL_eval_root) {
3668                 op_free(PL_eval_root);
3669                 PL_eval_root = NULL;
3670             }
3671             SP = PL_stack_base + POPMARK;       /* pop original mark */
3672             if (!startop) {
3673                 POPBLOCK(cx,PL_curpm);
3674                 POPEVAL(cx);
3675                 namesv = cx->blk_eval.old_namesv;
3676             }
3677             /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3678             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3679         }
3680
3681         if (in_require) {
3682             if (!cx) {
3683                 /* If cx is still NULL, it means that we didn't go in the
3684                  * POPEVAL branch. */
3685                 cx = &cxstack[cxstack_ix];
3686                 assert(CxTYPE(cx) == CXt_EVAL);
3687                 namesv = cx->blk_eval.old_namesv;
3688             }
3689             (void)hv_store(GvHVn(PL_incgv),
3690                            SvPVX_const(namesv),
3691                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3692                            &PL_sv_undef, 0);
3693             Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3694                        SVfARG(ERRSV
3695                                 ? ERRSV
3696                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3697         }
3698         else if (startop) {
3699             if (yystatus != 3) {
3700                 POPBLOCK(cx,PL_curpm);
3701                 POPEVAL(cx);
3702             }
3703             Perl_croak(aTHX_ "%"SVf"Compilation failed in regexp",
3704                        SVfARG(ERRSV
3705                                 ? ERRSV
3706                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3707         }
3708         else {
3709             if (!*(SvPVx_nolen_const(ERRSV))) {
3710                 sv_setpvs(ERRSV, "Compilation error");
3711             }
3712         }
3713         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3714         PUTBACK;
3715         return FALSE;
3716     }
3717     else if (!startop) LEAVE_with_name("evalcomp");
3718     CopLINE_set(&PL_compiling, 0);
3719     if (startop) {
3720         *startop = PL_eval_root;
3721     } else
3722         SAVEFREEOP(PL_eval_root);
3723
3724     DEBUG_x(dump_eval());
3725
3726     /* Register with debugger: */
3727     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3728         CV * const cv = get_cvs("DB::postponed", 0);
3729         if (cv) {
3730             dSP;
3731             PUSHMARK(SP);
3732             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3733             PUTBACK;
3734             call_sv(MUTABLE_SV(cv), G_DISCARD);
3735         }
3736     }
3737
3738     if (PL_unitcheckav) {
3739         OP *es = PL_eval_start;
3740         call_list(PL_scopestack_ix, PL_unitcheckav);
3741         PL_eval_start = es;
3742     }
3743
3744     /* compiled okay, so do it */
3745
3746     CvDEPTH(evalcv) = 1;
3747     SP = PL_stack_base + POPMARK;               /* pop original mark */
3748     PL_op = saveop;                     /* The caller may need it. */
3749     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3750
3751     PUTBACK;
3752     return TRUE;
3753 }
3754
3755 STATIC PerlIO *
3756 S_check_type_and_open(pTHX_ SV *name)
3757 {
3758     Stat_t st;
3759     const char *p = SvPV_nolen_const(name);
3760     const int st_rc = PerlLIO_stat(p, &st);
3761
3762     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3763
3764     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3765         return NULL;
3766     }
3767
3768 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3769     return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3770 #else
3771     return PerlIO_open(p, PERL_SCRIPT_MODE);
3772 #endif
3773 }
3774
3775 #ifndef PERL_DISABLE_PMC
3776 STATIC PerlIO *
3777 S_doopen_pm(pTHX_ SV *name)
3778 {
3779     STRLEN namelen;
3780     const char *p = SvPV_const(name, namelen);
3781
3782     PERL_ARGS_ASSERT_DOOPEN_PM;
3783
3784     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3785         SV *const pmcsv = sv_newmortal();
3786         Stat_t pmcstat;
3787
3788         SvSetSV_nosteal(pmcsv,name);
3789         sv_catpvn(pmcsv, "c", 1);
3790
3791         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3792             return check_type_and_open(pmcsv);
3793     }
3794     return check_type_and_open(name);
3795 }
3796 #else
3797 #  define doopen_pm(name) check_type_and_open(name)
3798 #endif /* !PERL_DISABLE_PMC */
3799
3800 PP(pp_require)
3801 {
3802     dVAR; dSP;
3803     register PERL_CONTEXT *cx;
3804     SV *sv;
3805     const char *name;
3806     STRLEN len;
3807     char * unixname;
3808     STRLEN unixlen;
3809 #ifdef VMS
3810     int vms_unixname = 0;
3811 #endif
3812     const char *tryname = NULL;
3813     SV *namesv = NULL;
3814     const I32 gimme = GIMME_V;
3815     int filter_has_file = 0;
3816     PerlIO *tryrsfp = NULL;
3817     SV *filter_cache = NULL;
3818     SV *filter_state = NULL;
3819     SV *filter_sub = NULL;
3820     SV *hook_sv = NULL;
3821     SV *encoding;
3822     OP *op;
3823
3824     sv = POPs;
3825     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3826         sv = sv_2mortal(new_version(sv));
3827         if (!sv_derived_from(PL_patchlevel, "version"))
3828             upg_version(PL_patchlevel, TRUE);
3829         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3830             if ( vcmp(sv,PL_patchlevel) <= 0 )
3831                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3832                     SVfARG(sv_2mortal(vnormal(sv))),
3833                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3834                 );
3835         }
3836         else {
3837             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3838                 I32 first = 0;
3839                 AV *lav;
3840                 SV * const req = SvRV(sv);
3841                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3842
3843                 /* get the left hand term */
3844                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3845
3846                 first  = SvIV(*av_fetch(lav,0,0));
3847                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3848                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3849                     || av_len(lav) > 1               /* FP with > 3 digits */
3850                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3851                    ) {
3852                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3853                         "%"SVf", stopped",
3854                         SVfARG(sv_2mortal(vnormal(req))),
3855                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3856                     );
3857                 }
3858                 else { /* probably 'use 5.10' or 'use 5.8' */
3859                     SV *hintsv;
3860                     I32 second = 0;
3861
3862                     if (av_len(lav)>=1) 
3863                         second = SvIV(*av_fetch(lav,1,0));
3864
3865                     second /= second >= 600  ? 100 : 10;
3866                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3867                                            (int)first, (int)second);
3868                     upg_version(hintsv, TRUE);
3869
3870                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3871                         "--this is only %"SVf", stopped",
3872                         SVfARG(sv_2mortal(vnormal(req))),
3873                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3874                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3875                     );
3876                 }
3877             }
3878         }
3879
3880         RETPUSHYES;
3881     }
3882     name = SvPV_const(sv, len);
3883     if (!(name && len > 0 && *name))
3884         DIE(aTHX_ "Null filename used");
3885     TAINT_PROPER("require");
3886
3887
3888 #ifdef VMS
3889     /* The key in the %ENV hash is in the syntax of file passed as the argument
3890      * usually this is in UNIX format, but sometimes in VMS format, which
3891      * can result in a module being pulled in more than once.
3892      * To prevent this, the key must be stored in UNIX format if the VMS
3893      * name can be translated to UNIX.
3894      */
3895     if ((unixname = tounixspec(name, NULL)) != NULL) {
3896         unixlen = strlen(unixname);
3897         vms_unixname = 1;
3898     }
3899     else
3900 #endif
3901     {
3902         /* if not VMS or VMS name can not be translated to UNIX, pass it
3903          * through.
3904          */
3905         unixname = (char *) name;
3906         unixlen = len;
3907     }
3908     if (PL_op->op_type == OP_REQUIRE) {
3909         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3910                                           unixname, unixlen, 0);
3911         if ( svp ) {
3912             if (*svp != &PL_sv_undef)
3913                 RETPUSHYES;
3914             else
3915                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3916                             "Compilation failed in require", unixname);
3917         }
3918     }
3919
3920     /* prepare to compile file */
3921
3922     if (path_is_absolute(name)) {
3923         /* At this point, name is SvPVX(sv)  */
3924         tryname = name;
3925         tryrsfp = doopen_pm(sv);
3926     }
3927     if (!tryrsfp) {
3928         AV * const ar = GvAVn(PL_incgv);
3929         I32 i;
3930 #ifdef VMS
3931         if (vms_unixname)
3932 #endif
3933         {
3934             namesv = newSV_type(SVt_PV);
3935             for (i = 0; i <= AvFILL(ar); i++) {
3936                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3937
3938                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3939                     mg_get(dirsv);
3940                 if (SvROK(dirsv)) {
3941                     int count;
3942                     SV **svp;
3943                     SV *loader = dirsv;
3944
3945                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3946                         && !sv_isobject(loader))
3947                     {
3948                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3949                     }
3950
3951                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3952                                    PTR2UV(SvRV(dirsv)), name);
3953                     tryname = SvPVX_const(namesv);
3954                     tryrsfp = NULL;
3955
3956                     ENTER_with_name("call_INC");
3957                     SAVETMPS;
3958                     EXTEND(SP, 2);
3959
3960                     PUSHMARK(SP);
3961                     PUSHs(dirsv);
3962                     PUSHs(sv);
3963                     PUTBACK;
3964                     if (sv_isobject(loader))
3965                         count = call_method("INC", G_ARRAY);
3966                     else
3967                         count = call_sv(loader, G_ARRAY);
3968                     SPAGAIN;
3969
3970                     if (count > 0) {
3971                         int i = 0;
3972                         SV *arg;
3973
3974                         SP -= count - 1;
3975                         arg = SP[i++];
3976
3977                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3978                             && !isGV_with_GP(SvRV(arg))) {
3979                             filter_cache = SvRV(arg);
3980                             SvREFCNT_inc_simple_void_NN(filter_cache);
3981
3982                             if (i < count) {
3983                                 arg = SP[i++];
3984                             }
3985                         }
3986
3987                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3988                             arg = SvRV(arg);
3989                         }
3990
3991                         if (isGV_with_GP(arg)) {
3992                             IO * const io = GvIO((const GV *)arg);
3993
3994                             ++filter_has_file;
3995
3996                             if (io) {
3997                                 tryrsfp = IoIFP(io);
3998                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3999                                     PerlIO_close(IoOFP(io));
4000                                 }
4001                                 IoIFP(io) = NULL;
4002                                 IoOFP(io) = NULL;
4003                             }
4004
4005                             if (i < count) {
4006                                 arg = SP[i++];
4007                             }
4008                         }
4009
4010                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
4011                             filter_sub = arg;
4012                             SvREFCNT_inc_simple_void_NN(filter_sub);
4013
4014                             if (i < count) {
4015                                 filter_state = SP[i];
4016                                 SvREFCNT_inc_simple_void(filter_state);
4017                             }
4018                         }
4019
4020                         if (!tryrsfp && (filter_cache || filter_sub)) {
4021                             tryrsfp = PerlIO_open(BIT_BUCKET,
4022                                                   PERL_SCRIPT_MODE);
4023                         }
4024                         SP--;
4025                     }
4026
4027                     PUTBACK;
4028                     FREETMPS;
4029                     LEAVE_with_name("call_INC");
4030
4031                     /* Adjust file name if the hook has set an %INC entry.
4032                        This needs to happen after the FREETMPS above.  */
4033                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
4034                     if (svp)
4035                         tryname = SvPV_nolen_const(*svp);
4036
4037                     if (tryrsfp) {
4038                         hook_sv = dirsv;
4039                         break;
4040                     }
4041
4042                     filter_has_file = 0;
4043                     if (filter_cache) {
4044                         SvREFCNT_dec(filter_cache);
4045                         filter_cache = NULL;
4046                     }
4047                     if (filter_state) {
4048                         SvREFCNT_dec(filter_state);
4049                         filter_state = NULL;
4050                     }
4051                     if (filter_sub) {
4052                         SvREFCNT_dec(filter_sub);
4053                         filter_sub = NULL;
4054                     }
4055                 }
4056                 else {
4057                   if (!path_is_absolute(name)
4058                   ) {
4059                     const char *dir;
4060                     STRLEN dirlen;
4061
4062                     if (SvOK(dirsv)) {
4063                         dir = SvPV_const(dirsv, dirlen);
4064                     } else {
4065                         dir = "";
4066                         dirlen = 0;
4067                     }
4068
4069 #ifdef VMS
4070                     char *unixdir;
4071                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
4072                         continue;
4073                     sv_setpv(namesv, unixdir);
4074                     sv_catpv(namesv, unixname);
4075 #else
4076 #  ifdef __SYMBIAN32__
4077                     if (PL_origfilename[0] &&
4078                         PL_origfilename[1] == ':' &&
4079                         !(dir[0] && dir[1] == ':'))
4080                         Perl_sv_setpvf(aTHX_ namesv,
4081                                        "%c:%s\\%s",
4082                                        PL_origfilename[0],
4083                                        dir, name);
4084                     else
4085                         Perl_sv_setpvf(aTHX_ namesv,
4086                                        "%s\\%s",
4087                                        dir, name);
4088 #  else
4089                     /* The equivalent of                    
4090                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4091                        but without the need to parse the format string, or
4092                        call strlen on either pointer, and with the correct
4093                        allocation up front.  */
4094                     {
4095                         char *tmp = SvGROW(namesv, dirlen + len + 2);
4096
4097                         memcpy(tmp, dir, dirlen);
4098                         tmp +=dirlen;
4099                         *tmp++ = '/';
4100                         /* name came from an SV, so it will have a '\0' at the
4101                            end that we can copy as part of this memcpy().  */
4102                         memcpy(tmp, name, len + 1);
4103
4104                         SvCUR_set(namesv, dirlen + len + 1);
4105                         SvPOK_on(namesv);
4106                     }
4107 #  endif
4108 #endif
4109                     TAINT_PROPER("require");
4110                     tryname = SvPVX_const(namesv);
4111                     tryrsfp = doopen_pm(namesv);
4112                     if (tryrsfp) {
4113                         if (tryname[0] == '.' && tryname[1] == '/') {
4114                             ++tryname;
4115                             while (*++tryname == '/');
4116                         }
4117                         break;
4118                     }
4119                     else if (errno == EMFILE)
4120                         /* no point in trying other paths if out of handles */
4121                         break;
4122                   }
4123                 }
4124             }
4125         }
4126     }
4127     sv_2mortal(namesv);
4128     if (!tryrsfp) {
4129         if (PL_op->op_type == OP_REQUIRE) {
4130             if(errno == EMFILE) {
4131                 /* diag_listed_as: Can't locate %s */
4132                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(errno));
4133             } else {
4134                 if (namesv) {                   /* did we lookup @INC? */
4135                     AV * const ar = GvAVn(PL_incgv);
4136                     I32 i;
4137                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4138                     for (i = 0; i <= AvFILL(ar); i++) {
4139                         sv_catpvs(inc, " ");
4140                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4141                     }
4142
4143                     /* diag_listed_as: Can't locate %s */
4144                     DIE(aTHX_
4145                         "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
4146                         name,
4147                         (memEQ(name + len - 2, ".h", 3)
4148                          ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
4149                         (memEQ(name + len - 3, ".ph", 4)
4150                          ? " (did you run h2ph?)" : ""),
4151                         inc
4152                         );
4153                 }
4154             }
4155             DIE(aTHX_ "Can't locate %s", name);
4156         }
4157
4158         RETPUSHUNDEF;
4159     }
4160     else
4161         SETERRNO(0, SS_NORMAL);
4162
4163     /* Assume success here to prevent recursive requirement. */
4164     /* name is never assigned to again, so len is still strlen(name)  */
4165     /* Check whether a hook in @INC has already filled %INC */
4166     if (!hook_sv) {
4167         (void)hv_store(GvHVn(PL_incgv),
4168                        unixname, unixlen, newSVpv(tryname,0),0);
4169     } else {
4170         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4171         if (!svp)
4172             (void)hv_store(GvHVn(PL_incgv),
4173                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4174     }
4175
4176     ENTER_with_name("eval");
4177     SAVETMPS;
4178     SAVECOPFILE_FREE(&PL_compiling);
4179     CopFILE_set(&PL_compiling, tryname);
4180     lex_start(NULL, tryrsfp, 0);
4181
4182     if (filter_sub || filter_cache) {
4183         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4184            than hanging another SV from it. In turn, filter_add() optionally
4185            takes the SV to use as the filter (or creates a new SV if passed
4186            NULL), so simply pass in whatever value filter_cache has.  */
4187         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
4188         IoLINES(datasv) = filter_has_file;
4189         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4190         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4191     }
4192
4193     /* switch to eval mode */
4194     PUSHBLOCK(cx, CXt_EVAL, SP);
4195     PUSHEVAL(cx, name);
4196     cx->blk_eval.retop = PL_op->op_next;
4197
4198     SAVECOPLINE(&PL_compiling);
4199     CopLINE_set(&PL_compiling, 0);
4200
4201     PUTBACK;
4202
4203     /* Store and reset encoding. */
4204     encoding = PL_encoding;
4205     PL_encoding = NULL;
4206
4207     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq, NULL))
4208         op = DOCATCH(PL_eval_start);
4209     else
4210         op = PL_op->op_next;
4211
4212     /* Restore encoding. */
4213     PL_encoding = encoding;
4214
4215     return op;
4216 }
4217
4218 /* This is a op added to hold the hints hash for
4219    pp_entereval. The hash can be modified by the code
4220    being eval'ed, so we return a copy instead. */
4221
4222 PP(pp_hintseval)
4223 {
4224     dVAR;
4225     dSP;
4226     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4227     RETURN;
4228 }
4229
4230
4231 PP(pp_entereval)
4232 {
4233     dVAR; dSP;
4234     register PERL_CONTEXT *cx;
4235     SV *sv;
4236     const I32 gimme = GIMME_V;
4237     const U32 was = PL_breakable_sub_gen;
4238     char tbuf[TYPE_DIGITS(long) + 12];
4239     bool saved_delete = FALSE;
4240     char *tmpbuf = tbuf;
4241     STRLEN len;
4242     CV* runcv;
4243     U32 seq, lex_flags = 0;
4244     HV *saved_hh = NULL;
4245     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4246
4247     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4248         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4249     }
4250     else if (PL_hints & HINT_LOCALIZE_HH || (
4251                 PL_op->op_private & OPpEVAL_COPHH
4252              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4253             )) {
4254         saved_hh = cop_hints_2hv(PL_curcop, 0);
4255         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4256     }
4257     sv = POPs;
4258     if (!SvPOK(sv)) {
4259         /* make sure we've got a plain PV (no overload etc) before testing
4260          * for taint. Making a copy here is probably overkill, but better
4261          * safe than sorry */
4262         STRLEN len;
4263         const char * const p = SvPV_const(sv, len);
4264
4265         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4266         lex_flags |= LEX_START_COPIED;
4267
4268         if (bytes && SvUTF8(sv))
4269             SvPVbyte_force(sv, len);
4270     }
4271     else if (bytes && SvUTF8(sv)) {
4272         /* Don't modify someone else's scalar */
4273         STRLEN len;
4274         sv = newSVsv(sv);
4275         (void)sv_2mortal(sv);
4276         SvPVbyte_force(sv,len);
4277         lex_flags |= LEX_START_COPIED;
4278     }
4279
4280     TAINT_IF(SvTAINTED(sv));
4281     TAINT_PROPER("eval");
4282
4283     ENTER_with_name("eval");
4284     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4285                            ? LEX_IGNORE_UTF8_HINTS
4286                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4287                         )
4288              );
4289     SAVETMPS;
4290
4291     /* switch to eval mode */
4292
4293     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4294         SV * const temp_sv = sv_newmortal();
4295         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4296                        (unsigned long)++PL_evalseq,
4297                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4298         tmpbuf = SvPVX(temp_sv);
4299         len = SvCUR(temp_sv);
4300     }
4301     else
4302         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4303     SAVECOPFILE_FREE(&PL_compiling);
4304     CopFILE_set(&PL_compiling, tmpbuf+2);
4305     SAVECOPLINE(&PL_compiling);
4306     CopLINE_set(&PL_compiling, 1);
4307     /* special case: an eval '' executed within the DB package gets lexically
4308      * placed in the first non-DB CV rather than the current CV - this
4309      * allows the debugger to execute code, find lexicals etc, in the
4310      * scope of the code being debugged. Passing &seq gets find_runcv
4311      * to do the dirty work for us */
4312     runcv = find_runcv(&seq);
4313
4314     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4315     PUSHEVAL(cx, 0);
4316     cx->blk_eval.retop = PL_op->op_next;
4317
4318     /* prepare to compile string */
4319
4320     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4321         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4322     else {
4323         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4324            deleting the eval's FILEGV from the stash before gv_check() runs
4325            (i.e. before run-time proper). To work around the coredump that
4326            ensues, we always turn GvMULTI_on for any globals that were
4327            introduced within evals. See force_ident(). GSAR 96-10-12 */
4328         char *const safestr = savepvn(tmpbuf, len);
4329         SAVEDELETE(PL_defstash, safestr, len);
4330         saved_delete = TRUE;
4331     }
4332     
4333     PUTBACK;
4334
4335     if (doeval(gimme, NULL, runcv, seq, saved_hh)) {
4336         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4337             ? (PERLDB_LINE || PERLDB_SAVESRC)
4338             :  PERLDB_SAVESRC_NOSUBS) {
4339             /* Retain the filegv we created.  */
4340         } else if (!saved_delete) {
4341             char *const safestr = savepvn(tmpbuf, len);
4342             SAVEDELETE(PL_defstash, safestr, len);
4343         }
4344         return DOCATCH(PL_eval_start);
4345     } else {
4346         /* We have already left the scope set up earlier thanks to the LEAVE
4347            in doeval().  */
4348         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4349             ? (PERLDB_LINE || PERLDB_SAVESRC)
4350             :  PERLDB_SAVESRC_INVALID) {
4351             /* Retain the filegv we created.  */
4352         } else if (!saved_delete) {
4353             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4354         }
4355         return PL_op->op_next;
4356     }
4357 }
4358
4359 PP(pp_leaveeval)
4360 {
4361     dVAR; dSP;
4362     SV **newsp;
4363     PMOP *newpm;
4364     I32 gimme;
4365     register PERL_CONTEXT *cx;
4366     OP *retop;
4367     const U8 save_flags = PL_op -> op_flags;
4368     I32 optype;
4369     SV *namesv;
4370     CV *evalcv;
4371
4372     PERL_ASYNC_CHECK();
4373     POPBLOCK(cx,newpm);
4374     POPEVAL(cx);
4375     namesv = cx->blk_eval.old_namesv;
4376     retop = cx->blk_eval.retop;
4377     evalcv = cx->blk_eval.cv;
4378
4379     TAINT_NOT;
4380     SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4381                                 gimme, SVs_TEMP);
4382     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4383
4384 #ifdef DEBUGGING
4385     assert(CvDEPTH(evalcv) == 1);
4386 #endif
4387     CvDEPTH(evalcv) = 0;
4388
4389     if (optype == OP_REQUIRE &&
4390         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4391     {
4392         /* Unassume the success we assumed earlier. */
4393         (void)hv_delete(GvHVn(PL_incgv),
4394                         SvPVX_const(namesv),
4395                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4396                         G_DISCARD);
4397         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4398                                SVfARG(namesv));
4399         /* die_unwind() did LEAVE, or we won't be here */
4400     }
4401     else {
4402         LEAVE_with_name("eval");
4403         if (!(save_flags & OPf_SPECIAL)) {
4404             CLEAR_ERRSV();
4405         }
4406     }
4407
4408     RETURNOP(retop);
4409 }
4410
4411 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4412    close to the related Perl_create_eval_scope.  */
4413 void
4414 Perl_delete_eval_scope(pTHX)
4415 {
4416     SV **newsp;
4417     PMOP *newpm;
4418     I32 gimme;
4419     register PERL_CONTEXT *cx;
4420     I32 optype;
4421         
4422     POPBLOCK(cx,newpm);
4423     POPEVAL(cx);
4424     PL_curpm = newpm;
4425     LEAVE_with_name("eval_scope");
4426     PERL_UNUSED_VAR(newsp);
4427     PERL_UNUSED_VAR(gimme);
4428     PERL_UNUSED_VAR(optype);
4429 }
4430
4431 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4432    also needed by Perl_fold_constants.  */
4433 PERL_CONTEXT *
4434 Perl_create_eval_scope(pTHX_ U32 flags)
4435 {
4436     PERL_CONTEXT *cx;
4437     const I32 gimme = GIMME_V;
4438         
4439     ENTER_with_name("eval_scope");
4440     SAVETMPS;