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