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