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