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