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