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