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