This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove another CvLVALUE check from pp_leavesublv
[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             EXTEND_MORTAL(SP - newsp);
2441             for (mark = newsp + 1; mark <= SP; mark++) {
2442                 if (SvTEMP(*mark))
2443                     NOOP;
2444                 else if (SvFLAGS(*mark) & SVs_PADTMP)
2445                     *mark = sv_mortalcopy(*mark);
2446                 else {
2447                     /* Can be a localized value subject to deletion. */
2448                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2449                     SvREFCNT_inc_void(*mark);
2450                 }
2451             }
2452         }
2453     }
2454     else if (CxLVAL(cx)) {     /* Leave it as it is if we can. */
2455         if (gimme == G_SCALAR) {
2456             MARK = newsp + 1;
2457             EXTEND_MORTAL(1);
2458             if (MARK == SP) {
2459                 if ((SvPADTMP(TOPs) ||
2460                      (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2461                        == SVf_READONLY
2462                     ) &&
2463                     !SvSMAGICAL(TOPs)) {
2464                     LEAVE;
2465                     cxstack_ix--;
2466                     POPSUB(cx,sv);
2467                     PL_curpm = newpm;
2468                     LEAVESUB(sv);
2469                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2470                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2471                         : "a readonly value" : "a temporary");
2472                 }
2473                 else {                  /* Can be a localized value
2474                                          * subject to deletion. */
2475                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2476                     SvREFCNT_inc_void(*mark);
2477                 }
2478             }
2479             else {
2480                 /* sub:lvalue{} will take us here.
2481                    Presumably the case of a non-empty array never happens.
2482                  */
2483                 LEAVE;
2484                 cxstack_ix--;
2485                 POPSUB(cx,sv);
2486                 PL_curpm = newpm;
2487                 LEAVESUB(sv);
2488                 DIE(aTHX_ "%s",
2489                     (MARK > SP
2490                       ? "Can't return undef from lvalue subroutine"
2491                       : "Array returned from lvalue subroutine in scalar "
2492                         "context"
2493                     )
2494                 );
2495             }
2496             SP = MARK;
2497         }
2498         else if (gimme == G_ARRAY) {
2499             EXTEND_MORTAL(SP - newsp);
2500             for (mark = newsp + 1; mark <= SP; mark++) {
2501                 if (*mark != &PL_sv_undef
2502                     && (SvPADTMP(*mark)
2503                        || (SvFLAGS(*mark) & (SVf_READONLY|SVf_FAKE))
2504                              == SVf_READONLY
2505                        )
2506                 ) {
2507                     /* Might be flattened array after $#array =  */
2508                     PUTBACK;
2509                     LEAVE;
2510                     cxstack_ix--;
2511                     POPSUB(cx,sv);
2512                     PL_curpm = newpm;
2513                     LEAVESUB(sv);
2514                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2515                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2516                 }
2517                 else {
2518                     /* Can be a localized value subject to deletion. */
2519                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2520                     SvREFCNT_inc_void(*mark);
2521                 }
2522             }
2523         }
2524     }
2525     else {
2526         if (gimme == G_SCALAR) {
2527           rvalue:
2528             MARK = newsp + 1;
2529             if (MARK <= SP) {
2530                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2531                         *MARK = SvREFCNT_inc(TOPs);
2532                         FREETMPS;
2533                         sv_2mortal(*MARK);
2534                 }
2535                 else
2536                     *MARK = SvTEMP(TOPs)
2537                               ? TOPs
2538                               : sv_2mortal(SvREFCNT_inc_simple_NN(TOPs));
2539             }
2540             else {
2541                 MEXTEND(MARK, 0);
2542                 *MARK = &PL_sv_undef;
2543             }
2544             SP = MARK;
2545         }
2546         else if (gimme == G_ARRAY) {
2547           rvalue_array:
2548             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2549                 if (!SvTEMP(*MARK))
2550                     *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2551             }
2552         }
2553     }
2554
2555     if (CxLVAL(cx) & OPpENTERSUB_DEREF) {
2556         assert(gimme == G_SCALAR);
2557         SvGETMAGIC(TOPs);
2558         if (!SvOK(TOPs)) {
2559             U8 deref_type;
2560             if (cx->blk_sub.retop->op_type == OP_RV2SV)
2561                 deref_type = OPpDEREF_SV;
2562             else if (cx->blk_sub.retop->op_type == OP_RV2AV)
2563                 deref_type = OPpDEREF_AV;
2564             else {
2565                 assert(cx->blk_sub.retop->op_type == OP_RV2HV);
2566                 deref_type = OPpDEREF_HV;
2567             }
2568             vivify_ref(TOPs, deref_type);
2569         }
2570     }
2571
2572     PUTBACK;
2573
2574     LEAVE;
2575     cxstack_ix--;
2576     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2577     PL_curpm = newpm;   /* ... and pop $1 et al */
2578
2579     LEAVESUB(sv);
2580     return cx->blk_sub.retop;
2581 }
2582
2583 PP(pp_last)
2584 {
2585     dVAR; dSP;
2586     I32 cxix;
2587     register PERL_CONTEXT *cx;
2588     I32 pop2 = 0;
2589     I32 gimme;
2590     I32 optype;
2591     OP *nextop = NULL;
2592     SV **newsp;
2593     PMOP *newpm;
2594     SV **mark;
2595     SV *sv = NULL;
2596
2597
2598     if (PL_op->op_flags & OPf_SPECIAL) {
2599         cxix = dopoptoloop(cxstack_ix);
2600         if (cxix < 0)
2601             DIE(aTHX_ "Can't \"last\" outside a loop block");
2602     }
2603     else {
2604         cxix = dopoptolabel(cPVOP->op_pv);
2605         if (cxix < 0)
2606             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2607     }
2608     if (cxix < cxstack_ix)
2609         dounwind(cxix);
2610
2611     POPBLOCK(cx,newpm);
2612     cxstack_ix++; /* temporarily protect top context */
2613     mark = newsp;
2614     switch (CxTYPE(cx)) {
2615     case CXt_LOOP_LAZYIV:
2616     case CXt_LOOP_LAZYSV:
2617     case CXt_LOOP_FOR:
2618     case CXt_LOOP_PLAIN:
2619         pop2 = CxTYPE(cx);
2620         newsp = PL_stack_base + cx->blk_loop.resetsp;
2621         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2622         break;
2623     case CXt_SUB:
2624         pop2 = CXt_SUB;
2625         nextop = cx->blk_sub.retop;
2626         break;
2627     case CXt_EVAL:
2628         POPEVAL(cx);
2629         nextop = cx->blk_eval.retop;
2630         break;
2631     case CXt_FORMAT:
2632         POPFORMAT(cx);
2633         nextop = cx->blk_sub.retop;
2634         break;
2635     default:
2636         DIE(aTHX_ "panic: last");
2637     }
2638
2639     TAINT_NOT;
2640     if (gimme == G_SCALAR) {
2641         if (MARK < SP)
2642             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2643                         ? *SP : sv_mortalcopy(*SP);
2644         else
2645             *++newsp = &PL_sv_undef;
2646     }
2647     else if (gimme == G_ARRAY) {
2648         while (++MARK <= SP) {
2649             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2650                         ? *MARK : sv_mortalcopy(*MARK);
2651             TAINT_NOT;          /* Each item is independent */
2652         }
2653     }
2654     SP = newsp;
2655     PUTBACK;
2656
2657     LEAVE;
2658     cxstack_ix--;
2659     /* Stack values are safe: */
2660     switch (pop2) {
2661     case CXt_LOOP_LAZYIV:
2662     case CXt_LOOP_PLAIN:
2663     case CXt_LOOP_LAZYSV:
2664     case CXt_LOOP_FOR:
2665         POPLOOP(cx);    /* release loop vars ... */
2666         LEAVE;
2667         break;
2668     case CXt_SUB:
2669         POPSUB(cx,sv);  /* release CV and @_ ... */
2670         break;
2671     }
2672     PL_curpm = newpm;   /* ... and pop $1 et al */
2673
2674     LEAVESUB(sv);
2675     PERL_UNUSED_VAR(optype);
2676     PERL_UNUSED_VAR(gimme);
2677     return nextop;
2678 }
2679
2680 PP(pp_next)
2681 {
2682     dVAR;
2683     I32 cxix;
2684     register PERL_CONTEXT *cx;
2685     I32 inner;
2686
2687     if (PL_op->op_flags & OPf_SPECIAL) {
2688         cxix = dopoptoloop(cxstack_ix);
2689         if (cxix < 0)
2690             DIE(aTHX_ "Can't \"next\" outside a loop block");
2691     }
2692     else {
2693         cxix = dopoptolabel(cPVOP->op_pv);
2694         if (cxix < 0)
2695             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2696     }
2697     if (cxix < cxstack_ix)
2698         dounwind(cxix);
2699
2700     /* clear off anything above the scope we're re-entering, but
2701      * save the rest until after a possible continue block */
2702     inner = PL_scopestack_ix;
2703     TOPBLOCK(cx);
2704     if (PL_scopestack_ix < inner)
2705         leave_scope(PL_scopestack[PL_scopestack_ix]);
2706     PL_curcop = cx->blk_oldcop;
2707     return (cx)->blk_loop.my_op->op_nextop;
2708 }
2709
2710 PP(pp_redo)
2711 {
2712     dVAR;
2713     I32 cxix;
2714     register PERL_CONTEXT *cx;
2715     I32 oldsave;
2716     OP* redo_op;
2717
2718     if (PL_op->op_flags & OPf_SPECIAL) {
2719         cxix = dopoptoloop(cxstack_ix);
2720         if (cxix < 0)
2721             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2722     }
2723     else {
2724         cxix = dopoptolabel(cPVOP->op_pv);
2725         if (cxix < 0)
2726             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2727     }
2728     if (cxix < cxstack_ix)
2729         dounwind(cxix);
2730
2731     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2732     if (redo_op->op_type == OP_ENTER) {
2733         /* pop one less context to avoid $x being freed in while (my $x..) */
2734         cxstack_ix++;
2735         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2736         redo_op = redo_op->op_next;
2737     }
2738
2739     TOPBLOCK(cx);
2740     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2741     LEAVE_SCOPE(oldsave);
2742     FREETMPS;
2743     PL_curcop = cx->blk_oldcop;
2744     return redo_op;
2745 }
2746
2747 STATIC OP *
2748 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2749 {
2750     dVAR;
2751     OP **ops = opstack;
2752     static const char too_deep[] = "Target of goto is too deeply nested";
2753
2754     PERL_ARGS_ASSERT_DOFINDLABEL;
2755
2756     if (ops >= oplimit)
2757         Perl_croak(aTHX_ too_deep);
2758     if (o->op_type == OP_LEAVE ||
2759         o->op_type == OP_SCOPE ||
2760         o->op_type == OP_LEAVELOOP ||
2761         o->op_type == OP_LEAVESUB ||
2762         o->op_type == OP_LEAVETRY)
2763     {
2764         *ops++ = cUNOPo->op_first;
2765         if (ops >= oplimit)
2766             Perl_croak(aTHX_ too_deep);
2767     }
2768     *ops = 0;
2769     if (o->op_flags & OPf_KIDS) {
2770         OP *kid;
2771         /* First try all the kids at this level, since that's likeliest. */
2772         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2773             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2774                 const char *kid_label = CopLABEL(kCOP);
2775                 if (kid_label && strEQ(kid_label, label))
2776                     return kid;
2777             }
2778         }
2779         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2780             if (kid == PL_lastgotoprobe)
2781                 continue;
2782             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2783                 if (ops == opstack)
2784                     *ops++ = kid;
2785                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2786                          ops[-1]->op_type == OP_DBSTATE)
2787                     ops[-1] = kid;
2788                 else
2789                     *ops++ = kid;
2790             }
2791             if ((o = dofindlabel(kid, label, ops, oplimit)))
2792                 return o;
2793         }
2794     }
2795     *ops = 0;
2796     return 0;
2797 }
2798
2799 PP(pp_goto)
2800 {
2801     dVAR; dSP;
2802     OP *retop = NULL;
2803     I32 ix;
2804     register PERL_CONTEXT *cx;
2805 #define GOTO_DEPTH 64
2806     OP *enterops[GOTO_DEPTH];
2807     const char *label = NULL;
2808     const bool do_dump = (PL_op->op_type == OP_DUMP);
2809     static const char must_have_label[] = "goto must have label";
2810
2811     if (PL_op->op_flags & OPf_STACKED) {
2812         SV * const sv = POPs;
2813
2814         /* This egregious kludge implements goto &subroutine */
2815         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2816             I32 cxix;
2817             register PERL_CONTEXT *cx;
2818             CV *cv = MUTABLE_CV(SvRV(sv));
2819             SV** mark;
2820             I32 items = 0;
2821             I32 oldsave;
2822             bool reified = 0;
2823
2824         retry:
2825             if (!CvROOT(cv) && !CvXSUB(cv)) {
2826                 const GV * const gv = CvGV(cv);
2827                 if (gv) {
2828                     GV *autogv;
2829                     SV *tmpstr;
2830                     /* autoloaded stub? */
2831                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2832                         goto retry;
2833                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2834                                           GvNAMELEN(gv), FALSE);
2835                     if (autogv && (cv = GvCV(autogv)))
2836                         goto retry;
2837                     tmpstr = sv_newmortal();
2838                     gv_efullname3(tmpstr, gv, NULL);
2839                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2840                 }
2841                 DIE(aTHX_ "Goto undefined subroutine");
2842             }
2843
2844             /* First do some returnish stuff. */
2845             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2846             FREETMPS;
2847             cxix = dopoptosub(cxstack_ix);
2848             if (cxix < 0)
2849                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2850             if (cxix < cxstack_ix)
2851                 dounwind(cxix);
2852             TOPBLOCK(cx);
2853             SPAGAIN;
2854             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2855             if (CxTYPE(cx) == CXt_EVAL) {
2856                 if (CxREALEVAL(cx))
2857                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2858                 else
2859                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2860             }
2861             else if (CxMULTICALL(cx))
2862                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2863             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2864                 /* put @_ back onto stack */
2865                 AV* av = cx->blk_sub.argarray;
2866
2867                 items = AvFILLp(av) + 1;
2868                 EXTEND(SP, items+1); /* @_ could have been extended. */
2869                 Copy(AvARRAY(av), SP + 1, items, SV*);
2870                 SvREFCNT_dec(GvAV(PL_defgv));
2871                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2872                 CLEAR_ARGARRAY(av);
2873                 /* abandon @_ if it got reified */
2874                 if (AvREAL(av)) {
2875                     reified = 1;
2876                     SvREFCNT_dec(av);
2877                     av = newAV();
2878                     av_extend(av, items-1);
2879                     AvREIFY_only(av);
2880                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2881                 }
2882             }
2883             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2884                 AV* const av = GvAV(PL_defgv);
2885                 items = AvFILLp(av) + 1;
2886                 EXTEND(SP, items+1); /* @_ could have been extended. */
2887                 Copy(AvARRAY(av), SP + 1, items, SV*);
2888             }
2889             mark = SP;
2890             SP += items;
2891             if (CxTYPE(cx) == CXt_SUB &&
2892                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2893                 SvREFCNT_dec(cx->blk_sub.cv);
2894             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2895             LEAVE_SCOPE(oldsave);
2896
2897             /* Now do some callish stuff. */
2898             SAVETMPS;
2899             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2900             if (CvISXSUB(cv)) {
2901                 OP* const retop = cx->blk_sub.retop;
2902                 SV **newsp __attribute__unused__;
2903                 I32 gimme __attribute__unused__;
2904                 if (reified) {
2905                     I32 index;
2906                     for (index=0; index<items; index++)
2907                         sv_2mortal(SP[-index]);
2908                 }
2909
2910                 /* XS subs don't have a CxSUB, so pop it */
2911                 POPBLOCK(cx, PL_curpm);
2912                 /* Push a mark for the start of arglist */
2913                 PUSHMARK(mark);
2914                 PUTBACK;
2915                 (void)(*CvXSUB(cv))(aTHX_ cv);
2916                 LEAVE;
2917                 return retop;
2918             }
2919             else {
2920                 AV* const padlist = CvPADLIST(cv);
2921                 if (CxTYPE(cx) == CXt_EVAL) {
2922                     PL_in_eval = CxOLD_IN_EVAL(cx);
2923                     PL_eval_root = cx->blk_eval.old_eval_root;
2924                     cx->cx_type = CXt_SUB;
2925                 }
2926                 cx->blk_sub.cv = cv;
2927                 cx->blk_sub.olddepth = CvDEPTH(cv);
2928
2929                 CvDEPTH(cv)++;
2930                 if (CvDEPTH(cv) < 2)
2931                     SvREFCNT_inc_simple_void_NN(cv);
2932                 else {
2933                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2934                         sub_crush_depth(cv);
2935                     pad_push(padlist, CvDEPTH(cv));
2936                 }
2937                 SAVECOMPPAD();
2938                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2939                 if (CxHASARGS(cx))
2940                 {
2941                     AV *const av = MUTABLE_AV(PAD_SVl(0));
2942
2943                     cx->blk_sub.savearray = GvAV(PL_defgv);
2944                     GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2945                     CX_CURPAD_SAVE(cx->blk_sub);
2946                     cx->blk_sub.argarray = av;
2947
2948                     if (items >= AvMAX(av) + 1) {
2949                         SV **ary = AvALLOC(av);
2950                         if (AvARRAY(av) != ary) {
2951                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2952                             AvARRAY(av) = ary;
2953                         }
2954                         if (items >= AvMAX(av) + 1) {
2955                             AvMAX(av) = items - 1;
2956                             Renew(ary,items+1,SV*);
2957                             AvALLOC(av) = ary;
2958                             AvARRAY(av) = ary;
2959                         }
2960                     }
2961                     ++mark;
2962                     Copy(mark,AvARRAY(av),items,SV*);
2963                     AvFILLp(av) = items - 1;
2964                     assert(!AvREAL(av));
2965                     if (reified) {
2966                         /* transfer 'ownership' of refcnts to new @_ */
2967                         AvREAL_on(av);
2968                         AvREIFY_off(av);
2969                     }
2970                     while (items--) {
2971                         if (*mark)
2972                             SvTEMP_off(*mark);
2973                         mark++;
2974                     }
2975                 }
2976                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2977                     Perl_get_db_sub(aTHX_ NULL, cv);
2978                     if (PERLDB_GOTO) {
2979                         CV * const gotocv = get_cvs("DB::goto", 0);
2980                         if (gotocv) {
2981                             PUSHMARK( PL_stack_sp );
2982                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2983                             PL_stack_sp--;
2984                         }
2985                     }
2986                 }
2987                 RETURNOP(CvSTART(cv));
2988             }
2989         }
2990         else {
2991             label = SvPV_nolen_const(sv);
2992             if (!(do_dump || *label))
2993                 DIE(aTHX_ must_have_label);
2994         }
2995     }
2996     else if (PL_op->op_flags & OPf_SPECIAL) {
2997         if (! do_dump)
2998             DIE(aTHX_ must_have_label);
2999     }
3000     else
3001         label = cPVOP->op_pv;
3002
3003     PERL_ASYNC_CHECK();
3004
3005     if (label && *label) {
3006         OP *gotoprobe = NULL;
3007         bool leaving_eval = FALSE;
3008         bool in_block = FALSE;
3009         PERL_CONTEXT *last_eval_cx = NULL;
3010
3011         /* find label */
3012
3013         PL_lastgotoprobe = NULL;
3014         *enterops = 0;
3015         for (ix = cxstack_ix; ix >= 0; ix--) {
3016             cx = &cxstack[ix];
3017             switch (CxTYPE(cx)) {
3018             case CXt_EVAL:
3019                 leaving_eval = TRUE;
3020                 if (!CxTRYBLOCK(cx)) {
3021                     gotoprobe = (last_eval_cx ?
3022                                 last_eval_cx->blk_eval.old_eval_root :
3023                                 PL_eval_root);
3024                     last_eval_cx = cx;
3025                     break;
3026                 }
3027                 /* else fall through */
3028             case CXt_LOOP_LAZYIV:
3029             case CXt_LOOP_LAZYSV:
3030             case CXt_LOOP_FOR:
3031             case CXt_LOOP_PLAIN:
3032             case CXt_GIVEN:
3033             case CXt_WHEN:
3034                 gotoprobe = cx->blk_oldcop->op_sibling;
3035                 break;
3036             case CXt_SUBST:
3037                 continue;
3038             case CXt_BLOCK:
3039                 if (ix) {
3040                     gotoprobe = cx->blk_oldcop->op_sibling;
3041                     in_block = TRUE;
3042                 } else
3043                     gotoprobe = PL_main_root;
3044                 break;
3045             case CXt_SUB:
3046                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3047                     gotoprobe = CvROOT(cx->blk_sub.cv);
3048                     break;
3049                 }
3050                 /* FALL THROUGH */
3051             case CXt_FORMAT:
3052             case CXt_NULL:
3053                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3054             default:
3055                 if (ix)
3056                     DIE(aTHX_ "panic: goto");
3057                 gotoprobe = PL_main_root;
3058                 break;
3059             }
3060             if (gotoprobe) {
3061                 retop = dofindlabel(gotoprobe, label,
3062                                     enterops, enterops + GOTO_DEPTH);
3063                 if (retop)
3064                     break;
3065                 if (gotoprobe->op_sibling &&
3066                         gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3067                         gotoprobe->op_sibling->op_sibling) {
3068                     retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3069                                         label, enterops, enterops + GOTO_DEPTH);
3070                     if (retop)
3071                         break;
3072                 }
3073             }
3074             PL_lastgotoprobe = gotoprobe;
3075         }
3076         if (!retop)
3077             DIE(aTHX_ "Can't find label %s", label);
3078
3079         /* if we're leaving an eval, check before we pop any frames
3080            that we're not going to punt, otherwise the error
3081            won't be caught */
3082
3083         if (leaving_eval && *enterops && enterops[1]) {
3084             I32 i;
3085             for (i = 1; enterops[i]; i++)
3086                 if (enterops[i]->op_type == OP_ENTERITER)
3087                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3088         }
3089
3090         if (*enterops && enterops[1]) {
3091             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3092             if (enterops[i])
3093                 deprecate("\"goto\" to jump into a construct");
3094         }
3095
3096         /* pop unwanted frames */
3097
3098         if (ix < cxstack_ix) {
3099             I32 oldsave;
3100
3101             if (ix < 0)
3102                 ix = 0;
3103             dounwind(ix);
3104             TOPBLOCK(cx);
3105             oldsave = PL_scopestack[PL_scopestack_ix];
3106             LEAVE_SCOPE(oldsave);
3107         }
3108
3109         /* push wanted frames */
3110
3111         if (*enterops && enterops[1]) {
3112             OP * const oldop = PL_op;
3113             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3114             for (; enterops[ix]; ix++) {
3115                 PL_op = enterops[ix];
3116                 /* Eventually we may want to stack the needed arguments
3117                  * for each op.  For now, we punt on the hard ones. */
3118                 if (PL_op->op_type == OP_ENTERITER)
3119                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3120                 PL_op->op_ppaddr(aTHX);
3121             }
3122             PL_op = oldop;
3123         }
3124     }
3125
3126     if (do_dump) {
3127 #ifdef VMS
3128         if (!retop) retop = PL_main_start;
3129 #endif
3130         PL_restartop = retop;
3131         PL_do_undump = TRUE;
3132
3133         my_unexec();
3134
3135         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3136         PL_do_undump = FALSE;
3137     }
3138
3139     RETURNOP(retop);
3140 }
3141
3142 PP(pp_exit)
3143 {
3144     dVAR;
3145     dSP;
3146     I32 anum;
3147
3148     if (MAXARG < 1)
3149         anum = 0;
3150     else {
3151         anum = SvIVx(POPs);
3152 #ifdef VMS
3153         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3154             anum = 0;
3155         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3156 #endif
3157     }
3158     PL_exit_flags |= PERL_EXIT_EXPECTED;
3159 #ifdef PERL_MAD
3160     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3161     if (anum || !(PL_minus_c && PL_madskills))
3162         my_exit(anum);
3163 #else
3164     my_exit(anum);
3165 #endif
3166     PUSHs(&PL_sv_undef);
3167     RETURN;
3168 }
3169
3170 /* Eval. */
3171
3172 STATIC void
3173 S_save_lines(pTHX_ AV *array, SV *sv)
3174 {
3175     const char *s = SvPVX_const(sv);
3176     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3177     I32 line = 1;
3178
3179     PERL_ARGS_ASSERT_SAVE_LINES;
3180
3181     while (s && s < send) {
3182         const char *t;
3183         SV * const tmpstr = newSV_type(SVt_PVMG);
3184
3185         t = (const char *)memchr(s, '\n', send - s);
3186         if (t)
3187             t++;
3188         else
3189             t = send;
3190
3191         sv_setpvn(tmpstr, s, t - s);
3192         av_store(array, line++, tmpstr);
3193         s = t;
3194     }
3195 }
3196
3197 /*
3198 =for apidoc docatch
3199
3200 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3201
3202 0 is used as continue inside eval,
3203
3204 3 is used for a die caught by an inner eval - continue inner loop
3205
3206 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3207 establish a local jmpenv to handle exception traps.
3208
3209 =cut
3210 */
3211 STATIC OP *
3212 S_docatch(pTHX_ OP *o)
3213 {
3214     dVAR;
3215     int ret;
3216     OP * const oldop = PL_op;
3217     dJMPENV;
3218
3219 #ifdef DEBUGGING
3220     assert(CATCH_GET == TRUE);
3221 #endif
3222     PL_op = o;
3223
3224     JMPENV_PUSH(ret);
3225     switch (ret) {
3226     case 0:
3227         assert(cxstack_ix >= 0);
3228         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3229         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3230  redo_body:
3231         CALLRUNOPS(aTHX);
3232         break;
3233     case 3:
3234         /* die caught by an inner eval - continue inner loop */
3235         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3236             PL_restartjmpenv = NULL;
3237             PL_op = PL_restartop;
3238             PL_restartop = 0;
3239             goto redo_body;
3240         }
3241         /* FALL THROUGH */
3242     default:
3243         JMPENV_POP;
3244         PL_op = oldop;
3245         JMPENV_JUMP(ret);
3246         /* NOTREACHED */
3247     }
3248     JMPENV_POP;
3249     PL_op = oldop;
3250     return NULL;
3251 }
3252
3253 /* James Bond: Do you expect me to talk?
3254    Auric Goldfinger: No, Mr. Bond. I expect you to die.
3255
3256    This code is an ugly hack, doesn't work with lexicals in subroutines that are
3257    called more than once, and is only used by regcomp.c, for (?{}) blocks.
3258
3259    Currently it is not used outside the core code. Best if it stays that way.
3260
3261    Hence it's now deprecated, and will be removed.
3262 */
3263 OP *
3264 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
3265 /* sv Text to convert to OP tree. */
3266 /* startop op_free() this to undo. */
3267 /* code Short string id of the caller. */
3268 {
3269     PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3270     return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3271 }
3272
3273 /* Don't use this. It will go away without warning once the regexp engine is
3274    refactored not to use it.  */
3275 OP *
3276 Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3277                               PAD **padp)
3278 {
3279     dVAR; dSP;                          /* Make POPBLOCK work. */
3280     PERL_CONTEXT *cx;
3281     SV **newsp;
3282     I32 gimme = G_VOID;
3283     I32 optype;
3284     OP dummy;
3285     char tbuf[TYPE_DIGITS(long) + 12 + 10];
3286     char *tmpbuf = tbuf;
3287     char *safestr;
3288     int runtime;
3289     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
3290     STRLEN len;
3291     bool need_catch;
3292
3293     PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
3294
3295     ENTER_with_name("eval");
3296     lex_start(sv, NULL, LEX_START_SAME_FILTER);
3297     SAVETMPS;
3298     /* switch to eval mode */
3299
3300     if (IN_PERL_COMPILETIME) {
3301         SAVECOPSTASH_FREE(&PL_compiling);
3302         CopSTASH_set(&PL_compiling, PL_curstash);
3303     }
3304     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3305         SV * const sv = sv_newmortal();
3306         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3307                        code, (unsigned long)++PL_evalseq,
3308                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3309         tmpbuf = SvPVX(sv);
3310         len = SvCUR(sv);
3311     }
3312     else
3313         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3314                           (unsigned long)++PL_evalseq);
3315     SAVECOPFILE_FREE(&PL_compiling);
3316     CopFILE_set(&PL_compiling, tmpbuf+2);
3317     SAVECOPLINE(&PL_compiling);
3318     CopLINE_set(&PL_compiling, 1);
3319     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3320        deleting the eval's FILEGV from the stash before gv_check() runs
3321        (i.e. before run-time proper). To work around the coredump that
3322        ensues, we always turn GvMULTI_on for any globals that were
3323        introduced within evals. See force_ident(). GSAR 96-10-12 */
3324     safestr = savepvn(tmpbuf, len);
3325     SAVEDELETE(PL_defstash, safestr, len);
3326     SAVEHINTS();
3327 #ifdef OP_IN_REGISTER
3328     PL_opsave = op;
3329 #else
3330     SAVEVPTR(PL_op);
3331 #endif
3332
3333     /* we get here either during compilation, or via pp_regcomp at runtime */
3334     runtime = IN_PERL_RUNTIME;
3335     if (runtime)
3336     {
3337         runcv = find_runcv(NULL);
3338
3339         /* At run time, we have to fetch the hints from PL_curcop. */
3340         PL_hints = PL_curcop->cop_hints;
3341         if (PL_hints & HINT_LOCALIZE_HH) {
3342             /* SAVEHINTS created a new HV in PL_hintgv, which we
3343                need to GC */
3344             SvREFCNT_dec(GvHV(PL_hintgv));
3345             GvHV(PL_hintgv) =
3346              refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3347             hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3348         }
3349         SAVECOMPILEWARNINGS();
3350         PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3351         cophh_free(CopHINTHASH_get(&PL_compiling));
3352         /* XXX Does this need to avoid copying a label? */
3353         PL_compiling.cop_hints_hash
3354          = cophh_copy(PL_curcop->cop_hints_hash);
3355     }
3356
3357     PL_op = &dummy;
3358     PL_op->op_type = OP_ENTEREVAL;
3359     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
3360     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3361     PUSHEVAL(cx, 0);
3362     need_catch = CATCH_GET;
3363     CATCH_SET(TRUE);
3364
3365     if (runtime)
3366         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
3367     else
3368         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
3369     CATCH_SET(need_catch);
3370     POPBLOCK(cx,PL_curpm);
3371     POPEVAL(cx);
3372
3373     (*startop)->op_type = OP_NULL;
3374     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3375     /* XXX DAPM do this properly one year */
3376     *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3377     LEAVE_with_name("eval");
3378     if (IN_PERL_COMPILETIME)
3379         CopHINTS_set(&PL_compiling, PL_hints);
3380 #ifdef OP_IN_REGISTER
3381     op = PL_opsave;
3382 #endif
3383     PERL_UNUSED_VAR(newsp);
3384     PERL_UNUSED_VAR(optype);
3385
3386     return PL_eval_start;
3387 }
3388
3389
3390 /*
3391 =for apidoc find_runcv
3392
3393 Locate the CV corresponding to the currently executing sub or eval.
3394 If db_seqp is non_null, skip CVs that are in the DB package and populate
3395 *db_seqp with the cop sequence number at the point that the DB:: code was
3396 entered. (allows debuggers to eval in the scope of the breakpoint rather
3397 than in the scope of the debugger itself).
3398
3399 =cut
3400 */
3401
3402 CV*
3403 Perl_find_runcv(pTHX_ U32 *db_seqp)
3404 {
3405     dVAR;
3406     PERL_SI      *si;
3407
3408     if (db_seqp)
3409         *db_seqp = PL_curcop->cop_seq;
3410     for (si = PL_curstackinfo; si; si = si->si_prev) {
3411         I32 ix;
3412         for (ix = si->si_cxix; ix >= 0; ix--) {
3413             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3414             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3415                 CV * const cv = cx->blk_sub.cv;
3416                 /* skip DB:: code */
3417                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3418                     *db_seqp = cx->blk_oldcop->cop_seq;
3419                     continue;
3420                 }
3421                 return cv;
3422             }
3423             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3424                 return PL_compcv;
3425         }
3426     }
3427     return PL_main_cv;
3428 }
3429
3430
3431 /* Run yyparse() in a setjmp wrapper. Returns:
3432  *   0: yyparse() successful
3433  *   1: yyparse() failed
3434  *   3: yyparse() died
3435  */
3436 STATIC int
3437 S_try_yyparse(pTHX_ int gramtype)
3438 {
3439     int ret;
3440     dJMPENV;
3441
3442     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3443     JMPENV_PUSH(ret);
3444     switch (ret) {
3445     case 0:
3446         ret = yyparse(gramtype) ? 1 : 0;
3447         break;
3448     case 3:
3449         break;
3450     default:
3451         JMPENV_POP;
3452         JMPENV_JUMP(ret);
3453         /* NOTREACHED */
3454     }
3455     JMPENV_POP;
3456     return ret;
3457 }
3458
3459
3460 /* Compile a require/do, an eval '', or a /(?{...})/.
3461  * In the last case, startop is non-null, and contains the address of
3462  * a pointer that should be set to the just-compiled code.
3463  * outside is the lexically enclosing CV (if any) that invoked us.
3464  * Returns a bool indicating whether the compile was successful; if so,
3465  * PL_eval_start contains the first op of the compiled ocde; otherwise,
3466  * pushes undef (also croaks if startop != NULL).
3467  */
3468
3469 STATIC bool
3470 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3471 {
3472     dVAR; dSP;
3473     OP * const saveop = PL_op;
3474     bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3475     int yystatus;
3476
3477     PL_in_eval = (in_require
3478                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3479                   : EVAL_INEVAL);
3480
3481     PUSHMARK(SP);
3482
3483     SAVESPTR(PL_compcv);
3484     PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3485     CvEVAL_on(PL_compcv);
3486     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3487     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3488
3489     CvOUTSIDE_SEQ(PL_compcv) = seq;
3490     CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3491
3492     /* set up a scratch pad */
3493
3494     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3495     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3496
3497
3498     if (!PL_madskills)
3499         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
3500
3501     /* make sure we compile in the right package */
3502
3503     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3504         SAVESPTR(PL_curstash);
3505         PL_curstash = CopSTASH(PL_curcop);
3506     }
3507     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3508     SAVESPTR(PL_beginav);
3509     PL_beginav = newAV();
3510     SAVEFREESV(PL_beginav);
3511     SAVESPTR(PL_unitcheckav);
3512     PL_unitcheckav = newAV();
3513     SAVEFREESV(PL_unitcheckav);
3514
3515 #ifdef PERL_MAD
3516     SAVEBOOL(PL_madskills);
3517     PL_madskills = 0;
3518 #endif
3519
3520     /* try to compile it */
3521
3522     PL_eval_root = NULL;
3523     PL_curcop = &PL_compiling;
3524     CopARYBASE_set(PL_curcop, 0);
3525     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3526         PL_in_eval |= EVAL_KEEPERR;
3527     else
3528         CLEAR_ERRSV();
3529
3530     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3531
3532     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3533      * so honour CATCH_GET and trap it here if necessary */
3534
3535     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3536
3537     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3538         SV **newsp;                     /* Used by POPBLOCK. */
3539         PERL_CONTEXT *cx = NULL;
3540         I32 optype;                     /* Used by POPEVAL. */
3541         SV *namesv = NULL;
3542         const char *msg;
3543
3544         PERL_UNUSED_VAR(newsp);
3545         PERL_UNUSED_VAR(optype);
3546
3547         /* note that if yystatus == 3, then the EVAL CX block has already
3548          * been popped, and various vars restored */
3549         PL_op = saveop;
3550         if (yystatus != 3) {
3551             if (PL_eval_root) {
3552                 op_free(PL_eval_root);
3553                 PL_eval_root = NULL;
3554             }
3555             SP = PL_stack_base + POPMARK;       /* pop original mark */
3556             if (!startop) {
3557                 POPBLOCK(cx,PL_curpm);
3558                 POPEVAL(cx);
3559                 namesv = cx->blk_eval.old_namesv;
3560             }
3561         }
3562         if (yystatus != 3)
3563             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3564
3565         msg = SvPVx_nolen_const(ERRSV);
3566         if (in_require) {
3567             if (!cx) {
3568                 /* If cx is still NULL, it means that we didn't go in the
3569                  * POPEVAL branch. */
3570                 cx = &cxstack[cxstack_ix];
3571                 assert(CxTYPE(cx) == CXt_EVAL);
3572                 namesv = cx->blk_eval.old_namesv;
3573             }
3574             (void)hv_store(GvHVn(PL_incgv),
3575                            SvPVX_const(namesv), SvCUR(namesv),
3576                            &PL_sv_undef, 0);
3577             Perl_croak(aTHX_ "%sCompilation failed in require",
3578                        *msg ? msg : "Unknown error\n");
3579         }
3580         else if (startop) {
3581             if (yystatus != 3) {
3582                 POPBLOCK(cx,PL_curpm);
3583                 POPEVAL(cx);
3584             }
3585             Perl_croak(aTHX_ "%sCompilation failed in regexp",
3586                        (*msg ? msg : "Unknown error\n"));
3587         }
3588         else {
3589             if (!*msg) {
3590                 sv_setpvs(ERRSV, "Compilation error");
3591             }
3592         }
3593         PUSHs(&PL_sv_undef);
3594         PUTBACK;
3595         return FALSE;
3596     }
3597     CopLINE_set(&PL_compiling, 0);
3598     if (startop) {
3599         *startop = PL_eval_root;
3600     } else
3601         SAVEFREEOP(PL_eval_root);
3602
3603     /* Set the context for this new optree.
3604      * Propagate the context from the eval(). */
3605     if ((gimme & G_WANT) == G_VOID)
3606         scalarvoid(PL_eval_root);
3607     else if ((gimme & G_WANT) == G_ARRAY)
3608         list(PL_eval_root);
3609     else
3610         scalar(PL_eval_root);
3611
3612     DEBUG_x(dump_eval());
3613
3614     /* Register with debugger: */
3615     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3616         CV * const cv = get_cvs("DB::postponed", 0);
3617         if (cv) {
3618             dSP;
3619             PUSHMARK(SP);
3620             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3621             PUTBACK;
3622             call_sv(MUTABLE_SV(cv), G_DISCARD);
3623         }
3624     }
3625
3626     if (PL_unitcheckav) {
3627         OP *es = PL_eval_start;
3628         call_list(PL_scopestack_ix, PL_unitcheckav);
3629         PL_eval_start = es;
3630     }
3631
3632     /* compiled okay, so do it */
3633
3634     CvDEPTH(PL_compcv) = 1;
3635     SP = PL_stack_base + POPMARK;               /* pop original mark */
3636     PL_op = saveop;                     /* The caller may need it. */
3637     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3638
3639     PUTBACK;
3640     return TRUE;
3641 }
3642
3643 STATIC PerlIO *
3644 S_check_type_and_open(pTHX_ SV *name)
3645 {
3646     Stat_t st;
3647     const char *p = SvPV_nolen_const(name);
3648     const int st_rc = PerlLIO_stat(p, &st);
3649
3650     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3651
3652     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3653         return NULL;
3654     }
3655
3656 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3657     return PerlIO_openn(aTHX_ NULL, PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3658 #else
3659     return PerlIO_open(p, PERL_SCRIPT_MODE);
3660 #endif
3661 }
3662
3663 #ifndef PERL_DISABLE_PMC
3664 STATIC PerlIO *
3665 S_doopen_pm(pTHX_ SV *name)
3666 {
3667     STRLEN namelen;
3668     const char *p = SvPV_const(name, namelen);
3669
3670     PERL_ARGS_ASSERT_DOOPEN_PM;
3671
3672     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3673         SV *const pmcsv = sv_newmortal();
3674         Stat_t pmcstat;
3675
3676         SvSetSV_nosteal(pmcsv,name);
3677         sv_catpvn(pmcsv, "c", 1);
3678
3679         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3680             return check_type_and_open(pmcsv);
3681     }
3682     return check_type_and_open(name);
3683 }
3684 #else
3685 #  define doopen_pm(name) check_type_and_open(name)
3686 #endif /* !PERL_DISABLE_PMC */
3687
3688 PP(pp_require)
3689 {
3690     dVAR; dSP;
3691     register PERL_CONTEXT *cx;
3692     SV *sv;
3693     const char *name;
3694     STRLEN len;
3695     char * unixname;
3696     STRLEN unixlen;
3697 #ifdef VMS
3698     int vms_unixname = 0;
3699 #endif
3700     const char *tryname = NULL;
3701     SV *namesv = NULL;
3702     const I32 gimme = GIMME_V;
3703     int filter_has_file = 0;
3704     PerlIO *tryrsfp = NULL;
3705     SV *filter_cache = NULL;
3706     SV *filter_state = NULL;
3707     SV *filter_sub = NULL;
3708     SV *hook_sv = NULL;
3709     SV *encoding;
3710     OP *op;
3711
3712     sv = POPs;
3713     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3714         sv = sv_2mortal(new_version(sv));
3715         if (!sv_derived_from(PL_patchlevel, "version"))
3716             upg_version(PL_patchlevel, TRUE);
3717         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3718             if ( vcmp(sv,PL_patchlevel) <= 0 )
3719                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3720                     SVfARG(sv_2mortal(vnormal(sv))),
3721                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3722                 );
3723         }
3724         else {
3725             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3726                 I32 first = 0;
3727                 AV *lav;
3728                 SV * const req = SvRV(sv);
3729                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3730
3731                 /* get the left hand term */
3732                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3733
3734                 first  = SvIV(*av_fetch(lav,0,0));
3735                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3736                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3737                     || av_len(lav) > 1               /* FP with > 3 digits */
3738                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3739                    ) {
3740                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3741                         "%"SVf", stopped",
3742                         SVfARG(sv_2mortal(vnormal(req))),
3743                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3744                     );
3745                 }
3746                 else { /* probably 'use 5.10' or 'use 5.8' */
3747                     SV *hintsv;
3748                     I32 second = 0;
3749
3750                     if (av_len(lav)>=1) 
3751                         second = SvIV(*av_fetch(lav,1,0));
3752
3753                     second /= second >= 600  ? 100 : 10;
3754                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3755                                            (int)first, (int)second);
3756                     upg_version(hintsv, TRUE);
3757
3758                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3759                         "--this is only %"SVf", stopped",
3760                         SVfARG(sv_2mortal(vnormal(req))),
3761                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3762                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3763                     );
3764                 }
3765             }
3766         }
3767
3768         RETPUSHYES;
3769     }
3770     name = SvPV_const(sv, len);
3771     if (!(name && len > 0 && *name))
3772         DIE(aTHX_ "Null filename used");
3773     TAINT_PROPER("require");
3774
3775
3776 #ifdef VMS
3777     /* The key in the %ENV hash is in the syntax of file passed as the argument
3778      * usually this is in UNIX format, but sometimes in VMS format, which
3779      * can result in a module being pulled in more than once.
3780      * To prevent this, the key must be stored in UNIX format if the VMS
3781      * name can be translated to UNIX.
3782      */
3783     if ((unixname = tounixspec(name, NULL)) != NULL) {
3784         unixlen = strlen(unixname);
3785         vms_unixname = 1;
3786     }
3787     else
3788 #endif
3789     {
3790         /* if not VMS or VMS name can not be translated to UNIX, pass it
3791          * through.
3792          */
3793         unixname = (char *) name;
3794         unixlen = len;
3795     }
3796     if (PL_op->op_type == OP_REQUIRE) {
3797         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3798                                           unixname, unixlen, 0);
3799         if ( svp ) {
3800             if (*svp != &PL_sv_undef)
3801                 RETPUSHYES;
3802             else
3803                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3804                             "Compilation failed in require", unixname);
3805         }
3806     }
3807
3808     /* prepare to compile file */
3809
3810     if (path_is_absolute(name)) {
3811         /* At this point, name is SvPVX(sv)  */
3812         tryname = name;
3813         tryrsfp = doopen_pm(sv);
3814     }
3815     if (!tryrsfp) {
3816         AV * const ar = GvAVn(PL_incgv);
3817         I32 i;
3818 #ifdef VMS
3819         if (vms_unixname)
3820 #endif
3821         {
3822             namesv = newSV_type(SVt_PV);
3823             for (i = 0; i <= AvFILL(ar); i++) {
3824                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3825
3826                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3827                     mg_get(dirsv);
3828                 if (SvROK(dirsv)) {
3829                     int count;
3830                     SV **svp;
3831                     SV *loader = dirsv;
3832
3833                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3834                         && !sv_isobject(loader))
3835                     {
3836                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3837                     }
3838
3839                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3840                                    PTR2UV(SvRV(dirsv)), name);
3841                     tryname = SvPVX_const(namesv);
3842                     tryrsfp = NULL;
3843
3844                     ENTER_with_name("call_INC");
3845                     SAVETMPS;
3846                     EXTEND(SP, 2);
3847
3848                     PUSHMARK(SP);
3849                     PUSHs(dirsv);
3850                     PUSHs(sv);
3851                     PUTBACK;
3852                     if (sv_isobject(loader))
3853                         count = call_method("INC", G_ARRAY);
3854                     else
3855                         count = call_sv(loader, G_ARRAY);
3856                     SPAGAIN;
3857
3858                     if (count > 0) {
3859                         int i = 0;
3860                         SV *arg;
3861
3862                         SP -= count - 1;
3863                         arg = SP[i++];
3864
3865                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3866                             && !isGV_with_GP(SvRV(arg))) {
3867                             filter_cache = SvRV(arg);
3868                             SvREFCNT_inc_simple_void_NN(filter_cache);
3869
3870                             if (i < count) {
3871                                 arg = SP[i++];
3872                             }
3873                         }
3874
3875                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3876                             arg = SvRV(arg);
3877                         }
3878
3879                         if (isGV_with_GP(arg)) {
3880                             IO * const io = GvIO((const GV *)arg);
3881
3882                             ++filter_has_file;
3883
3884                             if (io) {
3885                                 tryrsfp = IoIFP(io);
3886                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3887                                     PerlIO_close(IoOFP(io));
3888                                 }
3889                                 IoIFP(io) = NULL;
3890                                 IoOFP(io) = NULL;
3891                             }
3892
3893                             if (i < count) {
3894                                 arg = SP[i++];
3895                             }
3896                         }
3897
3898                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3899                             filter_sub = arg;
3900                             SvREFCNT_inc_simple_void_NN(filter_sub);
3901
3902                             if (i < count) {
3903                                 filter_state = SP[i];
3904                                 SvREFCNT_inc_simple_void(filter_state);
3905                             }
3906                         }
3907
3908                         if (!tryrsfp && (filter_cache || filter_sub)) {
3909                             tryrsfp = PerlIO_open(BIT_BUCKET,
3910                                                   PERL_SCRIPT_MODE);
3911                         }
3912                         SP--;
3913                     }
3914
3915                     PUTBACK;
3916                     FREETMPS;
3917                     LEAVE_with_name("call_INC");
3918
3919                     /* Adjust file name if the hook has set an %INC entry.
3920                        This needs to happen after the FREETMPS above.  */
3921                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3922                     if (svp)
3923                         tryname = SvPV_nolen_const(*svp);
3924
3925                     if (tryrsfp) {
3926                         hook_sv = dirsv;
3927                         break;
3928                     }
3929
3930                     filter_has_file = 0;
3931                     if (filter_cache) {
3932                         SvREFCNT_dec(filter_cache);
3933                         filter_cache = NULL;
3934                     }
3935                     if (filter_state) {
3936                         SvREFCNT_dec(filter_state);
3937                         filter_state = NULL;
3938                     }
3939                     if (filter_sub) {
3940                         SvREFCNT_dec(filter_sub);
3941                         filter_sub = NULL;
3942                     }
3943                 }
3944                 else {
3945                   if (!path_is_absolute(name)
3946                   ) {
3947                     const char *dir;
3948                     STRLEN dirlen;
3949
3950                     if (SvOK(dirsv)) {
3951                         dir = SvPV_const(dirsv, dirlen);
3952                     } else {
3953                         dir = "";
3954                         dirlen = 0;
3955                     }
3956
3957 #ifdef VMS
3958                     char *unixdir;
3959                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3960                         continue;
3961                     sv_setpv(namesv, unixdir);
3962                     sv_catpv(namesv, unixname);
3963 #else
3964 #  ifdef __SYMBIAN32__
3965                     if (PL_origfilename[0] &&
3966                         PL_origfilename[1] == ':' &&
3967                         !(dir[0] && dir[1] == ':'))
3968                         Perl_sv_setpvf(aTHX_ namesv,
3969                                        "%c:%s\\%s",
3970                                        PL_origfilename[0],
3971                                        dir, name);
3972                     else
3973                         Perl_sv_setpvf(aTHX_ namesv,
3974                                        "%s\\%s",
3975                                        dir, name);
3976 #  else
3977                     /* The equivalent of                    
3978                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3979                        but without the need to parse the format string, or
3980                        call strlen on either pointer, and with the correct
3981                        allocation up front.  */
3982                     {
3983                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3984
3985                         memcpy(tmp, dir, dirlen);
3986                         tmp +=dirlen;
3987                         *tmp++ = '/';
3988                         /* name came from an SV, so it will have a '\0' at the
3989                            end that we can copy as part of this memcpy().  */
3990                         memcpy(tmp, name, len + 1);
3991
3992                         SvCUR_set(namesv, dirlen + len + 1);
3993                         SvPOK_on(namesv);
3994                     }
3995 #  endif
3996 #endif
3997                     TAINT_PROPER("require");
3998                     tryname = SvPVX_const(namesv);
3999                     tryrsfp = doopen_pm(namesv);
4000                     if (tryrsfp) {
4001                         if (tryname[0] == '.' && tryname[1] == '/') {
4002                             ++tryname;
4003                             while (*++tryname == '/');
4004                         }
4005                         break;
4006                     }
4007                     else if (errno == EMFILE)
4008                         /* no point in trying other paths if out of handles */
4009                         break;
4010                   }
4011                 }
4012             }
4013         }
4014     }
4015     sv_2mortal(namesv);
4016     if (!tryrsfp) {
4017         if (PL_op->op_type == OP_REQUIRE) {
4018             if(errno == EMFILE) {
4019                 /* diag_listed_as: Can't locate %s */
4020                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(errno));
4021             } else {
4022                 if (namesv) {                   /* did we lookup @INC? */
4023                     AV * const ar = GvAVn(PL_incgv);
4024                     I32 i;
4025                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4026                     for (i = 0; i <= AvFILL(ar); i++) {
4027                         sv_catpvs(inc, " ");
4028                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4029                     }
4030
4031                     /* diag_listed_as: Can't locate %s */
4032                     DIE(aTHX_
4033                         "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
4034                         name,
4035                         (memEQ(name + len - 2, ".h", 3)
4036                          ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
4037                         (memEQ(name + len - 3, ".ph", 4)
4038                          ? " (did you run h2ph?)" : ""),
4039                         inc
4040                         );
4041                 }
4042             }
4043             DIE(aTHX_ "Can't locate %s", name);
4044         }
4045
4046         RETPUSHUNDEF;
4047     }
4048     else
4049         SETERRNO(0, SS_NORMAL);
4050
4051     /* Assume success here to prevent recursive requirement. */
4052     /* name is never assigned to again, so len is still strlen(name)  */
4053     /* Check whether a hook in @INC has already filled %INC */
4054     if (!hook_sv) {
4055         (void)hv_store(GvHVn(PL_incgv),
4056                        unixname, unixlen, newSVpv(tryname,0),0);
4057     } else {
4058         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4059         if (!svp)
4060             (void)hv_store(GvHVn(PL_incgv),
4061                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4062     }
4063
4064     ENTER_with_name("eval");
4065     SAVETMPS;
4066     SAVECOPFILE_FREE(&PL_compiling);
4067     CopFILE_set(&PL_compiling, tryname);
4068     lex_start(NULL, tryrsfp, 0);
4069
4070     SAVEHINTS();
4071     PL_hints = 0;
4072     hv_clear(GvHV(PL_hintgv));
4073
4074     SAVECOMPILEWARNINGS();
4075     if (PL_dowarn & G_WARN_ALL_ON)
4076         PL_compiling.cop_warnings = pWARN_ALL ;
4077     else if (PL_dowarn & G_WARN_ALL_OFF)
4078         PL_compiling.cop_warnings = pWARN_NONE ;
4079     else
4080         PL_compiling.cop_warnings = pWARN_STD ;
4081
4082     if (filter_sub || filter_cache) {
4083         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4084            than hanging another SV from it. In turn, filter_add() optionally
4085            takes the SV to use as the filter (or creates a new SV if passed
4086            NULL), so simply pass in whatever value filter_cache has.  */
4087         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
4088         IoLINES(datasv) = filter_has_file;
4089         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4090         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4091     }
4092
4093     /* switch to eval mode */
4094     PUSHBLOCK(cx, CXt_EVAL, SP);
4095     PUSHEVAL(cx, name);
4096     cx->blk_eval.retop = PL_op->op_next;
4097
4098     SAVECOPLINE(&PL_compiling);
4099     CopLINE_set(&PL_compiling, 0);
4100
4101     PUTBACK;
4102
4103     /* Store and reset encoding. */
4104     encoding = PL_encoding;
4105     PL_encoding = NULL;
4106
4107     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
4108         op = DOCATCH(PL_eval_start);
4109     else
4110         op = PL_op->op_next;
4111
4112     /* Restore encoding. */
4113     PL_encoding = encoding;
4114
4115     return op;
4116 }
4117
4118 /* This is a op added to hold the hints hash for
4119    pp_entereval. The hash can be modified by the code
4120    being eval'ed, so we return a copy instead. */
4121
4122 PP(pp_hintseval)
4123 {
4124     dVAR;
4125     dSP;
4126     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4127     RETURN;
4128 }
4129
4130
4131 PP(pp_entereval)
4132 {
4133     dVAR; dSP;
4134     register PERL_CONTEXT *cx;
4135     SV *sv;
4136     const I32 gimme = GIMME_V;
4137     const U32 was = PL_breakable_sub_gen;
4138     char tbuf[TYPE_DIGITS(long) + 12];
4139     bool saved_delete = FALSE;
4140     char *tmpbuf = tbuf;
4141     STRLEN len;
4142     CV* runcv;
4143     U32 seq;
4144     HV *saved_hh = NULL;
4145
4146     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4147         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4148     }
4149     sv = POPs;
4150     if (!SvPOK(sv)) {
4151         /* make sure we've got a plain PV (no overload etc) before testing
4152          * for taint. Making a copy here is probably overkill, but better
4153          * safe than sorry */
4154         STRLEN len;
4155         const char * const p = SvPV_const(sv, len);
4156
4157         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4158     }
4159
4160     TAINT_IF(SvTAINTED(sv));
4161     TAINT_PROPER("eval");
4162
4163     ENTER_with_name("eval");
4164     lex_start(sv, NULL, LEX_START_SAME_FILTER);
4165     SAVETMPS;
4166
4167     /* switch to eval mode */
4168
4169     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4170         SV * const temp_sv = sv_newmortal();
4171         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4172                        (unsigned long)++PL_evalseq,
4173                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4174         tmpbuf = SvPVX(temp_sv);
4175         len = SvCUR(temp_sv);
4176     }
4177     else
4178         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4179     SAVECOPFILE_FREE(&PL_compiling);
4180     CopFILE_set(&PL_compiling, tmpbuf+2);
4181     SAVECOPLINE(&PL_compiling);
4182     CopLINE_set(&PL_compiling, 1);
4183     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4184        deleting the eval's FILEGV from the stash before gv_check() runs
4185        (i.e. before run-time proper). To work around the coredump that
4186        ensues, we always turn GvMULTI_on for any globals that were
4187        introduced within evals. See force_ident(). GSAR 96-10-12 */
4188     SAVEHINTS();
4189     PL_hints = PL_op->op_targ;
4190     if (saved_hh) {
4191         /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
4192         SvREFCNT_dec(GvHV(PL_hintgv));
4193         GvHV(PL_hintgv) = saved_hh;
4194     }
4195     SAVECOMPILEWARNINGS();
4196     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4197     cophh_free(CopHINTHASH_get(&PL_compiling));
4198     if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
4199         /* The label, if present, is the first entry on the chain. So rather
4200            than writing a blank label in front of it (which involves an
4201            allocation), just use the next entry in the chain.  */
4202         PL_compiling.cop_hints_hash
4203             = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
4204         /* Check the assumption that this removed the label.  */
4205         assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
4206     }
4207     else
4208         PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
4209     /* special case: an eval '' executed within the DB package gets lexically
4210      * placed in the first non-DB CV rather than the current CV - this
4211      * allows the debugger to execute code, find lexicals etc, in the
4212      * scope of the code being debugged. Passing &seq gets find_runcv
4213      * to do the dirty work for us */
4214     runcv = find_runcv(&seq);
4215
4216     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4217     PUSHEVAL(cx, 0);
4218     cx->blk_eval.retop = PL_op->op_next;
4219
4220     /* prepare to compile string */
4221
4222     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4223         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4224     else {
4225         char *const safestr = savepvn(tmpbuf, len);
4226         SAVEDELETE(PL_defstash, safestr, len);
4227         saved_delete = TRUE;
4228     }
4229     
4230     PUTBACK;
4231
4232     if (doeval(gimme, NULL, runcv, seq)) {
4233         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4234             ? (PERLDB_LINE || PERLDB_SAVESRC)
4235             :  PERLDB_SAVESRC_NOSUBS) {
4236             /* Retain the filegv we created.  */
4237         } else if (!saved_delete) {
4238             char *const safestr = savepvn(tmpbuf, len);
4239             SAVEDELETE(PL_defstash, safestr, len);
4240         }
4241         return DOCATCH(PL_eval_start);
4242     } else {
4243         /* We have already left the scope set up earlier thanks to the LEAVE
4244            in doeval().  */
4245         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4246             ? (PERLDB_LINE || PERLDB_SAVESRC)
4247             :  PERLDB_SAVESRC_INVALID) {
4248             /* Retain the filegv we created.  */
4249         } else if (!saved_delete) {
4250             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4251         }
4252         return PL_op->op_next;
4253     }
4254 }
4255
4256 PP(pp_leaveeval)
4257 {
4258     dVAR; dSP;
4259     register SV **mark;
4260     SV **newsp;
4261     PMOP *newpm;
4262     I32 gimme;
4263     register PERL_CONTEXT *cx;
4264     OP *retop;
4265     const U8 save_flags = PL_op -> op_flags;
4266     I32 optype;
4267     SV *namesv;
4268
4269     PERL_ASYNC_CHECK();
4270     POPBLOCK(cx,newpm);
4271     POPEVAL(cx);
4272     namesv = cx->blk_eval.old_namesv;
4273     retop = cx->blk_eval.retop;
4274
4275     TAINT_NOT;
4276     if (gimme == G_VOID)
4277         MARK = newsp;
4278     else if (gimme == G_SCALAR) {
4279         MARK = newsp + 1;
4280         if (MARK <= SP) {
4281             if (SvFLAGS(TOPs) & SVs_TEMP)
4282                 *MARK = TOPs;
4283             else
4284                 *MARK = sv_mortalcopy(TOPs);
4285         }
4286         else {
4287             MEXTEND(mark,0);
4288             *MARK = &PL_sv_undef;
4289         }
4290         SP = MARK;
4291     }
4292     else {
4293         /* in case LEAVE wipes old return values */
4294         for (mark = newsp + 1; mark <= SP; mark++) {
4295             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
4296                 *mark = sv_mortalcopy(*mark);
4297                 TAINT_NOT;      /* Each item is independent */
4298             }
4299         }
4300     }
4301     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4302
4303 #ifdef DEBUGGING
4304     assert(CvDEPTH(PL_compcv) == 1);
4305 #endif
4306     CvDEPTH(PL_compcv) = 0;
4307
4308     if (optype == OP_REQUIRE &&
4309         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4310     {
4311         /* Unassume the success we assumed earlier. */
4312         (void)hv_delete(GvHVn(PL_incgv),
4313                         SvPVX_const(namesv), SvCUR(namesv),
4314                         G_DISCARD);
4315         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4316                                SVfARG(namesv));
4317         /* die_unwind() did LEAVE, or we won't be here */
4318     }
4319     else {
4320         LEAVE_with_name("eval");
4321         if (!(save_flags & OPf_SPECIAL)) {
4322             CLEAR_ERRSV();
4323         }
4324     }
4325
4326     RETURNOP(retop);
4327 }
4328
4329 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4330    close to the related Perl_create_eval_scope.  */
4331 void
4332 Perl_delete_eval_scope(pTHX)
4333 {
4334     SV **newsp;
4335     PMOP *newpm;
4336     I32 gimme;
4337     register PERL_CONTEXT *cx;
4338     I32 optype;
4339         
4340     POPBLOCK(cx,newpm);
4341     POPEVAL(cx);
4342     PL_curpm = newpm;
4343     LEAVE_with_name("eval_scope");
4344     PERL_UNUSED_VAR(newsp);
4345     PERL_UNUSED_VAR(gimme);
4346     PERL_UNUSED_VAR(optype);
4347 }
4348
4349 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4350    also needed by Perl_fold_constants.  */
4351 PERL_CONTEXT *
4352 Perl_create_eval_scope(pTHX_ U32 flags)
4353 {
4354     PERL_CONTEXT *cx;
4355     const I32 gimme = GIMME_V;
4356         
4357     ENTER_with_name("eval_scope");
4358     SAVETMPS;
4359
4360     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4361     PUSHEVAL(cx, 0);
4362
4363     PL_in_eval = EVAL_INEVAL;
4364     if (flags & G_KEEPERR)
4365         PL_in_eval |= EVAL_KEEPERR;
4366     else
4367         CLEAR_ERRSV();
4368     if (flags & G_FAKINGEVAL) {
4369         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4370     }
4371     return cx;
4372 }
4373     
4374 PP(pp_entertry)
4375 {
4376     dVAR;
4377     PERL_CONTEXT * const cx = create_eval_scope(0);
4378     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4379     return DOCATCH(PL_op->op_next);
4380 }
4381
4382 PP(pp_leavetry)
4383 {
4384     dVAR; dSP;
4385     SV **newsp;
4386     PMOP *newpm;
4387     I32 gimme;
4388     register PERL_CONTEXT *cx;
4389     I32 optype;
4390
4391     PERL_ASYNC_CHECK();
4392     POPBLOCK(cx,newpm);
4393     POPEVAL(cx);
4394     PERL_UNUSED_VAR(optype);
4395
4396     TAINT_NOT;
4397     if (gimme == G_VOID)
4398         SP = newsp;
4399     else if (gimme == G_SCALAR) {
4400         register SV **mark;
4401         MARK = newsp + 1;
4402         if (MARK <= SP) {
4403             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4404                 *MARK = TOPs;
4405             else
4406                 *MARK = sv_mortalcopy(TOPs);
4407         }
4408         else {
4409             MEXTEND(mark,0);
4410             *MARK = &PL_sv_undef;
4411         }
4412         SP = MARK;
4413     }
4414     else {
4415         /* in case LEAVE wipes old return values */
4416         register SV **mark;
4417         for (mark = newsp + 1; mark <= SP; mark++) {
4418             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4419                 *mark = sv_mortalcopy(*mark);
4420                 TAINT_NOT;      /* Each item is independent */
4421             }
4422         }
4423     }
4424     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4425
4426     LEAVE_with_name("eval_scope");
4427     CLEAR_ERRSV();
4428     RETURN;
4429 }
4430
4431 PP(pp_entergiven)
4432 {
4433     dVAR; dSP;
4434     register PERL_CONTEXT *cx;
4435     const I32 gimme = GIMME_V;
4436     
4437     ENTER_with_name("given");
4438     SAVETMPS;
4439
4440     sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
4441
4442     PUSHBLOCK(cx, CXt_GIVEN, SP);
4443     PUSHGIVEN(cx);
4444
4445     RETURN;
4446 }
4447
4448 PP(pp_leavegiven)
4449 {
4450     dVAR; dSP;
4451     register PERL_CONTEXT *cx;
4452     I32 gimme;
4453     SV **newsp;
4454     PMOP *newpm;
4455     PERL_UNUSED_CONTEXT;
4456
4457     POPBLOCK(cx,newpm);
4458     assert(CxTYPE(cx) == CXt_GIVEN);
4459
4460     TAINT_NOT;
4461     if (gimme == G_VOID)
4462         SP = newsp;
4463     else if (gimme == G_SCALAR) {
4464         register SV **mark;
4465         MARK = newsp + 1;
4466         if (MARK <= SP) {
4467             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4468                 *MARK = TOPs;
4469             else
4470                 *MARK = sv_mortalcopy(TOPs);
4471         }
4472         else {
4473             MEXTEND(mark,0);
4474             *MARK = &PL_sv_undef;
4475         }
4476         SP = MARK;
4477     }
4478     else {
4479         /* in case LEAVE wipes old return values */
4480         register SV **mark;
4481         for (mark = newsp + 1; mark <= SP; mark++) {
4482             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4483                 *mark = sv_mortalcopy(*mark);
4484                 TAINT_NOT;      /* Each item is independent */
4485             }
4486         }
4487     }
4488     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4489
4490     LEAVE_with_name("given");
4491     RETURN;
4492 }
4493
4494 /* Helper routines used by pp_smartmatch */
4495 STATIC PMOP *
4496 S_make_matcher(pTHX_ REGEXP *re)