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