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