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