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