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