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