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