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