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