sigsystem.t depends on fork().
[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             sv_catsv_nomg(tmpstr, msv);
134         }
135         SvSETMAGIC(tmpstr);
136         SP = ORIGMARK;
137     }
138     else {
139         tmpstr = POPs;
140         tryAMAGICregexp(tmpstr);
141     }
142
143 #undef tryAMAGICregexp
144
145     if (SvROK(tmpstr)) {
146         SV * const sv = SvRV(tmpstr);
147         if (SvTYPE(sv) == SVt_REGEXP)
148             re = (REGEXP*) sv;
149     }
150     else if (SvTYPE(tmpstr) == SVt_REGEXP)
151         re = (REGEXP*) tmpstr;
152
153     if (re) {
154         /* The match's LHS's get-magic might need to access this op's reg-
155            exp (as is sometimes the case with $';  see bug 70764).  So we
156            must call get-magic now before we replace the regexp. Hopeful-
157            ly this hack can be replaced with the approach described at
158            http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
159            /msg122415.html some day. */
160         if(pm->op_type == OP_MATCH) {
161          SV *lhs;
162          const bool was_tainted = PL_tainted;
163          if (pm->op_flags & OPf_STACKED)
164             lhs = TOPs;
165          else if (pm->op_private & OPpTARGET_MY)
166             lhs = PAD_SV(pm->op_targ);
167          else lhs = DEFSV;
168          SvGETMAGIC(lhs);
169          /* Restore the previous value of PL_tainted (which may have been
170             modified by get-magic), to avoid incorrectly setting the
171             RXf_TAINTED flag further down. */
172          PL_tainted = was_tainted;
173         }
174
175         re = reg_temp_copy(NULL, re);
176         ReREFCNT_dec(PM_GETRE(pm));
177         PM_SETRE(pm, re);
178     }
179     else {
180         STRLEN len = 0;
181         const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
182
183         re = PM_GETRE(pm);
184         assert (re != (REGEXP*) &PL_sv_undef);
185
186         /* Check against the last compiled regexp. */
187         if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
188             memNE(RX_PRECOMP(re), t, len))
189         {
190             const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
191             U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
192             if (re) {
193                 ReREFCNT_dec(re);
194 #ifdef USE_ITHREADS
195                 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
196 #else
197                 PM_SETRE(pm, NULL);     /* crucial if regcomp aborts */
198 #endif
199             } else if (PL_curcop->cop_hints_hash) {
200                 SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
201                 if (ptr && SvIOK(ptr) && SvIV(ptr))
202                     eng = INT2PTR(regexp_engine*,SvIV(ptr));
203             }
204
205             if (PL_op->op_flags & OPf_SPECIAL)
206                 PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
207
208             if (!DO_UTF8(tmpstr) && SvUTF8(tmpstr)) {
209                 /* Not doing UTF-8, despite what the SV says. Is this only if
210                    we're trapped in use 'bytes'?  */
211                 /* Make a copy of the octet sequence, but without the flag on,
212                    as the compiler now honours the SvUTF8 flag on tmpstr.  */
213                 STRLEN len;
214                 const char *const p = SvPV(tmpstr, len);
215                 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
216             }
217             else if (SvAMAGIC(tmpstr) || SvGMAGICAL(tmpstr)) {
218                 /* make a copy to avoid extra stringifies */
219                 tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
220             }
221
222             if (eng)
223                 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
224             else
225                 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
226
227             PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
228                                            inside tie/overload accessors.  */
229         }
230     }
231     
232     re = PM_GETRE(pm);
233
234 #ifndef INCOMPLETE_TAINTS
235     if (PL_tainting) {
236         if (PL_tainted) {
237             SvTAINTED_on((SV*)re);
238             RX_EXTFLAGS(re) |= RXf_TAINTED;
239         }
240     }
241 #endif
242
243     if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
244         pm = PL_curpm;
245
246
247 #if !defined(USE_ITHREADS)
248     /* can't change the optree at runtime either */
249     /* PMf_KEEP is handled differently under threads to avoid these problems */
250     if (pm->op_pmflags & PMf_KEEP) {
251         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
252         cLOGOP->op_first->op_next = PL_op->op_next;
253     }
254 #endif
255     RETURN;
256 }
257
258 PP(pp_substcont)
259 {
260     dVAR;
261     dSP;
262     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
263     register PMOP * const pm = (PMOP*) cLOGOP->op_other;
264     register SV * const dstr = cx->sb_dstr;
265     register char *s = cx->sb_s;
266     register char *m = cx->sb_m;
267     char *orig = cx->sb_orig;
268     register REGEXP * const rx = cx->sb_rx;
269     SV *nsv = NULL;
270     REGEXP *old = PM_GETRE(pm);
271
272     PERL_ASYNC_CHECK();
273
274     if(old != rx) {
275         if(old)
276             ReREFCNT_dec(old);
277         PM_SETRE(pm,ReREFCNT_inc(rx));
278     }
279
280     rxres_restore(&cx->sb_rxres, rx);
281     RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
282
283     if (cx->sb_iters++) {
284         const I32 saviters = cx->sb_iters;
285         if (cx->sb_iters > cx->sb_maxiters)
286             DIE(aTHX_ "Substitution loop");
287
288         SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
289
290         /* See "how taint works" above pp_subst() */
291         if (SvTAINTED(TOPs))
292             cx->sb_rxtainted |= SUBST_TAINT_REPL;
293         sv_catsv_nomg(dstr, POPs);
294         /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
295         s -= RX_GOFS(rx);
296
297         /* Are we done */
298         /* I believe that we can't set REXEC_SCREAM here if
299            SvSCREAM(cx->sb_targ) is true because SvPVX(cx->sb_targ) isn't always
300            equal to s.  [See the comment before Perl_re_intuit_start(), which is
301            called from Perl_regexec_flags(), which says that it should be when
302            SvSCREAM() is true.]  s, cx->sb_strend and orig will be consistent
303            with SvPVX(cx->sb_targ), as substconst doesn't modify cx->sb_targ
304            during the match.  */
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)
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             const char *cx_label = CxLABEL(cx);
1409             if (!cx_label || strNE(label, cx_label) ) {
1410                 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1411                         (long)i, cx_label));
1412                 continue;
1413             }
1414             DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1415             return i;
1416           }
1417         }
1418     }
1419     return i;
1420 }
1421
1422
1423
1424 I32
1425 Perl_dowantarray(pTHX)
1426 {
1427     dVAR;
1428     const I32 gimme = block_gimme();
1429     return (gimme == G_VOID) ? G_SCALAR : gimme;
1430 }
1431
1432 I32
1433 Perl_block_gimme(pTHX)
1434 {
1435     dVAR;
1436     const I32 cxix = dopoptosub(cxstack_ix);
1437     if (cxix < 0)
1438         return G_VOID;
1439
1440     switch (cxstack[cxix].blk_gimme) {
1441     case G_VOID:
1442         return G_VOID;
1443     case G_SCALAR:
1444         return G_SCALAR;
1445     case G_ARRAY:
1446         return G_ARRAY;
1447     default:
1448         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1449         /* NOTREACHED */
1450         return 0;
1451     }
1452 }
1453
1454 I32
1455 Perl_is_lvalue_sub(pTHX)
1456 {
1457     dVAR;
1458     const I32 cxix = dopoptosub(cxstack_ix);
1459     assert(cxix >= 0);  /* We should only be called from inside subs */
1460
1461     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1462         return CxLVAL(cxstack + cxix);
1463     else
1464         return 0;
1465 }
1466
1467 /* only used by PUSHSUB */
1468 I32
1469 Perl_was_lvalue_sub(pTHX)
1470 {
1471     dVAR;
1472     const I32 cxix = dopoptosub(cxstack_ix-1);
1473     assert(cxix >= 0);  /* We should only be called from inside subs */
1474
1475     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1476         return CxLVAL(cxstack + cxix);
1477     else
1478         return 0;
1479 }
1480
1481 STATIC I32
1482 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1483 {
1484     dVAR;
1485     I32 i;
1486
1487     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1488
1489     for (i = startingblock; i >= 0; i--) {
1490         register const PERL_CONTEXT * const cx = &cxstk[i];
1491         switch (CxTYPE(cx)) {
1492         default:
1493             continue;
1494         case CXt_EVAL:
1495         case CXt_SUB:
1496         case CXt_FORMAT:
1497             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1498             return i;
1499         }
1500     }
1501     return i;
1502 }
1503
1504 STATIC I32
1505 S_dopoptoeval(pTHX_ I32 startingblock)
1506 {
1507     dVAR;
1508     I32 i;
1509     for (i = startingblock; i >= 0; i--) {
1510         register const PERL_CONTEXT *cx = &cxstack[i];
1511         switch (CxTYPE(cx)) {
1512         default:
1513             continue;
1514         case CXt_EVAL:
1515             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1516             return i;
1517         }
1518     }
1519     return i;
1520 }
1521
1522 STATIC I32
1523 S_dopoptoloop(pTHX_ I32 startingblock)
1524 {
1525     dVAR;
1526     I32 i;
1527     for (i = startingblock; i >= 0; i--) {
1528         register const PERL_CONTEXT * const cx = &cxstack[i];
1529         switch (CxTYPE(cx)) {
1530         case CXt_SUBST:
1531         case CXt_SUB:
1532         case CXt_FORMAT:
1533         case CXt_EVAL:
1534         case CXt_NULL:
1535             /* diag_listed_as: Exiting subroutine via %s */
1536             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1537                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1538             if ((CxTYPE(cx)) == CXt_NULL)
1539                 return -1;
1540             break;
1541         case CXt_LOOP_LAZYIV:
1542         case CXt_LOOP_LAZYSV:
1543         case CXt_LOOP_FOR:
1544         case CXt_LOOP_PLAIN:
1545             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1546             return i;
1547         }
1548     }
1549     return i;
1550 }
1551
1552 STATIC I32
1553 S_dopoptogiven(pTHX_ I32 startingblock)
1554 {
1555     dVAR;
1556     I32 i;
1557     for (i = startingblock; i >= 0; i--) {
1558         register const PERL_CONTEXT *cx = &cxstack[i];
1559         switch (CxTYPE(cx)) {
1560         default:
1561             continue;
1562         case CXt_GIVEN:
1563             DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1564             return i;
1565         case CXt_LOOP_PLAIN:
1566             assert(!CxFOREACHDEF(cx));
1567             break;
1568         case CXt_LOOP_LAZYIV:
1569         case CXt_LOOP_LAZYSV:
1570         case CXt_LOOP_FOR:
1571             if (CxFOREACHDEF(cx)) {
1572                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1573                 return i;
1574             }
1575         }
1576     }
1577     return i;
1578 }
1579
1580 STATIC I32
1581 S_dopoptowhen(pTHX_ I32 startingblock)
1582 {
1583     dVAR;
1584     I32 i;
1585     for (i = startingblock; i >= 0; i--) {
1586         register const PERL_CONTEXT *cx = &cxstack[i];
1587         switch (CxTYPE(cx)) {
1588         default:
1589             continue;
1590         case CXt_WHEN:
1591             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1592             return i;
1593         }
1594     }
1595     return i;
1596 }
1597
1598 void
1599 Perl_dounwind(pTHX_ I32 cxix)
1600 {
1601     dVAR;
1602     I32 optype;
1603
1604     if (!PL_curstackinfo) /* can happen if die during thread cloning */
1605         return;
1606
1607     while (cxstack_ix > cxix) {
1608         SV *sv;
1609         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1610         DEBUG_CX("UNWIND");                                             \
1611         /* Note: we don't need to restore the base context info till the end. */
1612         switch (CxTYPE(cx)) {
1613         case CXt_SUBST:
1614             POPSUBST(cx);
1615             continue;  /* not break */
1616         case CXt_SUB:
1617             POPSUB(cx,sv);
1618             LEAVESUB(sv);
1619             break;
1620         case CXt_EVAL:
1621             POPEVAL(cx);
1622             break;
1623         case CXt_LOOP_LAZYIV:
1624         case CXt_LOOP_LAZYSV:
1625         case CXt_LOOP_FOR:
1626         case CXt_LOOP_PLAIN:
1627             POPLOOP(cx);
1628             break;
1629         case CXt_NULL:
1630             break;
1631         case CXt_FORMAT:
1632             POPFORMAT(cx);
1633             break;
1634         }
1635         cxstack_ix--;
1636     }
1637     PERL_UNUSED_VAR(optype);
1638 }
1639
1640 void
1641 Perl_qerror(pTHX_ SV *err)
1642 {
1643     dVAR;
1644
1645     PERL_ARGS_ASSERT_QERROR;
1646
1647     if (PL_in_eval) {
1648         if (PL_in_eval & EVAL_KEEPERR) {
1649                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1650                                                     SVfARG(err));
1651         }
1652         else
1653             sv_catsv(ERRSV, err);
1654     }
1655     else if (PL_errors)
1656         sv_catsv(PL_errors, err);
1657     else
1658         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1659     if (PL_parser)
1660         ++PL_parser->error_count;
1661 }
1662
1663 void
1664 Perl_die_unwind(pTHX_ SV *msv)
1665 {
1666     dVAR;
1667     SV *exceptsv = sv_mortalcopy(msv);
1668     U8 in_eval = PL_in_eval;
1669     PERL_ARGS_ASSERT_DIE_UNWIND;
1670
1671     if (in_eval) {
1672         I32 cxix;
1673         I32 gimme;
1674
1675         /*
1676          * Historically, perl used to set ERRSV ($@) early in the die
1677          * process and rely on it not getting clobbered during unwinding.
1678          * That sucked, because it was liable to get clobbered, so the
1679          * setting of ERRSV used to emit the exception from eval{} has
1680          * been moved to much later, after unwinding (see just before
1681          * JMPENV_JUMP below).  However, some modules were relying on the
1682          * early setting, by examining $@ during unwinding to use it as
1683          * a flag indicating whether the current unwinding was caused by
1684          * an exception.  It was never a reliable flag for that purpose,
1685          * being totally open to false positives even without actual
1686          * clobberage, but was useful enough for production code to
1687          * semantically rely on it.
1688          *
1689          * We'd like to have a proper introspective interface that
1690          * explicitly describes the reason for whatever unwinding
1691          * operations are currently in progress, so that those modules
1692          * work reliably and $@ isn't further overloaded.  But we don't
1693          * have one yet.  In its absence, as a stopgap measure, ERRSV is
1694          * now *additionally* set here, before unwinding, to serve as the
1695          * (unreliable) flag that it used to.
1696          *
1697          * This behaviour is temporary, and should be removed when a
1698          * proper way to detect exceptional unwinding has been developed.
1699          * As of 2010-12, the authors of modules relying on the hack
1700          * are aware of the issue, because the modules failed on
1701          * perls 5.13.{1..7} which had late setting of $@ without this
1702          * early-setting hack.
1703          */
1704         if (!(in_eval & EVAL_KEEPERR)) {
1705             SvTEMP_off(exceptsv);
1706             sv_setsv(ERRSV, exceptsv);
1707         }
1708
1709         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1710                && PL_curstackinfo->si_prev)
1711         {
1712             dounwind(-1);
1713             POPSTACK;
1714         }
1715
1716         if (cxix >= 0) {
1717             I32 optype;
1718             SV *namesv;
1719             register PERL_CONTEXT *cx;
1720             SV **newsp;
1721             COP *oldcop;
1722             JMPENV *restartjmpenv;
1723             OP *restartop;
1724
1725             if (cxix < cxstack_ix)
1726                 dounwind(cxix);
1727
1728             POPBLOCK(cx,PL_curpm);
1729             if (CxTYPE(cx) != CXt_EVAL) {
1730                 STRLEN msglen;
1731                 const char* message = SvPVx_const(exceptsv, msglen);
1732                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1733                 PerlIO_write(Perl_error_log, message, msglen);
1734                 my_exit(1);
1735             }
1736             POPEVAL(cx);
1737             namesv = cx->blk_eval.old_namesv;
1738             oldcop = cx->blk_oldcop;
1739             restartjmpenv = cx->blk_eval.cur_top_env;
1740             restartop = cx->blk_eval.retop;
1741
1742             if (gimme == G_SCALAR)
1743                 *++newsp = &PL_sv_undef;
1744             PL_stack_sp = newsp;
1745
1746             LEAVE;
1747
1748             /* LEAVE could clobber PL_curcop (see save_re_context())
1749              * XXX it might be better to find a way to avoid messing with
1750              * PL_curcop in save_re_context() instead, but this is a more
1751              * minimal fix --GSAR */
1752             PL_curcop = oldcop;
1753
1754             if (optype == OP_REQUIRE) {
1755                 (void)hv_store(GvHVn(PL_incgv),
1756                                SvPVX_const(namesv),
1757                                SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1758                                &PL_sv_undef, 0);
1759                 /* note that unlike pp_entereval, pp_require isn't
1760                  * supposed to trap errors. So now that we've popped the
1761                  * EVAL that pp_require pushed, and processed the error
1762                  * message, rethrow the error */
1763                 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1764                            SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1765                                                                     SVs_TEMP)));
1766             }
1767             if (in_eval & EVAL_KEEPERR) {
1768                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1769                                SVfARG(exceptsv));
1770             }
1771             else {
1772                 sv_setsv(ERRSV, exceptsv);
1773             }
1774             PL_restartjmpenv = restartjmpenv;
1775             PL_restartop = restartop;
1776             JMPENV_JUMP(3);
1777             /* NOTREACHED */
1778         }
1779     }
1780
1781     write_to_stderr(exceptsv);
1782     my_failure_exit();
1783     /* NOTREACHED */
1784 }
1785
1786 PP(pp_xor)
1787 {
1788     dVAR; dSP; dPOPTOPssrl;
1789     if (SvTRUE(left) != SvTRUE(right))
1790         RETSETYES;
1791     else
1792         RETSETNO;
1793 }
1794
1795 /*
1796 =for apidoc caller_cx
1797
1798 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1799 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1800 information returned to Perl by C<caller>. Note that XSUBs don't get a
1801 stack frame, so C<caller_cx(0, NULL)> will return information for the
1802 immediately-surrounding Perl code.
1803
1804 This function skips over the automatic calls to C<&DB::sub> made on the
1805 behalf of the debugger. If the stack frame requested was a sub called by
1806 C<DB::sub>, the return value will be the frame for the call to
1807 C<DB::sub>, since that has the correct line number/etc. for the call
1808 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1809 frame for the sub call itself.
1810
1811 =cut
1812 */
1813
1814 const PERL_CONTEXT *
1815 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1816 {
1817     register I32 cxix = dopoptosub(cxstack_ix);
1818     register const PERL_CONTEXT *cx;
1819     register const PERL_CONTEXT *ccstack = cxstack;
1820     const PERL_SI *top_si = PL_curstackinfo;
1821
1822     for (;;) {
1823         /* we may be in a higher stacklevel, so dig down deeper */
1824         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1825             top_si = top_si->si_prev;
1826             ccstack = top_si->si_cxstack;
1827             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1828         }
1829         if (cxix < 0)
1830             return NULL;
1831         /* caller() should not report the automatic calls to &DB::sub */
1832         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1833                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1834             count++;
1835         if (!count--)
1836             break;
1837         cxix = dopoptosub_at(ccstack, cxix - 1);
1838     }
1839
1840     cx = &ccstack[cxix];
1841     if (dbcxp) *dbcxp = cx;
1842
1843     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1844         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1845         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1846            field below is defined for any cx. */
1847         /* caller() should not report the automatic calls to &DB::sub */
1848         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1849             cx = &ccstack[dbcxix];
1850     }
1851
1852     return cx;
1853 }
1854
1855 PP(pp_caller)
1856 {
1857     dVAR;
1858     dSP;
1859     register const PERL_CONTEXT *cx;
1860     const PERL_CONTEXT *dbcx;
1861     I32 gimme;
1862     const HEK *stash_hek;
1863     I32 count = 0;
1864     bool has_arg = MAXARG && TOPs;
1865
1866     if (MAXARG) {
1867       if (has_arg)
1868         count = POPi;
1869       else (void)POPs;
1870     }
1871
1872     cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1873     if (!cx) {
1874         if (GIMME != G_ARRAY) {
1875             EXTEND(SP, 1);
1876             RETPUSHUNDEF;
1877         }
1878         RETURN;
1879     }
1880
1881     stash_hek = HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop));
1882     if (GIMME != G_ARRAY) {
1883         EXTEND(SP, 1);
1884         if (!stash_hek)
1885             PUSHs(&PL_sv_undef);
1886         else {
1887             dTARGET;
1888             sv_sethek(TARG, stash_hek);
1889             PUSHs(TARG);
1890         }
1891         RETURN;
1892     }
1893
1894     EXTEND(SP, 11);
1895
1896     if (!stash_hek)
1897         PUSHs(&PL_sv_undef);
1898     else {
1899         dTARGET;
1900         sv_sethek(TARG, stash_hek);
1901         PUSHTARG;
1902     }
1903     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1904     mPUSHi((I32)CopLINE(cx->blk_oldcop));
1905     if (!has_arg)
1906         RETURN;
1907     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1908         GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1909         /* So is ccstack[dbcxix]. */
1910         if (isGV(cvgv)) {
1911             SV * const sv = newSV(0);
1912             gv_efullname3(sv, cvgv, NULL);
1913             mPUSHs(sv);
1914             PUSHs(boolSV(CxHASARGS(cx)));
1915         }
1916         else {
1917             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1918             PUSHs(boolSV(CxHASARGS(cx)));
1919         }
1920     }
1921     else {
1922         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1923         mPUSHi(0);
1924     }
1925     gimme = (I32)cx->blk_gimme;
1926     if (gimme == G_VOID)
1927         PUSHs(&PL_sv_undef);
1928     else
1929         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1930     if (CxTYPE(cx) == CXt_EVAL) {
1931         /* eval STRING */
1932         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1933             PUSHs(cx->blk_eval.cur_text);
1934             PUSHs(&PL_sv_no);
1935         }
1936         /* require */
1937         else if (cx->blk_eval.old_namesv) {
1938             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1939             PUSHs(&PL_sv_yes);
1940         }
1941         /* eval BLOCK (try blocks have old_namesv == 0) */
1942         else {
1943             PUSHs(&PL_sv_undef);
1944             PUSHs(&PL_sv_undef);
1945         }
1946     }
1947     else {
1948         PUSHs(&PL_sv_undef);
1949         PUSHs(&PL_sv_undef);
1950     }
1951     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1952         && CopSTASH_eq(PL_curcop, PL_debstash))
1953     {
1954         AV * const ary = cx->blk_sub.argarray;
1955         const int off = AvARRAY(ary) - AvALLOC(ary);
1956
1957         Perl_init_dbargs(aTHX);
1958
1959         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1960             av_extend(PL_dbargs, AvFILLp(ary) + off);
1961         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1962         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1963     }
1964     /* XXX only hints propagated via op_private are currently
1965      * visible (others are not easily accessible, since they
1966      * use the global PL_hints) */
1967     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1968     {
1969         SV * mask ;
1970         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1971
1972         if  (old_warnings == pWARN_NONE ||
1973                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1974             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1975         else if (old_warnings == pWARN_ALL ||
1976                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1977             /* Get the bit mask for $warnings::Bits{all}, because
1978              * it could have been extended by warnings::register */
1979             SV **bits_all;
1980             HV * const bits = get_hv("warnings::Bits", 0);
1981             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1982                 mask = newSVsv(*bits_all);
1983             }
1984             else {
1985                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1986             }
1987         }
1988         else
1989             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1990         mPUSHs(mask);
1991     }
1992
1993     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1994           sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1995           : &PL_sv_undef);
1996     RETURN;
1997 }
1998
1999 PP(pp_reset)
2000 {
2001     dVAR;
2002     dSP;
2003     const char * const tmps =
2004         (MAXARG < 1 || (!TOPs && !POPs)) ? (const char *)"" : POPpconstx;
2005     sv_reset(tmps, CopSTASH(PL_curcop));
2006     PUSHs(&PL_sv_yes);
2007     RETURN;
2008 }
2009
2010 /* like pp_nextstate, but used instead when the debugger is active */
2011
2012 PP(pp_dbstate)
2013 {
2014     dVAR;
2015     PL_curcop = (COP*)PL_op;
2016     TAINT_NOT;          /* Each statement is presumed innocent */
2017     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
2018     FREETMPS;
2019
2020     PERL_ASYNC_CHECK();
2021
2022     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2023             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
2024     {
2025         dSP;
2026         register PERL_CONTEXT *cx;
2027         const I32 gimme = G_ARRAY;
2028         U8 hasargs;
2029         GV * const gv = PL_DBgv;
2030         register CV * const cv = GvCV(gv);
2031
2032         if (!cv)
2033             DIE(aTHX_ "No DB::DB routine defined");
2034
2035         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2036             /* don't do recursive DB::DB call */
2037             return NORMAL;
2038
2039         ENTER;
2040         SAVETMPS;
2041
2042         SAVEI32(PL_debug);
2043         SAVESTACK_POS();
2044         PL_debug = 0;
2045         hasargs = 0;
2046         SPAGAIN;
2047
2048         if (CvISXSUB(cv)) {
2049             CvDEPTH(cv)++;
2050             PUSHMARK(SP);
2051             (void)(*CvXSUB(cv))(aTHX_ cv);
2052             CvDEPTH(cv)--;
2053             FREETMPS;
2054             LEAVE;
2055             return NORMAL;
2056         }
2057         else {
2058             PUSHBLOCK(cx, CXt_SUB, SP);
2059             PUSHSUB_DB(cx);
2060             cx->blk_sub.retop = PL_op->op_next;
2061             CvDEPTH(cv)++;
2062             SAVECOMPPAD();
2063             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
2064             RETURNOP(CvSTART(cv));
2065         }
2066     }
2067     else
2068         return NORMAL;
2069 }
2070
2071 STATIC SV **
2072 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
2073 {
2074     bool padtmp = 0;
2075     PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2076
2077     if (flags & SVs_PADTMP) {
2078         flags &= ~SVs_PADTMP;
2079         padtmp = 1;
2080     }
2081     if (gimme == G_SCALAR) {
2082         if (MARK < SP)
2083             *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2084                             ? *SP : sv_mortalcopy(*SP);
2085         else {
2086             /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2087             MARK = newsp;
2088             MEXTEND(MARK, 1);
2089             *++MARK = &PL_sv_undef;
2090             return MARK;
2091         }
2092     }
2093     else if (gimme == G_ARRAY) {
2094         /* in case LEAVE wipes old return values */
2095         while (++MARK <= SP) {
2096             if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2097                 *++newsp = *MARK;
2098             else {
2099                 *++newsp = sv_mortalcopy(*MARK);
2100                 TAINT_NOT;      /* Each item is independent */
2101             }
2102         }
2103         /* When this function was called with MARK == newsp, we reach this
2104          * point with SP == newsp. */
2105     }
2106
2107     return newsp;
2108 }
2109
2110 PP(pp_enter)
2111 {
2112     dVAR; dSP;
2113     register PERL_CONTEXT *cx;
2114     I32 gimme = GIMME_V;
2115
2116     ENTER_with_name("block");
2117
2118     SAVETMPS;
2119     PUSHBLOCK(cx, CXt_BLOCK, SP);
2120
2121     RETURN;
2122 }
2123
2124 PP(pp_leave)
2125 {
2126     dVAR; dSP;
2127     register PERL_CONTEXT *cx;
2128     SV **newsp;
2129     PMOP *newpm;
2130     I32 gimme;
2131
2132     if (PL_op->op_flags & OPf_SPECIAL) {
2133         cx = &cxstack[cxstack_ix];
2134         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
2135     }
2136
2137     POPBLOCK(cx,newpm);
2138
2139     gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2140
2141     TAINT_NOT;
2142     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
2143     PL_curpm = newpm;   /* Don't pop $1 et al till now */
2144
2145     LEAVE_with_name("block");
2146
2147     RETURN;
2148 }
2149
2150 PP(pp_enteriter)
2151 {
2152     dVAR; dSP; dMARK;
2153     register PERL_CONTEXT *cx;
2154     const I32 gimme = GIMME_V;
2155     void *itervar; /* location of the iteration variable */
2156     U8 cxtype = CXt_LOOP_FOR;
2157
2158     ENTER_with_name("loop1");
2159     SAVETMPS;
2160
2161     if (PL_op->op_targ) {                        /* "my" variable */
2162         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2163             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2164             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2165                     SVs_PADSTALE, SVs_PADSTALE);
2166         }
2167         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2168 #ifdef USE_ITHREADS
2169         itervar = PL_comppad;
2170 #else
2171         itervar = &PAD_SVl(PL_op->op_targ);
2172 #endif
2173     }
2174     else {                                      /* symbol table variable */
2175         GV * const gv = MUTABLE_GV(POPs);
2176         SV** svp = &GvSV(gv);
2177         save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2178         *svp = newSV(0);
2179         itervar = (void *)gv;
2180     }
2181
2182     if (PL_op->op_private & OPpITER_DEF)
2183         cxtype |= CXp_FOR_DEF;
2184
2185     ENTER_with_name("loop2");
2186
2187     PUSHBLOCK(cx, cxtype, SP);
2188     PUSHLOOP_FOR(cx, itervar, MARK);
2189     if (PL_op->op_flags & OPf_STACKED) {
2190         SV *maybe_ary = POPs;
2191         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2192             dPOPss;
2193             SV * const right = maybe_ary;
2194             SvGETMAGIC(sv);
2195             SvGETMAGIC(right);
2196             if (RANGE_IS_NUMERIC(sv,right)) {
2197                 cx->cx_type &= ~CXTYPEMASK;
2198                 cx->cx_type |= CXt_LOOP_LAZYIV;
2199                 /* Make sure that no-one re-orders cop.h and breaks our
2200                    assumptions */
2201                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2202 #ifdef NV_PRESERVES_UV
2203                 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2204                                   (SvNV_nomg(sv) > (NV)IV_MAX)))
2205                         ||
2206                     (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2207                                      (SvNV_nomg(right) < (NV)IV_MIN))))
2208 #else
2209                 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
2210                                   ||
2211                                   ((SvNV_nomg(sv) > 0) &&
2212                                         ((SvUV_nomg(sv) > (UV)IV_MAX) ||
2213                                          (SvNV_nomg(sv) > (NV)UV_MAX)))))
2214                         ||
2215                     (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
2216                                      ||
2217                                      ((SvNV_nomg(right) > 0) &&
2218                                         ((SvUV_nomg(right) > (UV)IV_MAX) ||
2219                                          (SvNV_nomg(right) > (NV)UV_MAX))
2220                                      ))))
2221 #endif
2222                     DIE(aTHX_ "Range iterator outside integer range");
2223                 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2224                 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2225 #ifdef DEBUGGING
2226                 /* for correct -Dstv display */
2227                 cx->blk_oldsp = sp - PL_stack_base;
2228 #endif
2229             }
2230             else {
2231                 cx->cx_type &= ~CXTYPEMASK;
2232                 cx->cx_type |= CXt_LOOP_LAZYSV;
2233                 /* Make sure that no-one re-orders cop.h and breaks our
2234                    assumptions */
2235                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2236                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2237                 cx->blk_loop.state_u.lazysv.end = right;
2238                 SvREFCNT_inc(right);
2239                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2240                 /* This will do the upgrade to SVt_PV, and warn if the value
2241                    is uninitialised.  */
2242                 (void) SvPV_nolen_const(right);
2243                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2244                    to replace !SvOK() with a pointer to "".  */
2245                 if (!SvOK(right)) {
2246                     SvREFCNT_dec(right);
2247                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2248                 }
2249             }
2250         }
2251         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2252             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2253             SvREFCNT_inc(maybe_ary);
2254             cx->blk_loop.state_u.ary.ix =
2255                 (PL_op->op_private & OPpITER_REVERSED) ?
2256                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2257                 -1;
2258         }
2259     }
2260     else { /* iterating over items on the stack */
2261         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2262         if (PL_op->op_private & OPpITER_REVERSED) {
2263             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2264         }
2265         else {
2266             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2267         }
2268     }
2269
2270     RETURN;
2271 }
2272
2273 PP(pp_enterloop)
2274 {
2275     dVAR; dSP;
2276     register PERL_CONTEXT *cx;
2277     const I32 gimme = GIMME_V;
2278
2279     ENTER_with_name("loop1");
2280     SAVETMPS;
2281     ENTER_with_name("loop2");
2282
2283     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2284     PUSHLOOP_PLAIN(cx, SP);
2285
2286     RETURN;
2287 }
2288
2289 PP(pp_leaveloop)
2290 {
2291     dVAR; dSP;
2292     register PERL_CONTEXT *cx;
2293     I32 gimme;
2294     SV **newsp;
2295     PMOP *newpm;
2296     SV **mark;
2297
2298     POPBLOCK(cx,newpm);
2299     assert(CxTYPE_is_LOOP(cx));
2300     mark = newsp;
2301     newsp = PL_stack_base + cx->blk_loop.resetsp;
2302
2303     TAINT_NOT;
2304     SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
2305     PUTBACK;
2306
2307     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2308     PL_curpm = newpm;   /* ... and pop $1 et al */
2309
2310     LEAVE_with_name("loop2");
2311     LEAVE_with_name("loop1");
2312
2313     return NORMAL;
2314 }
2315
2316 STATIC void
2317 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2318                        PERL_CONTEXT *cx, PMOP *newpm)
2319 {
2320     const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2321     if (gimme == G_SCALAR) {
2322         if (CxLVAL(cx) && !ref) {     /* Leave it as it is if we can. */
2323             SV *sv;
2324             const char *what = NULL;
2325             if (MARK < SP) {
2326                 assert(MARK+1 == SP);
2327                 if ((SvPADTMP(TOPs) ||
2328                      (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2329                        == SVf_READONLY
2330                     ) &&
2331                     !SvSMAGICAL(TOPs)) {
2332                     what =
2333                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2334                         : "a readonly value" : "a temporary";
2335                 }
2336                 else goto copy_sv;
2337             }
2338             else {
2339                 /* sub:lvalue{} will take us here. */
2340                 what = "undef";
2341             }
2342             LEAVE;
2343             cxstack_ix--;
2344             POPSUB(cx,sv);
2345             PL_curpm = newpm;
2346             LEAVESUB(sv);
2347             Perl_croak(aTHX_
2348                       "Can't return %s from lvalue subroutine", what
2349             );
2350         }
2351         if (MARK < SP) {
2352               copy_sv:
2353                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2354                         *++newsp = SvREFCNT_inc(*SP);
2355                         FREETMPS;
2356                         sv_2mortal(*newsp);
2357                 }
2358                 else
2359                     *++newsp =
2360                         !SvTEMP(*SP)
2361                           ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2362                           : *SP;
2363         }
2364         else {
2365             EXTEND(newsp,1);
2366             *++newsp = &PL_sv_undef;
2367         }
2368         if (CxLVAL(cx) & OPpDEREF) {
2369             SvGETMAGIC(TOPs);
2370             if (!SvOK(TOPs)) {
2371                 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2372             }
2373         }
2374     }
2375     else if (gimme == G_ARRAY) {
2376         assert (!(CxLVAL(cx) & OPpDEREF));
2377         if (ref || !CxLVAL(cx))
2378             while (++MARK <= SP)
2379                 *++newsp =
2380                      SvTEMP(*MARK)
2381                        ? *MARK
2382                        : ref && SvFLAGS(*MARK) & SVs_PADTMP
2383                            ? sv_mortalcopy(*MARK)
2384                            : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2385         else while (++MARK <= SP) {
2386             if (*MARK != &PL_sv_undef
2387                     && (SvPADTMP(*MARK)
2388                        || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2389                              == SVf_READONLY
2390                        )
2391             ) {
2392                     SV *sv;
2393                     /* Might be flattened array after $#array =  */
2394                     PUTBACK;
2395                     LEAVE;
2396                     cxstack_ix--;
2397                     POPSUB(cx,sv);
2398                     PL_curpm = newpm;
2399                     LEAVESUB(sv);
2400                /* diag_listed_as: Can't return %s from lvalue subroutine */
2401                     Perl_croak(aTHX_
2402                         "Can't return a %s from lvalue subroutine",
2403                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2404             }
2405             else
2406                 *++newsp =
2407                     SvTEMP(*MARK)
2408                        ? *MARK
2409                        : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2410         }
2411     }
2412     PL_stack_sp = newsp;
2413 }
2414
2415 PP(pp_return)
2416 {
2417     dVAR; dSP; dMARK;
2418     register PERL_CONTEXT *cx;
2419     bool popsub2 = FALSE;
2420     bool clear_errsv = FALSE;
2421     bool lval = FALSE;
2422     I32 gimme;
2423     SV **newsp;
2424     PMOP *newpm;
2425     I32 optype = 0;
2426     SV *namesv;
2427     SV *sv;
2428     OP *retop = NULL;
2429
2430     const I32 cxix = dopoptosub(cxstack_ix);
2431
2432     if (cxix < 0) {
2433         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2434                                      * sort block, which is a CXt_NULL
2435                                      * not a CXt_SUB */
2436             dounwind(0);
2437             PL_stack_base[1] = *PL_stack_sp;
2438             PL_stack_sp = PL_stack_base + 1;
2439             return 0;
2440         }
2441         else
2442             DIE(aTHX_ "Can't return outside a subroutine");
2443     }
2444     if (cxix < cxstack_ix)
2445         dounwind(cxix);
2446
2447     if (CxMULTICALL(&cxstack[cxix])) {
2448         gimme = cxstack[cxix].blk_gimme;
2449         if (gimme == G_VOID)
2450             PL_stack_sp = PL_stack_base;
2451         else if (gimme == G_SCALAR) {
2452             PL_stack_base[1] = *PL_stack_sp;
2453             PL_stack_sp = PL_stack_base + 1;
2454         }
2455         return 0;
2456     }
2457
2458     POPBLOCK(cx,newpm);
2459     switch (CxTYPE(cx)) {
2460     case CXt_SUB:
2461         popsub2 = TRUE;
2462         lval = !!CvLVALUE(cx->blk_sub.cv);
2463         retop = cx->blk_sub.retop;
2464         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2465         break;
2466     case CXt_EVAL:
2467         if (!(PL_in_eval & EVAL_KEEPERR))
2468             clear_errsv = TRUE;
2469         POPEVAL(cx);
2470         namesv = cx->blk_eval.old_namesv;
2471         retop = cx->blk_eval.retop;
2472         if (CxTRYBLOCK(cx))
2473             break;
2474         if (optype == OP_REQUIRE &&
2475             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2476         {
2477             /* Unassume the success we assumed earlier. */
2478             (void)hv_delete(GvHVn(PL_incgv),
2479                             SvPVX_const(namesv),
2480                             SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2481                             G_DISCARD);
2482             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2483         }
2484         break;
2485     case CXt_FORMAT:
2486         POPFORMAT(cx);
2487         retop = cx->blk_sub.retop;
2488         break;
2489     default:
2490         DIE(aTHX_ "panic: return");
2491     }
2492
2493     TAINT_NOT;
2494     if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2495     else {
2496       if (gimme == G_SCALAR) {
2497         if (MARK < SP) {
2498             if (popsub2) {
2499                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2500                     if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2501                         *++newsp = SvREFCNT_inc(*SP);
2502                         FREETMPS;
2503                         sv_2mortal(*newsp);
2504                     }
2505                     else {
2506                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2507                         FREETMPS;
2508                         *++newsp = sv_mortalcopy(sv);
2509                         SvREFCNT_dec(sv);
2510                     }
2511                 }
2512                 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) {
2513                     *++newsp = *SP;
2514                 }
2515                 else
2516                     *++newsp = sv_mortalcopy(*SP);
2517             }
2518             else
2519                 *++newsp = sv_mortalcopy(*SP);
2520         }
2521         else
2522             *++newsp = &PL_sv_undef;
2523       }
2524       else if (gimme == G_ARRAY) {
2525         while (++MARK <= SP) {
2526             *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2527                         ? *MARK : sv_mortalcopy(*MARK);
2528             TAINT_NOT;          /* Each item is independent */
2529         }
2530       }
2531       PL_stack_sp = newsp;
2532     }
2533
2534     LEAVE;
2535     /* Stack values are safe: */
2536     if (popsub2) {
2537         cxstack_ix--;
2538         POPSUB(cx,sv);  /* release CV and @_ ... */
2539     }
2540     else
2541         sv = NULL;
2542     PL_curpm = newpm;   /* ... and pop $1 et al */
2543
2544     LEAVESUB(sv);
2545     if (clear_errsv) {
2546         CLEAR_ERRSV();
2547     }
2548     return retop;
2549 }
2550
2551 /* This duplicates parts of pp_leavesub, so that it can share code with
2552  * pp_return */
2553 PP(pp_leavesublv)
2554 {
2555     dVAR; dSP;
2556     SV **newsp;
2557     PMOP *newpm;
2558     I32 gimme;
2559     register PERL_CONTEXT *cx;
2560     SV *sv;
2561
2562     if (CxMULTICALL(&cxstack[cxstack_ix]))
2563         return 0;
2564
2565     POPBLOCK(cx,newpm);
2566     cxstack_ix++; /* temporarily protect top context */
2567
2568     TAINT_NOT;
2569
2570     S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2571
2572     LEAVE;
2573     cxstack_ix--;
2574     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2575     PL_curpm = newpm;   /* ... and pop $1 et al */
2576
2577     LEAVESUB(sv);
2578     return cx->blk_sub.retop;
2579 }
2580
2581 PP(pp_last)
2582 {
2583     dVAR; dSP;
2584     I32 cxix;
2585     register PERL_CONTEXT *cx;
2586     I32 pop2 = 0;
2587     I32 gimme;
2588     I32 optype;
2589     OP *nextop = NULL;
2590     SV **newsp;
2591     PMOP *newpm;
2592     SV **mark;
2593     SV *sv = NULL;
2594
2595
2596     if (PL_op->op_flags & OPf_SPECIAL) {
2597         cxix = dopoptoloop(cxstack_ix);
2598         if (cxix < 0)
2599             DIE(aTHX_ "Can't \"last\" outside a loop block");
2600     }
2601     else {
2602         cxix = dopoptolabel(cPVOP->op_pv);
2603         if (cxix < 0)
2604             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2605     }
2606     if (cxix < cxstack_ix)
2607         dounwind(cxix);
2608
2609     POPBLOCK(cx,newpm);
2610     cxstack_ix++; /* temporarily protect top context */
2611     mark = newsp;
2612     switch (CxTYPE(cx)) {
2613     case CXt_LOOP_LAZYIV:
2614     case CXt_LOOP_LAZYSV:
2615     case CXt_LOOP_FOR:
2616     case CXt_LOOP_PLAIN:
2617         pop2 = CxTYPE(cx);
2618         newsp = PL_stack_base + cx->blk_loop.resetsp;
2619         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2620         break;
2621     case CXt_SUB:
2622         pop2 = CXt_SUB;
2623         nextop = cx->blk_sub.retop;
2624         break;
2625     case CXt_EVAL:
2626         POPEVAL(cx);
2627         nextop = cx->blk_eval.retop;
2628         break;
2629     case CXt_FORMAT:
2630         POPFORMAT(cx);
2631         nextop = cx->blk_sub.retop;
2632         break;
2633     default:
2634         DIE(aTHX_ "panic: last");
2635     }
2636
2637     TAINT_NOT;
2638     SP = adjust_stack_on_leave(newsp, SP, MARK, gimme,
2639                                 pop2 == CXt_SUB ? SVs_TEMP : 0);
2640     PUTBACK;
2641
2642     LEAVE;
2643     cxstack_ix--;
2644     /* Stack values are safe: */
2645     switch (pop2) {
2646     case CXt_LOOP_LAZYIV:
2647     case CXt_LOOP_PLAIN:
2648     case CXt_LOOP_LAZYSV:
2649     case CXt_LOOP_FOR:
2650         POPLOOP(cx);    /* release loop vars ... */
2651         LEAVE;
2652         break;
2653     case CXt_SUB:
2654         POPSUB(cx,sv);  /* release CV and @_ ... */
2655         break;
2656     }
2657     PL_curpm = newpm;   /* ... and pop $1 et al */
2658
2659     LEAVESUB(sv);
2660     PERL_UNUSED_VAR(optype);
2661     PERL_UNUSED_VAR(gimme);
2662     return nextop;
2663 }
2664
2665 PP(pp_next)
2666 {
2667     dVAR;
2668     I32 cxix;
2669     register PERL_CONTEXT *cx;
2670     I32 inner;
2671
2672     if (PL_op->op_flags & OPf_SPECIAL) {
2673         cxix = dopoptoloop(cxstack_ix);
2674         if (cxix < 0)
2675             DIE(aTHX_ "Can't \"next\" outside a loop block");
2676     }
2677     else {
2678         cxix = dopoptolabel(cPVOP->op_pv);
2679         if (cxix < 0)
2680             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2681     }
2682     if (cxix < cxstack_ix)
2683         dounwind(cxix);
2684
2685     /* clear off anything above the scope we're re-entering, but
2686      * save the rest until after a possible continue block */
2687     inner = PL_scopestack_ix;
2688     TOPBLOCK(cx);
2689     if (PL_scopestack_ix < inner)
2690         leave_scope(PL_scopestack[PL_scopestack_ix]);
2691     PL_curcop = cx->blk_oldcop;
2692     return (cx)->blk_loop.my_op->op_nextop;
2693 }
2694
2695 PP(pp_redo)
2696 {
2697     dVAR;
2698     I32 cxix;
2699     register PERL_CONTEXT *cx;
2700     I32 oldsave;
2701     OP* redo_op;
2702
2703     if (PL_op->op_flags & OPf_SPECIAL) {
2704         cxix = dopoptoloop(cxstack_ix);
2705         if (cxix < 0)
2706             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2707     }
2708     else {
2709         cxix = dopoptolabel(cPVOP->op_pv);
2710         if (cxix < 0)
2711             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2712     }
2713     if (cxix < cxstack_ix)
2714         dounwind(cxix);
2715
2716     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2717     if (redo_op->op_type == OP_ENTER) {
2718         /* pop one less context to avoid $x being freed in while (my $x..) */
2719         cxstack_ix++;
2720         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2721         redo_op = redo_op->op_next;
2722     }
2723
2724     TOPBLOCK(cx);
2725     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2726     LEAVE_SCOPE(oldsave);
2727     FREETMPS;
2728     PL_curcop = cx->blk_oldcop;
2729     return redo_op;
2730 }
2731
2732 STATIC OP *
2733 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2734 {
2735     dVAR;
2736     OP **ops = opstack;
2737     static const char too_deep[] = "Target of goto is too deeply nested";
2738
2739     PERL_ARGS_ASSERT_DOFINDLABEL;
2740
2741     if (ops >= oplimit)
2742         Perl_croak(aTHX_ too_deep);
2743     if (o->op_type == OP_LEAVE ||
2744         o->op_type == OP_SCOPE ||
2745         o->op_type == OP_LEAVELOOP ||
2746         o->op_type == OP_LEAVESUB ||
2747         o->op_type == OP_LEAVETRY)
2748     {
2749         *ops++ = cUNOPo->op_first;
2750         if (ops >= oplimit)
2751             Perl_croak(aTHX_ too_deep);
2752     }
2753     *ops = 0;
2754     if (o->op_flags & OPf_KIDS) {
2755         OP *kid;
2756         /* First try all the kids at this level, since that's likeliest. */
2757         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2758             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2759                 const char *kid_label = CopLABEL(kCOP);
2760                 if (kid_label && strEQ(kid_label, label))
2761                     return kid;
2762             }
2763         }
2764         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2765             if (kid == PL_lastgotoprobe)
2766                 continue;
2767             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2768                 if (ops == opstack)
2769                     *ops++ = kid;
2770                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2771                          ops[-1]->op_type == OP_DBSTATE)
2772                     ops[-1] = kid;
2773                 else
2774                     *ops++ = kid;
2775             }
2776             if ((o = dofindlabel(kid, label, ops, oplimit)))
2777                 return o;
2778         }
2779     }
2780     *ops = 0;
2781     return 0;
2782 }
2783
2784 PP(pp_goto)
2785 {
2786     dVAR; dSP;
2787     OP *retop = NULL;
2788     I32 ix;
2789     register PERL_CONTEXT *cx;
2790 #define GOTO_DEPTH 64
2791     OP *enterops[GOTO_DEPTH];
2792     const char *label = NULL;
2793     const bool do_dump = (PL_op->op_type == OP_DUMP);
2794     static const char must_have_label[] = "goto must have label";
2795
2796     if (PL_op->op_flags & OPf_STACKED) {
2797         SV * const sv = POPs;
2798
2799         /* This egregious kludge implements goto &subroutine */
2800         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2801             I32 cxix;
2802             register PERL_CONTEXT *cx;
2803             CV *cv = MUTABLE_CV(SvRV(sv));
2804             SV** mark;
2805             I32 items = 0;
2806             I32 oldsave;
2807             bool reified = 0;
2808
2809         retry:
2810             if (!CvROOT(cv) && !CvXSUB(cv)) {
2811                 const GV * const gv = CvGV(cv);
2812                 if (gv) {
2813                     GV *autogv;
2814                     SV *tmpstr;
2815                     /* autoloaded stub? */
2816                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2817                         goto retry;
2818                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2819                                           GvNAMELEN(gv),
2820                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2821                     if (autogv && (cv = GvCV(autogv)))
2822                         goto retry;
2823                     tmpstr = sv_newmortal();
2824                     gv_efullname3(tmpstr, gv, NULL);
2825                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2826                 }
2827                 DIE(aTHX_ "Goto undefined subroutine");
2828             }
2829
2830             /* First do some returnish stuff. */
2831             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2832             FREETMPS;
2833             cxix = dopoptosub(cxstack_ix);
2834             if (cxix < 0)
2835                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2836             if (cxix < cxstack_ix)
2837                 dounwind(cxix);
2838             TOPBLOCK(cx);
2839             SPAGAIN;
2840             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2841             if (CxTYPE(cx) == CXt_EVAL) {
2842                 if (CxREALEVAL(cx))
2843                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2844                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2845                 else
2846                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2847                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2848             }
2849             else if (CxMULTICALL(cx))
2850                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2851             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2852                 /* put @_ back onto stack */
2853                 AV* av = cx->blk_sub.argarray;
2854
2855                 items = AvFILLp(av) + 1;
2856                 EXTEND(SP, items+1); /* @_ could have been extended. */
2857                 Copy(AvARRAY(av), SP + 1, items, SV*);
2858                 SvREFCNT_dec(GvAV(PL_defgv));
2859                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2860                 CLEAR_ARGARRAY(av);
2861                 /* abandon @_ if it got reified */
2862                 if (AvREAL(av)) {
2863                     reified = 1;
2864                     SvREFCNT_dec(av);
2865                     av = newAV();
2866                     av_extend(av, items-1);
2867                     AvREIFY_only(av);
2868                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2869                 }
2870             }
2871             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2872                 AV* const av = GvAV(PL_defgv);
2873                 items = AvFILLp(av) + 1;
2874                 EXTEND(SP, items+1); /* @_ could have been extended. */
2875                 Copy(AvARRAY(av), SP + 1, items, SV*);
2876             }
2877             mark = SP;
2878             SP += items;
2879             if (CxTYPE(cx) == CXt_SUB &&
2880                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2881                 SvREFCNT_dec(cx->blk_sub.cv);
2882             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2883             LEAVE_SCOPE(oldsave);
2884
2885             /* A destructor called during LEAVE_SCOPE could have undefined
2886              * our precious cv.  See bug #99850. */
2887             if (!CvROOT(cv) && !CvXSUB(cv)) {
2888                 const GV * const gv = CvGV(cv);
2889                 if (gv) {
2890                     SV * const tmpstr = sv_newmortal();
2891                     gv_efullname3(tmpstr, gv, NULL);
2892                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2893                                SVfARG(tmpstr));
2894                 }
2895                 DIE(aTHX_ "Goto undefined subroutine");
2896             }
2897
2898             /* Now do some callish stuff. */
2899             SAVETMPS;
2900             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2901             if (CvISXSUB(cv)) {
2902                 OP* const retop = cx->blk_sub.retop;
2903                 SV **newsp PERL_UNUSED_DECL;
2904                 I32 gimme PERL_UNUSED_DECL;
2905                 if (reified) {
2906                     I32 index;
2907                     for (index=0; index<items; index++)
2908                         sv_2mortal(SP[-index]);
2909                 }
2910
2911                 /* XS subs don't have a CxSUB, so pop it */
2912                 POPBLOCK(cx, PL_curpm);
2913                 /* Push a mark for the start of arglist */
2914                 PUSHMARK(mark);
2915                 PUTBACK;
2916                 (void)(*CvXSUB(cv))(aTHX_ cv);
2917                 LEAVE;
2918                 return retop;
2919             }
2920             else {
2921                 AV* const padlist = CvPADLIST(cv);
2922                 if (CxTYPE(cx) == CXt_EVAL) {
2923                     PL_in_eval = CxOLD_IN_EVAL(cx);
2924                     PL_eval_root = cx->blk_eval.old_eval_root;
2925                     cx->cx_type = CXt_SUB;
2926                 }
2927                 cx->blk_sub.cv = cv;
2928                 cx->blk_sub.olddepth = CvDEPTH(cv);
2929
2930                 CvDEPTH(cv)++;
2931                 if (CvDEPTH(cv) < 2)
2932                     SvREFCNT_inc_simple_void_NN(cv);
2933                 else {
2934                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2935                         sub_crush_depth(cv);
2936                     pad_push(padlist, CvDEPTH(cv));
2937                 }
2938                 PL_curcop = cx->blk_oldcop;
2939                 SAVECOMPPAD();
2940                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2941                 if (CxHASARGS(cx))
2942                 {
2943                     AV *const av = MUTABLE_AV(PAD_SVl(0));
2944
2945                     cx->blk_sub.savearray = GvAV(PL_defgv);
2946                     GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2947                     CX_CURPAD_SAVE(cx->blk_sub);
2948                     cx->blk_sub.argarray = av;
2949
2950                     if (items >= AvMAX(av) + 1) {
2951                         SV **ary = AvALLOC(av);
2952                         if (AvARRAY(av) != ary) {
2953                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2954                             AvARRAY(av) = ary;
2955                         }
2956                         if (items >= AvMAX(av) + 1) {
2957                             AvMAX(av) = items - 1;
2958                             Renew(ary,items+1,SV*);
2959                             AvALLOC(av) = ary;
2960                             AvARRAY(av) = ary;
2961                         }
2962                     }
2963                     ++mark;
2964                     Copy(mark,AvARRAY(av),items,SV*);
2965                     AvFILLp(av) = items - 1;
2966                     assert(!AvREAL(av));
2967                     if (reified) {
2968                         /* transfer 'ownership' of refcnts to new @_ */
2969                         AvREAL_on(av);
2970                         AvREIFY_off(av);
2971                     }
2972                     while (items--) {
2973                         if (*mark)
2974                             SvTEMP_off(*mark);
2975                         mark++;
2976                     }
2977                 }
2978                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2979                     Perl_get_db_sub(aTHX_ NULL, cv);
2980                     if (PERLDB_GOTO) {
2981                         CV * const gotocv = get_cvs("DB::goto", 0);
2982                         if (gotocv) {
2983                             PUSHMARK( PL_stack_sp );
2984                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2985                             PL_stack_sp--;
2986                         }
2987                     }
2988                 }
2989                 RETURNOP(CvSTART(cv));
2990             }
2991         }
2992         else {
2993             label = SvPV_nolen_const(sv);
2994             if (!(do_dump || *label))
2995                 DIE(aTHX_ must_have_label);
2996         }
2997     }
2998     else if (PL_op->op_flags & OPf_SPECIAL) {
2999         if (! do_dump)
3000             DIE(aTHX_ must_have_label);
3001     }
3002     else
3003         label = cPVOP->op_pv;
3004
3005     PERL_ASYNC_CHECK();
3006
3007     if (label && *label) {
3008         OP *gotoprobe = NULL;
3009         bool leaving_eval = FALSE;
3010         bool in_block = FALSE;
3011         PERL_CONTEXT *last_eval_cx = NULL;
3012
3013         /* find label */
3014
3015         PL_lastgotoprobe = NULL;
3016         *enterops = 0;
3017         for (ix = cxstack_ix; ix >= 0; ix--) {
3018             cx = &cxstack[ix];
3019             switch (CxTYPE(cx)) {
3020             case CXt_EVAL:
3021                 leaving_eval = TRUE;
3022                 if (!CxTRYBLOCK(cx)) {
3023                     gotoprobe = (last_eval_cx ?
3024                                 last_eval_cx->blk_eval.old_eval_root :
3025                                 PL_eval_root);
3026                     last_eval_cx = cx;
3027                     break;
3028                 }
3029                 /* else fall through */
3030             case CXt_LOOP_LAZYIV:
3031             case CXt_LOOP_LAZYSV:
3032             case CXt_LOOP_FOR:
3033             case CXt_LOOP_PLAIN:
3034             case CXt_GIVEN:
3035             case CXt_WHEN:
3036                 gotoprobe = cx->blk_oldcop->op_sibling;
3037                 break;
3038             case CXt_SUBST:
3039                 continue;
3040             case CXt_BLOCK:
3041                 if (ix) {
3042                     gotoprobe = cx->blk_oldcop->op_sibling;
3043                     in_block = TRUE;
3044                 } else
3045                     gotoprobe = PL_main_root;
3046                 break;
3047             case CXt_SUB:
3048                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3049                     gotoprobe = CvROOT(cx->blk_sub.cv);
3050                     break;
3051                 }
3052                 /* FALL THROUGH */
3053             case CXt_FORMAT:
3054             case CXt_NULL:
3055                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3056             default:
3057                 if (ix)
3058                     DIE(aTHX_ "panic: goto");
3059                 gotoprobe = PL_main_root;
3060                 break;
3061             }
3062             if (gotoprobe) {
3063                 retop = dofindlabel(gotoprobe, label,
3064                                     enterops, enterops + GOTO_DEPTH);
3065                 if (retop)
3066                     break;
3067                 if (gotoprobe->op_sibling &&
3068                         gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3069                         gotoprobe->op_sibling->op_sibling) {
3070                     retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3071                                         label, enterops, enterops + GOTO_DEPTH);
3072                     if (retop)
3073                         break;
3074                 }
3075             }
3076             PL_lastgotoprobe = gotoprobe;
3077         }
3078         if (!retop)
3079             DIE(aTHX_ "Can't find label %s", label);
3080
3081         /* if we're leaving an eval, check before we pop any frames
3082            that we're not going to punt, otherwise the error
3083            won't be caught */
3084
3085         if (leaving_eval && *enterops && enterops[1]) {
3086             I32 i;
3087             for (i = 1; enterops[i]; i++)
3088                 if (enterops[i]->op_type == OP_ENTERITER)
3089                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3090         }
3091
3092         if (*enterops && enterops[1]) {
3093             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3094             if (enterops[i])
3095                 deprecate("\"goto\" to jump into a construct");
3096         }
3097
3098         /* pop unwanted frames */
3099
3100         if (ix < cxstack_ix) {
3101             I32 oldsave;
3102
3103             if (ix < 0)
3104                 ix = 0;
3105             dounwind(ix);
3106             TOPBLOCK(cx);
3107             oldsave = PL_scopestack[PL_scopestack_ix];
3108             LEAVE_SCOPE(oldsave);
3109         }
3110
3111         /* push wanted frames */
3112
3113         if (*enterops && enterops[1]) {
3114             OP * const oldop = PL_op;
3115             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3116             for (; enterops[ix]; ix++) {
3117                 PL_op = enterops[ix];
3118                 /* Eventually we may want to stack the needed arguments
3119                  * for each op.  For now, we punt on the hard ones. */
3120                 if (PL_op->op_type == OP_ENTERITER)
3121                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3122                 PL_op->op_ppaddr(aTHX);
3123             }
3124             PL_op = oldop;
3125         }
3126     }
3127
3128     if (do_dump) {
3129 #ifdef VMS
3130         if (!retop) retop = PL_main_start;
3131 #endif
3132         PL_restartop = retop;
3133         PL_do_undump = TRUE;
3134
3135         my_unexec();
3136
3137         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3138         PL_do_undump = FALSE;
3139     }
3140
3141     RETURNOP(retop);
3142 }
3143
3144 PP(pp_exit)
3145 {
3146     dVAR;
3147     dSP;
3148     I32 anum;
3149
3150     if (MAXARG < 1)
3151         anum = 0;
3152     else if (!TOPs) {
3153         anum = 0; (void)POPs;
3154     }
3155     else {
3156         anum = SvIVx(POPs);
3157 #ifdef VMS
3158         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3159             anum = 0;
3160         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3161 #endif
3162     }
3163     PL_exit_flags |= PERL_EXIT_EXPECTED;
3164 #ifdef PERL_MAD
3165     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3166     if (anum || !(PL_minus_c && PL_madskills))
3167         my_exit(anum);
3168 #else
3169     my_exit(anum);
3170 #endif
3171     PUSHs(&PL_sv_undef);
3172     RETURN;
3173 }
3174
3175 /* Eval. */
3176
3177 STATIC void
3178 S_save_lines(pTHX_ AV *array, SV *sv)
3179 {
3180     const char *s = SvPVX_const(sv);
3181     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3182     I32 line = 1;
3183
3184     PERL_ARGS_ASSERT_SAVE_LINES;
3185
3186     while (s && s < send) {
3187         const char *t;
3188         SV * const tmpstr = newSV_type(SVt_PVMG);
3189
3190         t = (const char *)memchr(s, '\n', send - s);
3191         if (t)
3192             t++;
3193         else
3194             t = send;
3195
3196         sv_setpvn(tmpstr, s, t - s);
3197         av_store(array, line++, tmpstr);
3198         s = t;
3199     }
3200 }
3201
3202 /*
3203 =for apidoc docatch
3204
3205 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3206
3207 0 is used as continue inside eval,
3208
3209 3 is used for a die caught by an inner eval - continue inner loop
3210
3211 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3212 establish a local jmpenv to handle exception traps.
3213
3214 =cut
3215 */
3216 STATIC OP *
3217 S_docatch(pTHX_ OP *o)
3218 {
3219     dVAR;
3220     int ret;
3221     OP * const oldop = PL_op;
3222     dJMPENV;
3223
3224 #ifdef DEBUGGING
3225     assert(CATCH_GET == TRUE);
3226 #endif
3227     PL_op = o;
3228
3229     JMPENV_PUSH(ret);
3230     switch (ret) {
3231     case 0:
3232         assert(cxstack_ix >= 0);
3233         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3234         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3235  redo_body:
3236         CALLRUNOPS(aTHX);
3237         break;
3238     case 3:
3239         /* die caught by an inner eval - continue inner loop */
3240         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3241             PL_restartjmpenv = NULL;
3242             PL_op = PL_restartop;
3243             PL_restartop = 0;
3244             goto redo_body;
3245         }
3246         /* FALL THROUGH */
3247     default:
3248         JMPENV_POP;
3249         PL_op = oldop;
3250         JMPENV_JUMP(ret);
3251         /* NOTREACHED */
3252     }
3253     JMPENV_POP;
3254     PL_op = oldop;
3255     return NULL;
3256 }
3257
3258 /* James Bond: Do you expect me to talk?
3259    Auric Goldfinger: No, Mr. Bond. I expect you to die.
3260
3261    This code is an ugly hack, doesn't work with lexicals in subroutines that are
3262    called more than once, and is only used by regcomp.c, for (?{}) blocks.
3263
3264    Currently it is not used outside the core code. Best if it stays that way.
3265
3266    Hence it's now deprecated, and will be removed.
3267 */
3268 OP *
3269 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
3270 /* sv Text to convert to OP tree. */
3271 /* startop op_free() this to undo. */
3272 /* code Short string id of the caller. */
3273 {
3274     PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3275     return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3276 }
3277
3278 /* Don't use this. It will go away without warning once the regexp engine is
3279    refactored not to use it.  */
3280 OP *
3281 Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3282                               PAD **padp)
3283 {
3284     dVAR; dSP;                          /* Make POPBLOCK work. */
3285     PERL_CONTEXT *cx;
3286     SV **newsp;
3287     I32 gimme = G_VOID;
3288     I32 optype;
3289     OP dummy;
3290     char tbuf[TYPE_DIGITS(long) + 12 + 10];
3291     char *tmpbuf = tbuf;
3292     char *safestr;
3293     int runtime;
3294     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
3295     STRLEN len;
3296     bool need_catch;
3297
3298     PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
3299
3300     ENTER_with_name("eval");
3301     lex_start(sv, NULL, LEX_START_SAME_FILTER);
3302     SAVETMPS;
3303     /* switch to eval mode */
3304
3305     if (IN_PERL_COMPILETIME) {
3306         SAVECOPSTASH_FREE(&PL_compiling);
3307         CopSTASH_set(&PL_compiling, PL_curstash);
3308     }
3309     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3310         SV * const sv = sv_newmortal();
3311         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3312                        code, (unsigned long)++PL_evalseq,
3313                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3314         tmpbuf = SvPVX(sv);
3315         len = SvCUR(sv);
3316     }
3317     else
3318         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3319                           (unsigned long)++PL_evalseq);
3320     SAVECOPFILE_FREE(&PL_compiling);
3321     CopFILE_set(&PL_compiling, tmpbuf+2);
3322     SAVECOPLINE(&PL_compiling);
3323     CopLINE_set(&PL_compiling, 1);
3324     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3325        deleting the eval's FILEGV from the stash before gv_check() runs
3326        (i.e. before run-time proper). To work around the coredump that
3327        ensues, we always turn GvMULTI_on for any globals that were
3328        introduced within evals. See force_ident(). GSAR 96-10-12 */
3329     safestr = savepvn(tmpbuf, len);
3330     SAVEDELETE(PL_defstash, safestr, len);
3331     SAVEHINTS();
3332 #ifdef OP_IN_REGISTER
3333     PL_opsave = op;
3334 #else
3335     SAVEVPTR(PL_op);
3336 #endif
3337
3338     /* we get here either during compilation, or via pp_regcomp at runtime */
3339     runtime = IN_PERL_RUNTIME;
3340     if (runtime)
3341     {
3342         runcv = find_runcv(NULL);
3343
3344         /* At run time, we have to fetch the hints from PL_curcop. */
3345         PL_hints = PL_curcop->cop_hints;
3346         if (PL_hints & HINT_LOCALIZE_HH) {
3347             /* SAVEHINTS created a new HV in PL_hintgv, which we
3348                need to GC */
3349             SvREFCNT_dec(GvHV(PL_hintgv));
3350             GvHV(PL_hintgv) =
3351              refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3352             hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3353         }
3354         SAVECOMPILEWARNINGS();
3355         PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3356         cophh_free(CopHINTHASH_get(&PL_compiling));
3357         /* XXX Does this need to avoid copying a label? */
3358         PL_compiling.cop_hints_hash
3359          = cophh_copy(PL_curcop->cop_hints_hash);
3360     }
3361
3362     PL_op = &dummy;
3363     PL_op->op_type = OP_ENTEREVAL;
3364     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
3365     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3366     PUSHEVAL(cx, 0);
3367     need_catch = CATCH_GET;
3368     CATCH_SET(TRUE);
3369
3370     if (runtime)
3371         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq, NULL);
3372     else
3373         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax, NULL);
3374     CATCH_SET(need_catch);
3375     POPBLOCK(cx,PL_curpm);
3376     POPEVAL(cx);
3377
3378     (*startop)->op_type = OP_NULL;
3379     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3380     /* XXX DAPM do this properly one year */
3381     *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3382     LEAVE_with_name("eval");
3383     if (IN_PERL_COMPILETIME)
3384         CopHINTS_set(&PL_compiling, PL_hints);
3385 #ifdef OP_IN_REGISTER
3386     op = PL_opsave;
3387 #endif
3388     PERL_UNUSED_VAR(newsp);
3389     PERL_UNUSED_VAR(optype);
3390
3391     return PL_eval_start;
3392 }
3393
3394
3395 /*
3396 =for apidoc find_runcv
3397
3398 Locate the CV corresponding to the currently executing sub or eval.
3399 If db_seqp is non_null, skip CVs that are in the DB package and populate
3400 *db_seqp with the cop sequence number at the point that the DB:: code was
3401 entered. (allows debuggers to eval in the scope of the breakpoint rather
3402 than in the scope of the debugger itself).
3403
3404 =cut
3405 */
3406
3407 CV*
3408 Perl_find_runcv(pTHX_ U32 *db_seqp)
3409 {
3410     dVAR;
3411     PERL_SI      *si;
3412
3413     if (db_seqp)
3414         *db_seqp = PL_curcop->cop_seq;
3415     for (si = PL_curstackinfo; si; si = si->si_prev) {
3416         I32 ix;
3417         for (ix = si->si_cxix; ix >= 0; ix--) {
3418             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3419             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3420                 CV * const cv = cx->blk_sub.cv;
3421                 /* skip DB:: code */
3422                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3423                     *db_seqp = cx->blk_oldcop->cop_seq;
3424                     continue;
3425                 }
3426                 return cv;
3427             }
3428             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3429                 return cx->blk_eval.cv;
3430         }
3431     }
3432     return PL_main_cv;
3433 }
3434
3435
3436 /* Run yyparse() in a setjmp wrapper. Returns:
3437  *   0: yyparse() successful
3438  *   1: yyparse() failed
3439  *   3: yyparse() died
3440  */
3441 STATIC int
3442 S_try_yyparse(pTHX_ int gramtype)
3443 {
3444     int ret;
3445     dJMPENV;
3446
3447     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3448     JMPENV_PUSH(ret);
3449     switch (ret) {
3450     case 0:
3451         ret = yyparse(gramtype) ? 1 : 0;
3452         break;
3453     case 3:
3454         break;
3455     default:
3456         JMPENV_POP;
3457         JMPENV_JUMP(ret);
3458         /* NOTREACHED */
3459     }
3460     JMPENV_POP;
3461     return ret;
3462 }
3463
3464
3465 /* Compile a require/do, an eval '', or a /(?{...})/.
3466  * In the last case, startop is non-null, and contains the address of
3467  * a pointer that should be set to the just-compiled code.
3468  * outside is the lexically enclosing CV (if any) that invoked us.
3469  * Returns a bool indicating whether the compile was successful; if so,
3470  * PL_eval_start contains the first op of the compiled ocde; otherwise,
3471  * pushes undef (also croaks if startop != NULL).
3472  */
3473
3474 /* This function is called from three places, sv_compile_2op, pp_return
3475  * and pp_entereval.  These can be distinguished as follows:
3476  *    sv_compile_2op - startop is non-null
3477  *    pp_require     - startop is null; in_require is true
3478  *    pp_entereval   - stortop is null; in_require is false
3479  */
3480
3481 STATIC bool
3482 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
3483 {
3484     dVAR; dSP;
3485     OP * const saveop = PL_op;
3486     COP * const oldcurcop = PL_curcop;
3487     bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3488     int yystatus;
3489     CV *evalcv;
3490
3491     PL_in_eval = (in_require
3492                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3493                   : EVAL_INEVAL);
3494
3495     PUSHMARK(SP);
3496
3497     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3498     CvEVAL_on(evalcv);
3499     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3500     cxstack[cxstack_ix].blk_eval.cv = evalcv;
3501     cxstack[cxstack_ix].blk_gimme = gimme;
3502
3503     CvOUTSIDE_SEQ(evalcv) = seq;
3504     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3505
3506     /* set up a scratch pad */
3507
3508     CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3509     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3510
3511
3512     if (!PL_madskills)
3513         SAVEMORTALIZESV(evalcv);        /* must remain until end of current statement */
3514
3515     /* make sure we compile in the right package */
3516
3517     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3518         SAVEGENERICSV(PL_curstash);
3519         PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop));
3520     }
3521     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3522     SAVESPTR(PL_beginav);
3523     PL_beginav = newAV();
3524     SAVEFREESV(PL_beginav);
3525     SAVESPTR(PL_unitcheckav);
3526     PL_unitcheckav = newAV();
3527     SAVEFREESV(PL_unitcheckav);
3528
3529 #ifdef PERL_MAD
3530     SAVEBOOL(PL_madskills);
3531     PL_madskills = 0;
3532 #endif
3533
3534     if (!startop) ENTER_with_name("evalcomp");
3535     SAVESPTR(PL_compcv);
3536     PL_compcv = evalcv;
3537
3538     /* try to compile it */
3539
3540     PL_eval_root = NULL;
3541     PL_curcop = &PL_compiling;
3542     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3543         PL_in_eval |= EVAL_KEEPERR;
3544     else
3545         CLEAR_ERRSV();
3546
3547     if (!startop) {
3548         SAVEHINTS();
3549         if (in_require) {
3550             PL_hints = 0;
3551             hv_clear(GvHV(PL_hintgv));
3552         }
3553         else {
3554             PL_hints = saveop->op_private & OPpEVAL_COPHH
3555                          ? oldcurcop->cop_hints : saveop->op_targ;
3556             if (hh) {
3557                 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3558                 SvREFCNT_dec(GvHV(PL_hintgv));
3559                 GvHV(PL_hintgv) = hh;
3560             }
3561         }
3562         SAVECOMPILEWARNINGS();
3563         if (in_require) {
3564             if (PL_dowarn & G_WARN_ALL_ON)
3565                 PL_compiling.cop_warnings = pWARN_ALL ;
3566             else if (PL_dowarn & G_WARN_ALL_OFF)
3567                 PL_compiling.cop_warnings = pWARN_NONE ;
3568             else
3569                 PL_compiling.cop_warnings = pWARN_STD ;
3570         }
3571         else {
3572             PL_compiling.cop_warnings =
3573                 DUP_WARNINGS(oldcurcop->cop_warnings);
3574             cophh_free(CopHINTHASH_get(&PL_compiling));
3575             if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3576                 /* The label, if present, is the first entry on the chain. So rather
3577                    than writing a blank label in front of it (which involves an
3578                    allocation), just use the next entry in the chain.  */
3579                 PL_compiling.cop_hints_hash
3580                     = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3581                 /* Check the assumption that this removed the label.  */
3582                 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3583             }
3584             else
3585                 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3586         }
3587     }
3588
3589     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3590
3591     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3592      * so honour CATCH_GET and trap it here if necessary */
3593
3594     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3595
3596     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3597         SV **newsp;                     /* Used by POPBLOCK. */
3598         PERL_CONTEXT *cx;
3599         I32 optype;                     /* Used by POPEVAL. */
3600         SV *namesv;
3601
3602         cx = NULL;
3603         namesv = NULL;
3604         PERL_UNUSED_VAR(newsp);
3605         PERL_UNUSED_VAR(optype);
3606
3607         /* note that if yystatus == 3, then the EVAL CX block has already
3608          * been popped, and various vars restored */
3609         PL_op = saveop;
3610         if (yystatus != 3) {
3611             if (PL_eval_root) {
3612                 op_free(PL_eval_root);
3613                 PL_eval_root = NULL;
3614             }
3615             SP = PL_stack_base + POPMARK;       /* pop original mark */
3616             if (!startop) {
3617                 POPBLOCK(cx,PL_curpm);
3618                 POPEVAL(cx);
3619                 namesv = cx->blk_eval.old_namesv;
3620             }
3621             /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3622             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3623         }
3624
3625         if (in_require) {
3626             if (!cx) {
3627                 /* If cx is still NULL, it means that we didn't go in the
3628                  * POPEVAL branch. */
3629                 cx = &cxstack[cxstack_ix];
3630                 assert(CxTYPE(cx) == CXt_EVAL);
3631                 namesv = cx->blk_eval.old_namesv;
3632             }
3633             (void)hv_store(GvHVn(PL_incgv),
3634                            SvPVX_const(namesv),
3635                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3636                            &PL_sv_undef, 0);
3637             Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3638                        SVfARG(ERRSV
3639                                 ? ERRSV
3640                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3641         }
3642         else if (startop) {
3643             if (yystatus != 3) {
3644                 POPBLOCK(cx,PL_curpm);
3645                 POPEVAL(cx);
3646             }
3647             Perl_croak(aTHX_ "%"SVf"Compilation failed in regexp",
3648                        SVfARG(ERRSV
3649                                 ? ERRSV
3650                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3651         }
3652         else {
3653             if (!*(SvPVx_nolen_const(ERRSV))) {
3654                 sv_setpvs(ERRSV, "Compilation error");
3655             }
3656         }
3657         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3658         PUTBACK;
3659         return FALSE;
3660     }
3661     else if (!startop) LEAVE_with_name("evalcomp");
3662     CopLINE_set(&PL_compiling, 0);
3663     if (startop) {
3664         *startop = PL_eval_root;
3665     } else
3666         SAVEFREEOP(PL_eval_root);
3667
3668     DEBUG_x(dump_eval());
3669
3670     /* Register with debugger: */
3671     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3672         CV * const cv = get_cvs("DB::postponed", 0);
3673         if (cv) {
3674             dSP;
3675             PUSHMARK(SP);
3676             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3677             PUTBACK;
3678             call_sv(MUTABLE_SV(cv), G_DISCARD);
3679         }
3680     }
3681
3682     if (PL_unitcheckav) {
3683         OP *es = PL_eval_start;
3684         call_list(PL_scopestack_ix, PL_unitcheckav);
3685         PL_eval_start = es;
3686     }
3687
3688     /* compiled okay, so do it */
3689
3690     CvDEPTH(evalcv) = 1;
3691     SP = PL_stack_base + POPMARK;               /* pop original mark */
3692     PL_op = saveop;                     /* The caller may need it. */
3693     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3694
3695     PUTBACK;
3696     return TRUE;
3697 }
3698
3699 STATIC PerlIO *
3700 S_check_type_and_open(pTHX_ SV *name)
3701 {
3702     Stat_t st;
3703     const char *p = SvPV_nolen_const(name);
3704     const int st_rc = PerlLIO_stat(p, &st);
3705
3706     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3707
3708     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3709         return NULL;
3710     }
3711
3712 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3713     return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3714 #else
3715     return PerlIO_open(p, PERL_SCRIPT_MODE);
3716 #endif
3717 }
3718
3719 #ifndef PERL_DISABLE_PMC
3720 STATIC PerlIO *
3721 S_doopen_pm(pTHX_ SV *name)
3722 {
3723     STRLEN namelen;
3724     const char *p = SvPV_const(name, namelen);
3725
3726     PERL_ARGS_ASSERT_DOOPEN_PM;
3727
3728     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3729         SV *const pmcsv = sv_newmortal();
3730         Stat_t pmcstat;
3731
3732         SvSetSV_nosteal(pmcsv,name);
3733         sv_catpvn(pmcsv, "c", 1);
3734
3735         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3736             return check_type_and_open(pmcsv);
3737     }
3738     return check_type_and_open(name);
3739 }
3740 #else
3741 #  define doopen_pm(name) check_type_and_open(name)
3742 #endif /* !PERL_DISABLE_PMC */
3743
3744 PP(pp_require)
3745 {
3746     dVAR; dSP;
3747     register PERL_CONTEXT *cx;
3748     SV *sv;
3749     const char *name;
3750     STRLEN len;
3751     char * unixname;
3752     STRLEN unixlen;
3753 #ifdef VMS
3754     int vms_unixname = 0;
3755 #endif
3756     const char *tryname = NULL;
3757     SV *namesv = NULL;
3758     const I32 gimme = GIMME_V;
3759     int filter_has_file = 0;
3760     PerlIO *tryrsfp = NULL;
3761     SV *filter_cache = NULL;
3762     SV *filter_state = NULL;
3763     SV *filter_sub = NULL;
3764     SV *hook_sv = NULL;
3765     SV *encoding;
3766     OP *op;
3767
3768     sv = POPs;
3769     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3770         sv = sv_2mortal(new_version(sv));
3771         if (!sv_derived_from(PL_patchlevel, "version"))
3772             upg_version(PL_patchlevel, TRUE);
3773         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3774             if ( vcmp(sv,PL_patchlevel) <= 0 )
3775                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3776                     SVfARG(sv_2mortal(vnormal(sv))),
3777                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3778                 );
3779         }
3780         else {
3781             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3782                 I32 first = 0;
3783                 AV *lav;
3784                 SV * const req = SvRV(sv);
3785                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3786
3787                 /* get the left hand term */
3788                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3789
3790                 first  = SvIV(*av_fetch(lav,0,0));
3791                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3792                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3793                     || av_len(lav) > 1               /* FP with > 3 digits */
3794                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3795                    ) {
3796                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3797                         "%"SVf", stopped",
3798                         SVfARG(sv_2mortal(vnormal(req))),
3799                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3800                     );
3801                 }
3802                 else { /* probably 'use 5.10' or 'use 5.8' */
3803                     SV *hintsv;
3804                     I32 second = 0;
3805
3806                     if (av_len(lav)>=1) 
3807                         second = SvIV(*av_fetch(lav,1,0));
3808
3809                     second /= second >= 600  ? 100 : 10;
3810                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3811                                            (int)first, (int)second);
3812                     upg_version(hintsv, TRUE);
3813
3814                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3815                         "--this is only %"SVf", stopped",
3816                         SVfARG(sv_2mortal(vnormal(req))),
3817                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3818                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3819                     );
3820                 }
3821             }
3822         }
3823
3824         RETPUSHYES;
3825     }
3826     name = SvPV_const(sv, len);
3827     if (!(name && len > 0 && *name))
3828         DIE(aTHX_ "Null filename used");
3829     TAINT_PROPER("require");
3830
3831
3832 #ifdef VMS
3833     /* The key in the %ENV hash is in the syntax of file passed as the argument
3834      * usually this is in UNIX format, but sometimes in VMS format, which
3835      * can result in a module being pulled in more than once.
3836      * To prevent this, the key must be stored in UNIX format if the VMS
3837      * name can be translated to UNIX.
3838      */
3839     if ((unixname = tounixspec(name, NULL)) != NULL) {
3840         unixlen = strlen(unixname);
3841         vms_unixname = 1;
3842     }
3843     else
3844 #endif
3845     {
3846         /* if not VMS or VMS name can not be translated to UNIX, pass it
3847          * through.
3848          */
3849         unixname = (char *) name;
3850         unixlen = len;
3851     }
3852     if (PL_op->op_type == OP_REQUIRE) {
3853         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3854                                           unixname, unixlen, 0);
3855         if ( svp ) {
3856             if (*svp != &PL_sv_undef)
3857                 RETPUSHYES;
3858             else
3859                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3860                             "Compilation failed in require", unixname);
3861         }
3862     }
3863
3864     /* prepare to compile file */
3865
3866     if (path_is_absolute(name)) {
3867         /* At this point, name is SvPVX(sv)  */
3868         tryname = name;
3869         tryrsfp = doopen_pm(sv);
3870     }
3871     if (!tryrsfp) {
3872         AV * const ar = GvAVn(PL_incgv);
3873         I32 i;
3874 #ifdef VMS
3875         if (vms_unixname)
3876 #endif
3877         {
3878             namesv = newSV_type(SVt_PV);
3879             for (i = 0; i <= AvFILL(ar); i++) {
3880                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3881
3882                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3883                     mg_get(dirsv);
3884                 if (SvROK(dirsv)) {
3885                     int count;
3886                     SV **svp;
3887                     SV *loader = dirsv;
3888
3889                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3890                         && !sv_isobject(loader))
3891                     {
3892                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3893                     }
3894
3895                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3896                                    PTR2UV(SvRV(dirsv)), name);
3897                     tryname = SvPVX_const(namesv);
3898                     tryrsfp = NULL;
3899
3900                     ENTER_with_name("call_INC");
3901                     SAVETMPS;
3902                     EXTEND(SP, 2);
3903
3904                     PUSHMARK(SP);
3905                     PUSHs(dirsv);
3906                     PUSHs(sv);
3907                     PUTBACK;
3908                     if (sv_isobject(loader))
3909                         count = call_method("INC", G_ARRAY);
3910                     else
3911                         count = call_sv(loader, G_ARRAY);
3912                     SPAGAIN;
3913
3914                     if (count > 0) {
3915                         int i = 0;
3916                         SV *arg;
3917
3918                         SP -= count - 1;
3919                         arg = SP[i++];
3920
3921                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3922                             && !isGV_with_GP(SvRV(arg))) {
3923                             filter_cache = SvRV(arg);
3924                             SvREFCNT_inc_simple_void_NN(filter_cache);
3925
3926                             if (i < count) {
3927                                 arg = SP[i++];
3928                             }
3929                         }
3930
3931                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3932                             arg = SvRV(arg);
3933                         }
3934
3935                         if (isGV_with_GP(arg)) {
3936                             IO * const io = GvIO((const GV *)arg);
3937
3938                             ++filter_has_file;
3939
3940                             if (io) {
3941                                 tryrsfp = IoIFP(io);
3942                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3943                                     PerlIO_close(IoOFP(io));
3944                                 }
3945                                 IoIFP(io) = NULL;
3946                                 IoOFP(io) = NULL;
3947                             }
3948
3949                             if (i < count) {
3950                                 arg = SP[i++];
3951                             }
3952                         }
3953
3954                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3955                             filter_sub = arg;
3956                             SvREFCNT_inc_simple_void_NN(filter_sub);
3957
3958                             if (i < count) {
3959                                 filter_state = SP[i];
3960                                 SvREFCNT_inc_simple_void(filter_state);
3961                             }
3962                         }
3963
3964                         if (!tryrsfp && (filter_cache || filter_sub)) {
3965                             tryrsfp = PerlIO_open(BIT_BUCKET,
3966                                                   PERL_SCRIPT_MODE);
3967                         }
3968                         SP--;
3969                     }
3970
3971                     PUTBACK;
3972                     FREETMPS;
3973                     LEAVE_with_name("call_INC");
3974
3975                     /* Adjust file name if the hook has set an %INC entry.
3976                        This needs to happen after the FREETMPS above.  */
3977                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3978                     if (svp)
3979                         tryname = SvPV_nolen_const(*svp);
3980
3981                     if (tryrsfp) {
3982                         hook_sv = dirsv;
3983                         break;
3984                     }
3985
3986                     filter_has_file = 0;
3987                     if (filter_cache) {
3988                         SvREFCNT_dec(filter_cache);
3989                         filter_cache = NULL;
3990                     }
3991                     if (filter_state) {
3992                         SvREFCNT_dec(filter_state);
3993                         filter_state = NULL;
3994                     }
3995                     if (filter_sub) {
3996                         SvREFCNT_dec(filter_sub);
3997                         filter_sub = NULL;
3998                     }
3999                 }
4000                 else {
4001                   if (!path_is_absolute(name)
4002                   ) {
4003                     const char *dir;
4004                     STRLEN dirlen;
4005
4006                     if (SvOK(dirsv)) {
4007                         dir = SvPV_const(dirsv, dirlen);
4008                     } else {
4009                         dir = "";
4010                         dirlen = 0;
4011                     }
4012
4013 #ifdef VMS
4014                     char *unixdir;
4015                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
4016                         continue;
4017                     sv_setpv(namesv, unixdir);
4018                     sv_catpv(namesv, unixname);
4019 #else
4020 #  ifdef __SYMBIAN32__
4021                     if (PL_origfilename[0] &&
4022                         PL_origfilename[1] == ':' &&
4023                         !(dir[0] && dir[1] == ':'))
4024                         Perl_sv_setpvf(aTHX_ namesv,
4025                                        "%c:%s\\%s",
4026                                        PL_origfilename[0],
4027                                        dir, name);
4028                     else
4029                         Perl_sv_setpvf(aTHX_ namesv,
4030                                        "%s\\%s",
4031                                        dir, name);
4032 #  else
4033                     /* The equivalent of                    
4034                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4035                        but without the need to parse the format string, or
4036                        call strlen on either pointer, and with the correct
4037                        allocation up front.  */
4038                     {
4039                         char *tmp = SvGROW(namesv, dirlen + len + 2);
4040
4041                         memcpy(tmp, dir, dirlen);
4042                         tmp +=dirlen;
4043                         *tmp++ = '/';
4044                         /* name came from an SV, so it will have a '\0' at the
4045                            end that we can copy as part of this memcpy().  */
4046                         memcpy(tmp, name, len + 1);
4047
4048                         SvCUR_set(namesv, dirlen + len + 1);
4049                         SvPOK_on(namesv);
4050                     }
4051 #  endif
4052 #endif
4053                     TAINT_PROPER("require");
4054                     tryname = SvPVX_const(namesv);
4055                     tryrsfp = doopen_pm(namesv);
4056                     if (tryrsfp) {
4057                         if (tryname[0] == '.' && tryname[1] == '/') {
4058                             ++tryname;
4059                             while (*++tryname == '/');
4060                         }
4061                         break;
4062                     }
4063                     else if (errno == EMFILE)
4064                         /* no point in trying other paths if out of handles */
4065                         break;
4066                   }
4067                 }
4068             }
4069         }
4070     }
4071     sv_2mortal(namesv);
4072     if (!tryrsfp) {
4073         if (PL_op->op_type == OP_REQUIRE) {
4074             if(errno == EMFILE) {
4075                 /* diag_listed_as: Can't locate %s */
4076                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(errno));
4077             } else {
4078                 if (namesv) {                   /* did we lookup @INC? */
4079                     AV * const ar = GvAVn(PL_incgv);
4080                     I32 i;
4081                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4082                     for (i = 0; i <= AvFILL(ar); i++) {
4083                         sv_catpvs(inc, " ");
4084                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4085                     }
4086
4087                     /* diag_listed_as: Can't locate %s */
4088                     DIE(aTHX_
4089                         "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
4090                         name,
4091                         (memEQ(name + len - 2, ".h", 3)
4092                          ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
4093                         (memEQ(name + len - 3, ".ph", 4)
4094                          ? " (did you run h2ph?)" : ""),
4095                         inc
4096                         );
4097                 }
4098             }
4099             DIE(aTHX_ "Can't locate %s", name);
4100         }
4101
4102         RETPUSHUNDEF;
4103     }
4104     else
4105         SETERRNO(0, SS_NORMAL);
4106
4107     /* Assume success here to prevent recursive requirement. */
4108     /* name is never assigned to again, so len is still strlen(name)  */
4109     /* Check whether a hook in @INC has already filled %INC */
4110     if (!hook_sv) {
4111         (void)hv_store(GvHVn(PL_incgv),
4112                        unixname, unixlen, newSVpv(tryname,0),0);
4113     } else {
4114         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4115         if (!svp)
4116             (void)hv_store(GvHVn(PL_incgv),
4117                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4118     }
4119
4120     ENTER_with_name("eval");
4121     SAVETMPS;
4122     SAVECOPFILE_FREE(&PL_compiling);
4123     CopFILE_set(&PL_compiling, tryname);
4124     lex_start(NULL, tryrsfp, 0);
4125
4126     if (filter_sub || filter_cache) {
4127         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4128            than hanging another SV from it. In turn, filter_add() optionally
4129            takes the SV to use as the filter (or creates a new SV if passed
4130            NULL), so simply pass in whatever value filter_cache has.  */
4131         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
4132         IoLINES(datasv) = filter_has_file;
4133         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4134         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4135     }
4136
4137     /* switch to eval mode */
4138     PUSHBLOCK(cx, CXt_EVAL, SP);
4139     PUSHEVAL(cx, name);
4140     cx->blk_eval.retop = PL_op->op_next;
4141
4142     SAVECOPLINE(&PL_compiling);
4143     CopLINE_set(&PL_compiling, 0);
4144
4145     PUTBACK;
4146
4147     /* Store and reset encoding. */
4148     encoding = PL_encoding;
4149     PL_encoding = NULL;
4150
4151     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq, NULL))
4152         op = DOCATCH(PL_eval_start);
4153     else
4154         op = PL_op->op_next;
4155
4156     /* Restore encoding. */
4157     PL_encoding = encoding;
4158
4159     return op;
4160 }
4161
4162 /* This is a op added to hold the hints hash for
4163    pp_entereval. The hash can be modified by the code
4164    being eval'ed, so we return a copy instead. */
4165
4166 PP(pp_hintseval)
4167 {
4168     dVAR;
4169     dSP;
4170     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4171     RETURN;
4172 }
4173
4174
4175 PP(pp_entereval)
4176 {
4177     dVAR; dSP;
4178     register PERL_CONTEXT *cx;
4179     SV *sv;
4180     const I32 gimme = GIMME_V;
4181     const U32 was = PL_breakable_sub_gen;
4182     char tbuf[TYPE_DIGITS(long) + 12];
4183     bool saved_delete = FALSE;
4184     char *tmpbuf = tbuf;
4185     STRLEN len;
4186     CV* runcv;
4187     U32 seq, lex_flags = 0;
4188     HV *saved_hh = NULL;
4189     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4190
4191     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4192         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4193     }
4194     else if (PL_hints & HINT_LOCALIZE_HH || (
4195                 PL_op->op_private & OPpEVAL_COPHH
4196              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4197             )) {
4198         saved_hh = cop_hints_2hv(PL_curcop, 0);
4199         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4200     }
4201     sv = POPs;
4202     if (!SvPOK(sv)) {
4203         /* make sure we've got a plain PV (no overload etc) before testing
4204          * for taint. Making a copy here is probably overkill, but better
4205          * safe than sorry */
4206         STRLEN len;
4207         const char * const p = SvPV_const(sv, len);
4208
4209         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4210         lex_flags |= LEX_START_COPIED;
4211
4212         if (bytes && SvUTF8(sv))
4213             SvPVbyte_force(sv, len);
4214     }
4215     else if (bytes && SvUTF8(sv)) {
4216         /* Don't modify someone else's scalar */
4217         STRLEN len;
4218         sv = newSVsv(sv);
4219         (void)sv_2mortal(sv);
4220         SvPVbyte_force(sv,len);
4221         lex_flags |= LEX_START_COPIED;
4222     }
4223
4224     TAINT_IF(SvTAINTED(sv));
4225     TAINT_PROPER("eval");
4226
4227     ENTER_with_name("eval");
4228     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4229                            ? LEX_IGNORE_UTF8_HINTS
4230                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4231                         )
4232              );
4233     SAVETMPS;
4234
4235     /* switch to eval mode */
4236
4237     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4238         SV * const temp_sv = sv_newmortal();
4239         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4240                        (unsigned long)++PL_evalseq,
4241                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4242         tmpbuf = SvPVX(temp_sv);
4243         len = SvCUR(temp_sv);
4244     }
4245     else
4246         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4247     SAVECOPFILE_FREE(&PL_compiling);
4248     CopFILE_set(&PL_compiling, tmpbuf+2);
4249     SAVECOPLINE(&PL_compiling);
4250     CopLINE_set(&PL_compiling, 1);
4251     /* special case: an eval '' executed within the DB package gets lexically
4252      * placed in the first non-DB CV rather than the current CV - this
4253      * allows the debugger to execute code, find lexicals etc, in the
4254      * scope of the code being debugged. Passing &seq gets find_runcv
4255      * to do the dirty work for us */
4256     runcv = find_runcv(&seq);
4257
4258     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4259     PUSHEVAL(cx, 0);
4260     cx->blk_eval.retop = PL_op->op_next;
4261
4262     /* prepare to compile string */
4263
4264     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4265         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4266     else {
4267         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4268            deleting the eval's FILEGV from the stash before gv_check() runs
4269            (i.e. before run-time proper). To work around the coredump that
4270            ensues, we always turn GvMULTI_on for any globals that were
4271            introduced within evals. See force_ident(). GSAR 96-10-12 */
4272         char *const safestr = savepvn(tmpbuf, len);
4273         SAVEDELETE(PL_defstash, safestr, len);
4274         saved_delete = TRUE;
4275     }
4276     
4277     PUTBACK;
4278
4279     if (doeval(gimme, NULL, runcv, seq, saved_hh)) {
4280         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4281             ? (PERLDB_LINE || PERLDB_SAVESRC)
4282             :  PERLDB_SAVESRC_NOSUBS) {
4283             /* Retain the filegv we created.  */
4284         } else if (!saved_delete) {
4285             char *const safestr = savepvn(tmpbuf, len);
4286             SAVEDELETE(PL_defstash, safestr, len);
4287         }
4288         return DOCATCH(PL_eval_start);
4289     } else {
4290         /* We have already left the scope set up earlier thanks to the LEAVE
4291            in doeval().  */
4292         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4293             ? (PERLDB_LINE || PERLDB_SAVESRC)
4294             :  PERLDB_SAVESRC_INVALID) {
4295             /* Retain the filegv we created.  */
4296         } else if (!saved_delete) {
4297             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4298         }
4299         return PL_op->op_next;
4300     }
4301 }
4302
4303 PP(pp_leaveeval)
4304 {
4305     dVAR; dSP;
4306     SV **newsp;
4307     PMOP *newpm;
4308     I32 gimme;
4309     register PERL_CONTEXT *cx;
4310     OP *retop;
4311     const U8 save_flags = PL_op -> op_flags;
4312     I32 optype;
4313     SV *namesv;
4314     CV *evalcv;
4315
4316     PERL_ASYNC_CHECK();
4317     POPBLOCK(cx,newpm);
4318     POPEVAL(cx);
4319     namesv = cx->blk_eval.old_namesv;
4320     retop = cx->blk_eval.retop;
4321     evalcv = cx->blk_eval.cv;
4322
4323     TAINT_NOT;
4324     SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4325                                 gimme, SVs_TEMP);
4326     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4327
4328 #ifdef DEBUGGING
4329     assert(CvDEPTH(evalcv) == 1);
4330 #endif
4331     CvDEPTH(evalcv) = 0;
4332
4333     if (optype == OP_REQUIRE &&
4334         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4335     {
4336         /* Unassume the success we assumed earlier. */
4337         (void)hv_delete(GvHVn(PL_incgv),
4338                         SvPVX_const(namesv),
4339                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4340                         G_DISCARD);
4341         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4342                                SVfARG(namesv));
4343         /* die_unwind() did LEAVE, or we won't be here */
4344     }
4345     else {
4346         LEAVE_with_name("eval");
4347         if (!(save_flags & OPf_SPECIAL)) {
4348             CLEAR_ERRSV();
4349         }
4350     }
4351
4352     RETURNOP(retop);
4353 }
4354
4355 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4356    close to the related Perl_create_eval_scope.  */
4357 void
4358 Perl_delete_eval_scope(pTHX)
4359 {
4360     SV **newsp;
4361     PMOP *newpm;
4362     I32 gimme;
4363     register PERL_CONTEXT *cx;
4364     I32 optype;
4365         
4366     POPBLOCK(cx,newpm);
4367     POPEVAL(cx);
4368     PL_curpm = newpm;
4369     LEAVE_with_name("eval_scope");
4370     PERL_UNUSED_VAR(newsp);
4371     PERL_UNUSED_VAR(gimme);
4372     PERL_UNUSED_VAR(optype);
4373 }
4374
4375 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4376    also needed by Perl_fold_constants.  */
4377 PERL_CONTEXT *
4378 Perl_create_eval_scope(pTHX_ U32 flags)
4379 {
4380     PERL_CONTEXT *cx;
4381     const I32 gimme = GIMME_V;
4382         
4383     ENTER_with_name("eval_scope");
4384     SAVETMPS;
4385
4386     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4387     PUSHEVAL(cx, 0);
4388
4389     PL_in_eval = EVAL_INEVAL;
4390     if (flags & G_KEEPERR)
4391         PL_in_eval |= EVAL_KEEPERR;
4392     else
4393         CLEAR_ERRSV();
4394     if (flags & G_FAKINGEVAL) {
4395         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4396     }
4397     return cx;
4398 }
4399     
4400 PP(pp_entertry)
4401 {
4402     dVAR;
4403     PERL_CONTEXT * const cx = create_eval_scope(0);
4404     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4405     return DOCATCH(PL_op->op_next);
4406 }
4407
4408 PP(pp_leavetry)
4409 {
4410     dVAR; dSP;
4411     SV **newsp;
4412     PMOP *newpm;
4413     I32 gimme;
4414     register PERL_CONTEXT *cx;
4415     I32 optype;
4416
4417     PERL_ASYNC_CHECK();
4418     POPBLOCK(cx,newpm);
4419     POPEVAL(cx);
4420     PERL_UNUSED_VAR(optype);
4421
4422     TAINT_NOT;
4423     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4424     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4425
4426     LEAVE_with_name("eval_scope");
4427     CLEAR_ERRSV();
4428     RETURN;
4429 }
4430
4431 PP(pp_entergiven)
4432 {
4433     dVAR; dSP;
4434     register PERL_CONTEXT *cx;
4435     const I32 gimme = GIMME_V;
4436     
4437     ENTER_with_name("given");
4438     SAVETMPS;
4439
4440     SAVECLEARSV(PAD_SVl(PL_op->op_targ));
4441     sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
4442
4443     PUSHBLOCK(cx, CXt_GIVEN, SP);
4444     PUSHGIVEN(cx);
4445
4446     RETURN;
4447 }
4448
4449 PP(pp_leavegiven)
4450 {
4451     dVAR; dSP;
4452     register PERL_CONTEXT *cx;
4453     I32 gimme;
4454     SV **newsp;
4455     PMOP *newpm;
4456     PERL_UNUSED_CONTEXT;
4457
4458     POPBLOCK(cx,newpm);
4459     assert(CxTYPE(cx) == CXt_GIVEN);
4460
4461     TAINT_NOT;
4462     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4463     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4464
4465     LEAVE_with_name("given");
4466     RETURN;
4467 }
4468
4469 /* Helper routines used by pp_smartmatch */
4470 STATIC PMOP *
4471 S_make_matcher(pTHX_ REGEXP *re)
4472 {
4473     dVAR;
4474     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4475
4476     PERL_ARGS_ASSERT_MAKE_MATCHER;
4477
4478     PM_SETRE(matcher, ReREFCNT_inc(re));
4479
4480     SAVEFREEOP((OP *) matcher);
4481     ENTER_with_name("matcher"); SAVETMPS;
4482     SAVEOP();
4483     return matcher;
4484 }
4485
4486 STATIC bool
4487 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4488 {
4489     dVAR;
4490     dSP;
4491
4492     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4493     
4494     PL_op = (OP *) matcher;
4495     XPUSHs(sv);
4496     PUTBACK;
4497     (void) Perl_pp_match(aTHX);
4498     SPAGAIN;
4499     return (SvTRUEx(POPs));
4500 }
4501
4502 STATIC void
4503 S_destroy_matcher(pTHX_ PMOP *matcher)
4504 {
4505     dVAR;
4506
4507     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4508     PERL_UNUSED_ARG(matcher);
4509
4510     FREETMPS;
4511     LEAVE_with_name("matcher");
4512 }
4513
4514 /* Do a smart match */
4515 PP(pp_smartmatch)
4516 {
4517     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4518     return do_smartmatch(NULL, NULL, 0);
4519 }
4520
4521 /* This version of do_smartmatch() implements the
4522  * table of smart matches that is found in perlsyn.
4523  */
4524 STATIC OP *
4525 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4526 {
4527     dVAR;
4528     dSP;