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