This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pp_return: reindent
[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
2422     const I32 cxix = dopoptosub(cxstack_ix);
2423
2424     if (cxix < 0) {
2425         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2426                                      * sort block, which is a CXt_NULL
2427                                      * not a CXt_SUB */
2428             dounwind(0);
2429             /* if we were in list context, we would have to splice out
2430              * any junk before the return args, like we do in the general
2431              * pp_return case, e.g.
2432              *   sub f { for (junk1, junk2) { return arg1, arg2 }}
2433              */
2434             assert(cxstack[0].blk_gimme == G_SCALAR);
2435             return 0;
2436         }
2437         else
2438             DIE(aTHX_ "Can't return outside a subroutine");
2439     }
2440     if (cxix < cxstack_ix)
2441         dounwind(cxix);
2442
2443     cx = &cxstack[cxix];
2444
2445     oldsp = PL_stack_base + cx->blk_oldsp;
2446     if (oldsp != MARK) {
2447         /* Handle extra junk on the stack. For example,
2448          *    for (1,2) { return 3,4 }
2449          * leaves 1,2,3,4 on the stack. In list context we
2450          * have to splice out the 1,2; In scalar context for
2451          *    for (1,2) { return }
2452          * we need to set sp = oldsp so that pp_leavesub knows
2453          * to push &PL_sv_undef onto the stack.
2454          * Note that in pp_return we only do the extra processing
2455          * required to handle junk; everything else we leave to
2456          * pp_leavesub.
2457          */
2458         SSize_t nargs = SP - MARK;
2459         if (nargs) {
2460             if (cx->blk_gimme == G_ARRAY) {
2461                 /* shift return args to base of call stack frame */
2462                 Move(MARK + 1, oldsp + 1, nargs, SV**);
2463                 PL_stack_sp  = oldsp + nargs;
2464             }
2465         }
2466         else
2467             PL_stack_sp  = oldsp;
2468     }
2469
2470     /* fall through to a normal exit */
2471     switch (CxTYPE(cx)) {
2472     case CXt_EVAL:
2473         return CxTRYBLOCK(cx)
2474             ? Perl_pp_leavetry(aTHX)
2475             : Perl_pp_leaveeval(aTHX);
2476     case CXt_SUB:
2477         return CvLVALUE(cx->blk_sub.cv)
2478             ? Perl_pp_leavesublv(aTHX)
2479             : Perl_pp_leavesub(aTHX);
2480     case CXt_FORMAT:
2481         return Perl_pp_leavewrite(aTHX);
2482     default:
2483         DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2484     }
2485 }
2486
2487
2488 static I32
2489 S_unwind_loop(pTHX_ const char * const opname)
2490 {
2491     I32 cxix;
2492     if (PL_op->op_flags & OPf_SPECIAL) {
2493         cxix = dopoptoloop(cxstack_ix);
2494         if (cxix < 0)
2495             /* diag_listed_as: Can't "last" outside a loop block */
2496             Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2497     }
2498     else {
2499         dSP;
2500         STRLEN label_len;
2501         const char * const label =
2502             PL_op->op_flags & OPf_STACKED
2503                 ? SvPV(TOPs,label_len)
2504                 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2505         const U32 label_flags =
2506             PL_op->op_flags & OPf_STACKED
2507                 ? SvUTF8(POPs)
2508                 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2509         PUTBACK;
2510         cxix = dopoptolabel(label, label_len, label_flags);
2511         if (cxix < 0)
2512             /* diag_listed_as: Label not found for "last %s" */
2513             Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2514                                        opname,
2515                                        SVfARG(PL_op->op_flags & OPf_STACKED
2516                                               && !SvGMAGICAL(TOPp1s)
2517                                               ? TOPp1s
2518                                               : newSVpvn_flags(label,
2519                                                     label_len,
2520                                                     label_flags | SVs_TEMP)));
2521     }
2522     if (cxix < cxstack_ix)
2523         dounwind(cxix);
2524     return cxix;
2525 }
2526
2527 PP(pp_last)
2528 {
2529     PERL_CONTEXT *cx;
2530     I32 gimme;
2531     OP *nextop = NULL;
2532     SV **newsp;
2533     PMOP *newpm;
2534
2535     S_unwind_loop(aTHX_ "last");
2536
2537     POPBLOCK(cx,newpm);
2538     cxstack_ix++; /* temporarily protect top context */
2539     assert(
2540            CxTYPE(cx) == CXt_LOOP_LAZYIV
2541         || CxTYPE(cx) == CXt_LOOP_LAZYSV
2542         || CxTYPE(cx) == CXt_LOOP_FOR
2543         || CxTYPE(cx) == CXt_LOOP_PLAIN
2544     );
2545     newsp = PL_stack_base + cx->blk_loop.resetsp;
2546     nextop = cx->blk_loop.my_op->op_lastop->op_next;
2547
2548     TAINT_NOT;
2549     PL_stack_sp = newsp;
2550
2551     LEAVE;
2552     cxstack_ix--;
2553     /* Stack values are safe: */
2554     POPLOOP(cx);        /* release loop vars ... */
2555     LEAVE;
2556     PL_curpm = newpm;   /* ... and pop $1 et al */
2557
2558     PERL_UNUSED_VAR(gimme);
2559     return nextop;
2560 }
2561
2562 PP(pp_next)
2563 {
2564     PERL_CONTEXT *cx;
2565     const I32 inner = PL_scopestack_ix;
2566
2567     S_unwind_loop(aTHX_ "next");
2568
2569     /* clear off anything above the scope we're re-entering, but
2570      * save the rest until after a possible continue block */
2571     TOPBLOCK(cx);
2572     if (PL_scopestack_ix < inner)
2573         leave_scope(PL_scopestack[PL_scopestack_ix]);
2574     PL_curcop = cx->blk_oldcop;
2575     PERL_ASYNC_CHECK();
2576     return (cx)->blk_loop.my_op->op_nextop;
2577 }
2578
2579 PP(pp_redo)
2580 {
2581     const I32 cxix = S_unwind_loop(aTHX_ "redo");
2582     PERL_CONTEXT *cx;
2583     I32 oldsave;
2584     OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2585
2586     if (redo_op->op_type == OP_ENTER) {
2587         /* pop one less context to avoid $x being freed in while (my $x..) */
2588         cxstack_ix++;
2589         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2590         redo_op = redo_op->op_next;
2591     }
2592
2593     TOPBLOCK(cx);
2594     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2595     LEAVE_SCOPE(oldsave);
2596     FREETMPS;
2597     PL_curcop = cx->blk_oldcop;
2598     PERL_ASYNC_CHECK();
2599     return redo_op;
2600 }
2601
2602 STATIC OP *
2603 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2604 {
2605     OP **ops = opstack;
2606     static const char* const too_deep = "Target of goto is too deeply nested";
2607
2608     PERL_ARGS_ASSERT_DOFINDLABEL;
2609
2610     if (ops >= oplimit)
2611         Perl_croak(aTHX_ "%s", too_deep);
2612     if (o->op_type == OP_LEAVE ||
2613         o->op_type == OP_SCOPE ||
2614         o->op_type == OP_LEAVELOOP ||
2615         o->op_type == OP_LEAVESUB ||
2616         o->op_type == OP_LEAVETRY)
2617     {
2618         *ops++ = cUNOPo->op_first;
2619         if (ops >= oplimit)
2620             Perl_croak(aTHX_ "%s", too_deep);
2621     }
2622     *ops = 0;
2623     if (o->op_flags & OPf_KIDS) {
2624         OP *kid;
2625         /* First try all the kids at this level, since that's likeliest. */
2626         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2627             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2628                 STRLEN kid_label_len;
2629                 U32 kid_label_flags;
2630                 const char *kid_label = CopLABEL_len_flags(kCOP,
2631                                                     &kid_label_len, &kid_label_flags);
2632                 if (kid_label && (
2633                     ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2634                         (flags & SVf_UTF8)
2635                             ? (bytes_cmp_utf8(
2636                                         (const U8*)kid_label, kid_label_len,
2637                                         (const U8*)label, len) == 0)
2638                             : (bytes_cmp_utf8(
2639                                         (const U8*)label, len,
2640                                         (const U8*)kid_label, kid_label_len) == 0)
2641                     : ( len == kid_label_len && ((kid_label == label)
2642                                     || memEQ(kid_label, label, len)))))
2643                     return kid;
2644             }
2645         }
2646         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2647             if (kid == PL_lastgotoprobe)
2648                 continue;
2649             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2650                 if (ops == opstack)
2651                     *ops++ = kid;
2652                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2653                          ops[-1]->op_type == OP_DBSTATE)
2654                     ops[-1] = kid;
2655                 else
2656                     *ops++ = kid;
2657             }
2658             if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2659                 return o;
2660         }
2661     }
2662     *ops = 0;
2663     return 0;
2664 }
2665
2666
2667 /* also used for: pp_dump() */
2668
2669 PP(pp_goto)
2670 {
2671     dVAR; dSP;
2672     OP *retop = NULL;
2673     I32 ix;
2674     PERL_CONTEXT *cx;
2675 #define GOTO_DEPTH 64
2676     OP *enterops[GOTO_DEPTH];
2677     const char *label = NULL;
2678     STRLEN label_len = 0;
2679     U32 label_flags = 0;
2680     const bool do_dump = (PL_op->op_type == OP_DUMP);
2681     static const char* const must_have_label = "goto must have label";
2682
2683     if (PL_op->op_flags & OPf_STACKED) {
2684         /* goto EXPR  or  goto &foo */
2685
2686         SV * const sv = POPs;
2687         SvGETMAGIC(sv);
2688
2689         /* This egregious kludge implements goto &subroutine */
2690         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2691             I32 cxix;
2692             PERL_CONTEXT *cx;
2693             CV *cv = MUTABLE_CV(SvRV(sv));
2694             AV *arg = GvAV(PL_defgv);
2695             I32 oldsave;
2696
2697         retry:
2698             if (!CvROOT(cv) && !CvXSUB(cv)) {
2699                 const GV * const gv = CvGV(cv);
2700                 if (gv) {
2701                     GV *autogv;
2702                     SV *tmpstr;
2703                     /* autoloaded stub? */
2704                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2705                         goto retry;
2706                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2707                                           GvNAMELEN(gv),
2708                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2709                     if (autogv && (cv = GvCV(autogv)))
2710                         goto retry;
2711                     tmpstr = sv_newmortal();
2712                     gv_efullname3(tmpstr, gv, NULL);
2713                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2714                 }
2715                 DIE(aTHX_ "Goto undefined subroutine");
2716             }
2717
2718             /* First do some returnish stuff. */
2719             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2720             FREETMPS;
2721             cxix = dopoptosub(cxstack_ix);
2722             if (cxix < cxstack_ix) {
2723                 if (cxix < 0) {
2724                     SvREFCNT_dec(cv);
2725                     DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2726                 }
2727                 dounwind(cxix);
2728             }
2729             TOPBLOCK(cx);
2730             SPAGAIN;
2731             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2732             if (CxTYPE(cx) == CXt_EVAL) {
2733                 SvREFCNT_dec(cv);
2734                 if (CxREALEVAL(cx))
2735                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2736                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2737                 else
2738                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2739                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2740             }
2741             else if (CxMULTICALL(cx))
2742             {
2743                 SvREFCNT_dec(cv);
2744                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2745             }
2746             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2747                 AV* av = cx->blk_sub.argarray;
2748
2749                 /* abandon the original @_ if it got reified or if it is
2750                    the same as the current @_ */
2751                 if (AvREAL(av) || av == arg) {
2752                     SvREFCNT_dec(av);
2753                     av = newAV();
2754                     AvREIFY_only(av);
2755                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2756                 }
2757                 else CLEAR_ARGARRAY(av);
2758             }
2759             /* We donate this refcount later to the callee’s pad. */
2760             SvREFCNT_inc_simple_void(arg);
2761             if (CxTYPE(cx) == CXt_SUB &&
2762                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2763                 SvREFCNT_dec(cx->blk_sub.cv);
2764             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2765             LEAVE_SCOPE(oldsave);
2766
2767             /* A destructor called during LEAVE_SCOPE could have undefined
2768              * our precious cv.  See bug #99850. */
2769             if (!CvROOT(cv) && !CvXSUB(cv)) {
2770                 const GV * const gv = CvGV(cv);
2771                 SvREFCNT_dec(arg);
2772                 if (gv) {
2773                     SV * const tmpstr = sv_newmortal();
2774                     gv_efullname3(tmpstr, gv, NULL);
2775                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2776                                SVfARG(tmpstr));
2777                 }
2778                 DIE(aTHX_ "Goto undefined subroutine");
2779             }
2780
2781             /* Now do some callish stuff. */
2782             SAVETMPS;
2783             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2784             if (CvISXSUB(cv)) {
2785                 SV **newsp;
2786                 I32 gimme;
2787                 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2788                 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2789                 SV** mark;
2790
2791                 PERL_UNUSED_VAR(newsp);
2792                 PERL_UNUSED_VAR(gimme);
2793
2794                 /* put GvAV(defgv) back onto stack */
2795                 if (items) {
2796                     EXTEND(SP, items+1); /* @_ could have been extended. */
2797                 }
2798                 mark = SP;
2799                 if (items) {
2800                     SSize_t index;
2801                     bool r = cBOOL(AvREAL(arg));
2802                     for (index=0; index<items; index++)
2803                     {
2804                         SV *sv;
2805                         if (m) {
2806                             SV ** const svp = av_fetch(arg, index, 0);
2807                             sv = svp ? *svp : NULL;
2808                         }
2809                         else sv = AvARRAY(arg)[index];
2810                         SP[index+1] = sv
2811                             ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2812                             : sv_2mortal(newSVavdefelem(arg, index, 1));
2813                     }
2814                 }
2815                 SP += items;
2816                 SvREFCNT_dec(arg);
2817                 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2818                     /* Restore old @_ */
2819                     arg = GvAV(PL_defgv);
2820                     GvAV(PL_defgv) = cx->blk_sub.savearray;
2821                     SvREFCNT_dec(arg);
2822                 }
2823
2824                 retop = cx->blk_sub.retop;
2825                 /* XS subs don't have a CxSUB, so pop it */
2826                 POPBLOCK(cx, PL_curpm);
2827                 /* Push a mark for the start of arglist */
2828                 PUSHMARK(mark);
2829                 PUTBACK;
2830                 (void)(*CvXSUB(cv))(aTHX_ cv);
2831                 LEAVE;
2832                 goto _return;
2833             }
2834             else {
2835                 PADLIST * const padlist = CvPADLIST(cv);
2836                 cx->blk_sub.cv = cv;
2837                 cx->blk_sub.olddepth = CvDEPTH(cv);
2838
2839                 CvDEPTH(cv)++;
2840                 if (CvDEPTH(cv) < 2)
2841                     SvREFCNT_inc_simple_void_NN(cv);
2842                 else {
2843                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2844                         sub_crush_depth(cv);
2845                     pad_push(padlist, CvDEPTH(cv));
2846                 }
2847                 PL_curcop = cx->blk_oldcop;
2848                 SAVECOMPPAD();
2849                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2850                 if (CxHASARGS(cx))
2851                 {
2852                     CX_CURPAD_SAVE(cx->blk_sub);
2853
2854                     /* cx->blk_sub.argarray has no reference count, so we
2855                        need something to hang on to our argument array so
2856                        that cx->blk_sub.argarray does not end up pointing
2857                        to freed memory as the result of undef *_.  So put
2858                        it in the callee’s pad, donating our refer-
2859                        ence count. */
2860                     if (arg) {
2861                         SvREFCNT_dec(PAD_SVl(0));
2862                         PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2863                     }
2864
2865                     /* GvAV(PL_defgv) might have been modified on scope
2866                        exit, so restore it. */
2867                     if (arg != GvAV(PL_defgv)) {
2868                         AV * const av = GvAV(PL_defgv);
2869                         GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2870                         SvREFCNT_dec(av);
2871                     }
2872                 }
2873                 else SvREFCNT_dec(arg);
2874                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2875                     Perl_get_db_sub(aTHX_ NULL, cv);
2876                     if (PERLDB_GOTO) {
2877                         CV * const gotocv = get_cvs("DB::goto", 0);
2878                         if (gotocv) {
2879                             PUSHMARK( PL_stack_sp );
2880                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2881                             PL_stack_sp--;
2882                         }
2883                     }
2884                 }
2885                 retop = CvSTART(cv);
2886                 goto putback_return;
2887             }
2888         }
2889         else {
2890             /* goto EXPR */
2891             label       = SvPV_nomg_const(sv, label_len);
2892             label_flags = SvUTF8(sv);
2893         }
2894     }
2895     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2896         /* goto LABEL  or  dump LABEL */
2897         label       = cPVOP->op_pv;
2898         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2899         label_len   = strlen(label);
2900     }
2901     if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2902
2903     PERL_ASYNC_CHECK();
2904
2905     if (label_len) {
2906         OP *gotoprobe = NULL;
2907         bool leaving_eval = FALSE;
2908         bool in_block = FALSE;
2909         PERL_CONTEXT *last_eval_cx = NULL;
2910
2911         /* find label */
2912
2913         PL_lastgotoprobe = NULL;
2914         *enterops = 0;
2915         for (ix = cxstack_ix; ix >= 0; ix--) {
2916             cx = &cxstack[ix];
2917             switch (CxTYPE(cx)) {
2918             case CXt_EVAL:
2919                 leaving_eval = TRUE;
2920                 if (!CxTRYBLOCK(cx)) {
2921                     gotoprobe = (last_eval_cx ?
2922                                 last_eval_cx->blk_eval.old_eval_root :
2923                                 PL_eval_root);
2924                     last_eval_cx = cx;
2925                     break;
2926                 }
2927                 /* else fall through */
2928             case CXt_LOOP_LAZYIV:
2929             case CXt_LOOP_LAZYSV:
2930             case CXt_LOOP_FOR:
2931             case CXt_LOOP_PLAIN:
2932             case CXt_GIVEN:
2933             case CXt_WHEN:
2934                 gotoprobe = OpSIBLING(cx->blk_oldcop);
2935                 break;
2936             case CXt_SUBST:
2937                 continue;
2938             case CXt_BLOCK:
2939                 if (ix) {
2940                     gotoprobe = OpSIBLING(cx->blk_oldcop);
2941                     in_block = TRUE;
2942                 } else
2943                     gotoprobe = PL_main_root;
2944                 break;
2945             case CXt_SUB:
2946                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2947                     gotoprobe = CvROOT(cx->blk_sub.cv);
2948                     break;
2949                 }
2950                 /* FALLTHROUGH */
2951             case CXt_FORMAT:
2952             case CXt_NULL:
2953                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2954             default:
2955                 if (ix)
2956                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
2957                         CxTYPE(cx), (long) ix);
2958                 gotoprobe = PL_main_root;
2959                 break;
2960             }
2961             if (gotoprobe) {
2962                 OP *sibl1, *sibl2;
2963
2964                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
2965                                     enterops, enterops + GOTO_DEPTH);
2966                 if (retop)
2967                     break;
2968                 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
2969                      sibl1->op_type == OP_UNSTACK &&
2970                      (sibl2 = OpSIBLING(sibl1)))
2971                 {
2972                     retop = dofindlabel(sibl2,
2973                                         label, label_len, label_flags, enterops,
2974                                         enterops + GOTO_DEPTH);
2975                     if (retop)
2976                         break;
2977                 }
2978             }
2979             PL_lastgotoprobe = gotoprobe;
2980         }
2981         if (!retop)
2982             DIE(aTHX_ "Can't find label %"UTF8f, 
2983                        UTF8fARG(label_flags, label_len, label));
2984
2985         /* if we're leaving an eval, check before we pop any frames
2986            that we're not going to punt, otherwise the error
2987            won't be caught */
2988
2989         if (leaving_eval && *enterops && enterops[1]) {
2990             I32 i;
2991             for (i = 1; enterops[i]; i++)
2992                 if (enterops[i]->op_type == OP_ENTERITER)
2993                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2994         }
2995
2996         if (*enterops && enterops[1]) {
2997             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2998             if (enterops[i])
2999                 deprecate("\"goto\" to jump into a construct");
3000         }
3001
3002         /* pop unwanted frames */
3003
3004         if (ix < cxstack_ix) {
3005             I32 oldsave;
3006
3007             if (ix < 0)
3008                 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3009             dounwind(ix);
3010             TOPBLOCK(cx);
3011             oldsave = PL_scopestack[PL_scopestack_ix];
3012             LEAVE_SCOPE(oldsave);
3013         }
3014
3015         /* push wanted frames */
3016
3017         if (*enterops && enterops[1]) {
3018             OP * const oldop = PL_op;
3019             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3020             for (; enterops[ix]; ix++) {
3021                 PL_op = enterops[ix];
3022                 /* Eventually we may want to stack the needed arguments
3023                  * for each op.  For now, we punt on the hard ones. */
3024                 if (PL_op->op_type == OP_ENTERITER)
3025                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3026                 PL_op->op_ppaddr(aTHX);
3027             }
3028             PL_op = oldop;
3029         }
3030     }
3031
3032     if (do_dump) {
3033 #ifdef VMS
3034         if (!retop) retop = PL_main_start;
3035 #endif
3036         PL_restartop = retop;
3037         PL_do_undump = TRUE;
3038
3039         my_unexec();
3040
3041         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3042         PL_do_undump = FALSE;
3043     }
3044
3045     putback_return:
3046     PL_stack_sp = sp;
3047     _return:
3048     PERL_ASYNC_CHECK();
3049     return retop;
3050 }
3051
3052 PP(pp_exit)
3053 {
3054     dSP;
3055     I32 anum;
3056
3057     if (MAXARG < 1)
3058         anum = 0;
3059     else if (!TOPs) {
3060         anum = 0; (void)POPs;
3061     }
3062     else {
3063         anum = SvIVx(POPs);
3064 #ifdef VMS
3065         if (anum == 1
3066          && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3067             anum = 0;
3068         VMSISH_HUSHED  =
3069             VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3070 #endif
3071     }
3072     PL_exit_flags |= PERL_EXIT_EXPECTED;
3073     my_exit(anum);
3074     PUSHs(&PL_sv_undef);
3075     RETURN;
3076 }
3077
3078 /* Eval. */
3079
3080 STATIC void
3081 S_save_lines(pTHX_ AV *array, SV *sv)
3082 {
3083     const char *s = SvPVX_const(sv);
3084     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3085     I32 line = 1;
3086
3087     PERL_ARGS_ASSERT_SAVE_LINES;
3088
3089     while (s && s < send) {
3090         const char *t;
3091         SV * const tmpstr = newSV_type(SVt_PVMG);
3092
3093         t = (const char *)memchr(s, '\n', send - s);
3094         if (t)
3095             t++;
3096         else
3097             t = send;
3098
3099         sv_setpvn(tmpstr, s, t - s);
3100         av_store(array, line++, tmpstr);
3101         s = t;
3102     }
3103 }
3104
3105 /*
3106 =for apidoc docatch
3107
3108 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3109
3110 0 is used as continue inside eval,
3111
3112 3 is used for a die caught by an inner eval - continue inner loop
3113
3114 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3115 establish a local jmpenv to handle exception traps.
3116
3117 =cut
3118 */
3119 STATIC OP *
3120 S_docatch(pTHX_ OP *o)
3121 {
3122     int ret;
3123     OP * const oldop = PL_op;
3124     dJMPENV;
3125
3126 #ifdef DEBUGGING
3127     assert(CATCH_GET == TRUE);
3128 #endif
3129     PL_op = o;
3130
3131     JMPENV_PUSH(ret);
3132     switch (ret) {
3133     case 0:
3134         assert(cxstack_ix >= 0);
3135         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3136         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3137  redo_body:
3138         CALLRUNOPS(aTHX);
3139         break;
3140     case 3:
3141         /* die caught by an inner eval - continue inner loop */
3142         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3143             PL_restartjmpenv = NULL;
3144             PL_op = PL_restartop;
3145             PL_restartop = 0;
3146             goto redo_body;
3147         }
3148         /* FALLTHROUGH */
3149     default:
3150         JMPENV_POP;
3151         PL_op = oldop;
3152         JMPENV_JUMP(ret);
3153         NOT_REACHED; /* NOTREACHED */
3154     }
3155     JMPENV_POP;
3156     PL_op = oldop;
3157     return NULL;
3158 }
3159
3160
3161 /*
3162 =for apidoc find_runcv
3163
3164 Locate the CV corresponding to the currently executing sub or eval.
3165 If db_seqp is non_null, skip CVs that are in the DB package and populate
3166 *db_seqp with the cop sequence number at the point that the DB:: code was
3167 entered.  (This allows debuggers to eval in the scope of the breakpoint
3168 rather than in the scope of the debugger itself.)
3169
3170 =cut
3171 */
3172
3173 CV*
3174 Perl_find_runcv(pTHX_ U32 *db_seqp)
3175 {
3176     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3177 }
3178
3179 /* If this becomes part of the API, it might need a better name. */
3180 CV *
3181 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3182 {
3183     PERL_SI      *si;
3184     int          level = 0;
3185
3186     if (db_seqp)
3187         *db_seqp =
3188             PL_curcop == &PL_compiling
3189                 ? PL_cop_seqmax
3190                 : PL_curcop->cop_seq;
3191
3192     for (si = PL_curstackinfo; si; si = si->si_prev) {
3193         I32 ix;
3194         for (ix = si->si_cxix; ix >= 0; ix--) {
3195             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3196             CV *cv = NULL;
3197             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3198                 cv = cx->blk_sub.cv;
3199                 /* skip DB:: code */
3200                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3201                     *db_seqp = cx->blk_oldcop->cop_seq;
3202                     continue;
3203                 }
3204                 if (cx->cx_type & CXp_SUB_RE)
3205                     continue;
3206             }
3207             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3208                 cv = cx->blk_eval.cv;
3209             if (cv) {
3210                 switch (cond) {
3211                 case FIND_RUNCV_padid_eq:
3212                     if (!CvPADLIST(cv)
3213                      || CvPADLIST(cv)->xpadl_id != (U32)arg)
3214                         continue;
3215                     return cv;
3216                 case FIND_RUNCV_level_eq:
3217                     if (level++ != arg) continue;
3218                     /* GERONIMO! */
3219                 default:
3220                     return cv;
3221                 }
3222             }
3223         }
3224     }
3225     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3226 }
3227
3228
3229 /* Run yyparse() in a setjmp wrapper. Returns:
3230  *   0: yyparse() successful
3231  *   1: yyparse() failed
3232  *   3: yyparse() died
3233  */
3234 STATIC int
3235 S_try_yyparse(pTHX_ int gramtype)
3236 {
3237     int ret;
3238     dJMPENV;
3239
3240     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3241     JMPENV_PUSH(ret);
3242     switch (ret) {
3243     case 0:
3244         ret = yyparse(gramtype) ? 1 : 0;
3245         break;
3246     case 3:
3247         break;
3248     default:
3249         JMPENV_POP;
3250         JMPENV_JUMP(ret);
3251         NOT_REACHED; /* NOTREACHED */
3252     }
3253     JMPENV_POP;
3254     return ret;
3255 }
3256
3257
3258 /* Compile a require/do or an eval ''.
3259  *
3260  * outside is the lexically enclosing CV (if any) that invoked us.
3261  * seq     is the current COP scope value.
3262  * hh      is the saved hints hash, if any.
3263  *
3264  * Returns a bool indicating whether the compile was successful; if so,
3265  * PL_eval_start contains the first op of the compiled code; otherwise,
3266  * pushes undef.
3267  *
3268  * This function is called from two places: pp_require and pp_entereval.
3269  * These can be distinguished by whether PL_op is entereval.
3270  */
3271
3272 STATIC bool
3273 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3274 {
3275     dSP;
3276     OP * const saveop = PL_op;
3277     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3278     COP * const oldcurcop = PL_curcop;
3279     bool in_require = (saveop->op_type == OP_REQUIRE);
3280     int yystatus;
3281     CV *evalcv;
3282
3283     PL_in_eval = (in_require
3284                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3285                   : (EVAL_INEVAL |
3286                         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3287                             ? EVAL_RE_REPARSING : 0)));
3288
3289     PUSHMARK(SP);
3290
3291     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3292     CvEVAL_on(evalcv);
3293     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3294     cxstack[cxstack_ix].blk_eval.cv = evalcv;
3295     cxstack[cxstack_ix].blk_gimme = gimme;
3296
3297     CvOUTSIDE_SEQ(evalcv) = seq;
3298     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3299
3300     /* set up a scratch pad */
3301
3302     CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3303     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3304
3305
3306     SAVEMORTALIZESV(evalcv);    /* must remain until end of current statement */
3307
3308     /* make sure we compile in the right package */
3309
3310     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3311         SAVEGENERICSV(PL_curstash);
3312         PL_curstash = (HV *)CopSTASH(PL_curcop);
3313         if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3314         else SvREFCNT_inc_simple_void(PL_curstash);
3315     }
3316     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3317     SAVESPTR(PL_beginav);
3318     PL_beginav = newAV();
3319     SAVEFREESV(PL_beginav);
3320     SAVESPTR(PL_unitcheckav);
3321     PL_unitcheckav = newAV();
3322     SAVEFREESV(PL_unitcheckav);
3323
3324
3325     ENTER_with_name("evalcomp");
3326     SAVESPTR(PL_compcv);
3327     PL_compcv = evalcv;
3328
3329     /* try to compile it */
3330
3331     PL_eval_root = NULL;
3332     PL_curcop = &PL_compiling;
3333     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3334         PL_in_eval |= EVAL_KEEPERR;
3335     else
3336         CLEAR_ERRSV();
3337
3338     SAVEHINTS();
3339     if (clear_hints) {
3340         PL_hints = 0;
3341         hv_clear(GvHV(PL_hintgv));
3342     }
3343     else {
3344         PL_hints = saveop->op_private & OPpEVAL_COPHH
3345                      ? oldcurcop->cop_hints : saveop->op_targ;
3346
3347         /* making 'use re eval' not be in scope when compiling the
3348          * qr/mabye_has_runtime_code_block/ ensures that we don't get
3349          * infinite recursion when S_has_runtime_code() gives a false
3350          * positive: the second time round, HINT_RE_EVAL isn't set so we
3351          * don't bother calling S_has_runtime_code() */
3352         if (PL_in_eval & EVAL_RE_REPARSING)
3353             PL_hints &= ~HINT_RE_EVAL;
3354
3355         if (hh) {
3356             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3357             SvREFCNT_dec(GvHV(PL_hintgv));
3358             GvHV(PL_hintgv) = hh;
3359         }
3360     }
3361     SAVECOMPILEWARNINGS();
3362     if (clear_hints) {
3363         if (PL_dowarn & G_WARN_ALL_ON)
3364             PL_compiling.cop_warnings = pWARN_ALL ;
3365         else if (PL_dowarn & G_WARN_ALL_OFF)
3366             PL_compiling.cop_warnings = pWARN_NONE ;
3367         else
3368             PL_compiling.cop_warnings = pWARN_STD ;
3369     }
3370     else {
3371         PL_compiling.cop_warnings =
3372             DUP_WARNINGS(oldcurcop->cop_warnings);
3373         cophh_free(CopHINTHASH_get(&PL_compiling));
3374         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3375             /* The label, if present, is the first entry on the chain. So rather
3376                than writing a blank label in front of it (which involves an
3377                allocation), just use the next entry in the chain.  */
3378             PL_compiling.cop_hints_hash
3379                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3380             /* Check the assumption that this removed the label.  */
3381             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3382         }
3383         else
3384             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3385     }
3386
3387     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3388
3389     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3390      * so honour CATCH_GET and trap it here if necessary */
3391
3392     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3393
3394     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3395         SV **newsp;                     /* Used by POPBLOCK. */
3396         PERL_CONTEXT *cx;
3397         I32 optype;                     /* Used by POPEVAL. */
3398         SV *namesv;
3399         SV *errsv = NULL;
3400
3401         cx = NULL;
3402         namesv = NULL;
3403         PERL_UNUSED_VAR(newsp);
3404         PERL_UNUSED_VAR(optype);
3405
3406         /* note that if yystatus == 3, then the EVAL CX block has already
3407          * been popped, and various vars restored */
3408         PL_op = saveop;
3409         if (yystatus != 3) {
3410             if (PL_eval_root) {
3411                 op_free(PL_eval_root);
3412                 PL_eval_root = NULL;
3413             }
3414             SP = PL_stack_base + POPMARK;       /* pop original mark */
3415             POPBLOCK(cx,PL_curpm);
3416             POPEVAL(cx);
3417             namesv = cx->blk_eval.old_namesv;
3418             /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3419             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3420         }
3421
3422         errsv = ERRSV;
3423         if (in_require) {
3424             if (!cx) {
3425                 /* If cx is still NULL, it means that we didn't go in the
3426                  * POPEVAL branch. */
3427                 cx = &cxstack[cxstack_ix];
3428                 assert(CxTYPE(cx) == CXt_EVAL);
3429                 namesv = cx->blk_eval.old_namesv;
3430             }
3431             (void)hv_store(GvHVn(PL_incgv),
3432                            SvPVX_const(namesv),
3433                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3434                            &PL_sv_undef, 0);
3435             Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3436                        SVfARG(errsv
3437                                 ? errsv
3438                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3439         }
3440         else {
3441             if (!*(SvPV_nolen_const(errsv))) {
3442                 sv_setpvs(errsv, "Compilation error");
3443             }
3444         }
3445         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3446         PUTBACK;
3447         return FALSE;
3448     }
3449     else
3450         LEAVE_with_name("evalcomp");
3451
3452     CopLINE_set(&PL_compiling, 0);
3453     SAVEFREEOP(PL_eval_root);
3454     cv_forget_slab(evalcv);
3455
3456     DEBUG_x(dump_eval());
3457
3458     /* Register with debugger: */
3459     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3460         CV * const cv = get_cvs("DB::postponed", 0);
3461         if (cv) {
3462             dSP;
3463             PUSHMARK(SP);
3464             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3465             PUTBACK;
3466             call_sv(MUTABLE_SV(cv), G_DISCARD);
3467         }
3468     }
3469
3470     if (PL_unitcheckav) {
3471         OP *es = PL_eval_start;
3472         call_list(PL_scopestack_ix, PL_unitcheckav);
3473         PL_eval_start = es;
3474     }
3475
3476     /* compiled okay, so do it */
3477
3478     CvDEPTH(evalcv) = 1;
3479     SP = PL_stack_base + POPMARK;               /* pop original mark */
3480     PL_op = saveop;                     /* The caller may need it. */
3481     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3482
3483     PUTBACK;
3484     return TRUE;
3485 }
3486
3487 STATIC PerlIO *
3488 S_check_type_and_open(pTHX_ SV *name)
3489 {
3490     Stat_t st;
3491     STRLEN len;
3492     PerlIO * retio;
3493     const char *p = SvPV_const(name, len);
3494     int st_rc;
3495
3496     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3497
3498     /* checking here captures a reasonable error message when
3499      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3500      * user gets a confusing message about looking for the .pmc file
3501      * rather than for the .pm file.
3502      * This check prevents a \0 in @INC causing problems.
3503      */
3504     if (!IS_SAFE_PATHNAME(p, len, "require"))
3505         return NULL;
3506
3507     /* on Win32 stat is expensive (it does an open() and close() twice and
3508        a couple other IO calls), the open will fail with a dir on its own with
3509        errno EACCES, so only do a stat to separate a dir from a real EACCES
3510        caused by user perms */
3511 #ifndef WIN32
3512     /* we use the value of errno later to see how stat() or open() failed.
3513      * We don't want it set if the stat succeeded but we still failed,
3514      * such as if the name exists, but is a directory */
3515     errno = 0;
3516
3517     st_rc = PerlLIO_stat(p, &st);
3518
3519     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3520         return NULL;
3521     }
3522 #endif
3523
3524 #if !defined(PERLIO_IS_STDIO)
3525     retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3526 #else
3527     retio = PerlIO_open(p, PERL_SCRIPT_MODE);
3528 #endif
3529 #ifdef WIN32
3530     /* EACCES stops the INC search early in pp_require to implement
3531        feature RT #113422 */
3532     if(!retio && errno == EACCES) { /* exists but probably a directory */
3533         int eno;
3534         st_rc = PerlLIO_stat(p, &st);
3535         if (st_rc >= 0) {
3536             if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3537                 eno = 0;
3538             else
3539                 eno = EACCES;
3540             errno = eno;
3541         }
3542     }
3543 #endif
3544     return retio;
3545 }
3546
3547 #ifndef PERL_DISABLE_PMC
3548 STATIC PerlIO *
3549 S_doopen_pm(pTHX_ SV *name)
3550 {
3551     STRLEN namelen;
3552     const char *p = SvPV_const(name, namelen);
3553
3554     PERL_ARGS_ASSERT_DOOPEN_PM;
3555
3556     /* check the name before trying for the .pmc name to avoid the
3557      * warning referring to the .pmc which the user probably doesn't
3558      * know or care about
3559      */
3560     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3561         return NULL;
3562
3563     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3564         SV *const pmcsv = sv_newmortal();
3565         Stat_t pmcstat;
3566
3567         SvSetSV_nosteal(pmcsv,name);
3568         sv_catpvs(pmcsv, "c");
3569
3570         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3571             return check_type_and_open(pmcsv);
3572     }
3573     return check_type_and_open(name);
3574 }
3575 #else
3576 #  define doopen_pm(name) check_type_and_open(name)
3577 #endif /* !PERL_DISABLE_PMC */
3578
3579 /* require doesn't search for absolute names, or when the name is
3580    explicitly relative the current directory */
3581 PERL_STATIC_INLINE bool
3582 S_path_is_searchable(const char *name)
3583 {
3584     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3585
3586     if (PERL_FILE_IS_ABSOLUTE(name)
3587 #ifdef WIN32
3588         || (*name == '.' && ((name[1] == '/' ||
3589                              (name[1] == '.' && name[2] == '/'))
3590                          || (name[1] == '\\' ||
3591                              ( name[1] == '.' && name[2] == '\\')))
3592             )
3593 #else
3594         || (*name == '.' && (name[1] == '/' ||
3595                              (name[1] == '.' && name[2] == '/')))
3596 #endif
3597          )
3598     {
3599         return FALSE;
3600     }
3601     else
3602         return TRUE;
3603 }
3604
3605
3606 /* also used for: pp_dofile() */
3607
3608 PP(pp_require)
3609 {
3610     dSP;
3611     PERL_CONTEXT *cx;
3612     SV *sv;
3613     const char *name;
3614     STRLEN len;
3615     char * unixname;
3616     STRLEN unixlen;
3617 #ifdef VMS
3618     int vms_unixname = 0;
3619     char *unixdir;
3620 #endif
3621     const char *tryname = NULL;
3622     SV *namesv = NULL;
3623     const I32 gimme = GIMME_V;
3624     int filter_has_file = 0;
3625     PerlIO *tryrsfp = NULL;
3626     SV *filter_cache = NULL;
3627     SV *filter_state = NULL;
3628     SV *filter_sub = NULL;
3629     SV *hook_sv = NULL;
3630     OP *op;
3631     int saved_errno;
3632     bool path_searchable;
3633
3634     sv = POPs;
3635     SvGETMAGIC(sv);
3636     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3637         sv = sv_2mortal(new_version(sv));
3638         if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3639             upg_version(PL_patchlevel, TRUE);
3640         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3641             if ( vcmp(sv,PL_patchlevel) <= 0 )
3642                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3643                     SVfARG(sv_2mortal(vnormal(sv))),
3644                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3645                 );
3646         }
3647         else {
3648             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3649                 I32 first = 0;
3650                 AV *lav;
3651                 SV * const req = SvRV(sv);
3652                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3653
3654                 /* get the left hand term */
3655                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3656
3657                 first  = SvIV(*av_fetch(lav,0,0));
3658                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3659                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3660                     || av_tindex(lav) > 1            /* FP with > 3 digits */
3661                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3662                    ) {
3663                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3664                         "%"SVf", stopped",
3665                         SVfARG(sv_2mortal(vnormal(req))),
3666                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3667                     );
3668                 }
3669                 else { /* probably 'use 5.10' or 'use 5.8' */
3670                     SV *hintsv;
3671                     I32 second = 0;
3672
3673                     if (av_tindex(lav)>=1)
3674                         second = SvIV(*av_fetch(lav,1,0));
3675
3676                     second /= second >= 600  ? 100 : 10;
3677                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3678                                            (int)first, (int)second);
3679                     upg_version(hintsv, TRUE);
3680
3681                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3682                         "--this is only %"SVf", stopped",
3683                         SVfARG(sv_2mortal(vnormal(req))),
3684                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3685                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3686                     );
3687                 }
3688             }
3689         }
3690
3691         RETPUSHYES;
3692     }
3693     if (!SvOK(sv))
3694         DIE(aTHX_ "Missing or undefined argument to require");
3695     name = SvPV_nomg_const(sv, len);
3696     if (!(name && len > 0 && *name))
3697         DIE(aTHX_ "Missing or undefined argument to require");
3698
3699     if (!IS_SAFE_PATHNAME(name, len, "require")) {
3700         DIE(aTHX_ "Can't locate %s:   %s",
3701             pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3702                       SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3703             Strerror(ENOENT));
3704     }
3705     TAINT_PROPER("require");
3706
3707     path_searchable = path_is_searchable(name);
3708
3709 #ifdef VMS
3710     /* The key in the %ENV hash is in the syntax of file passed as the argument
3711      * usually this is in UNIX format, but sometimes in VMS format, which
3712      * can result in a module being pulled in more than once.
3713      * To prevent this, the key must be stored in UNIX format if the VMS
3714      * name can be translated to UNIX.
3715      */
3716     
3717     if ((unixname =
3718           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3719          != NULL) {
3720         unixlen = strlen(unixname);
3721         vms_unixname = 1;
3722     }
3723     else
3724 #endif
3725     {
3726         /* if not VMS or VMS name can not be translated to UNIX, pass it
3727          * through.
3728          */
3729         unixname = (char *) name;
3730         unixlen = len;
3731     }
3732     if (PL_op->op_type == OP_REQUIRE) {
3733         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3734                                           unixname, unixlen, 0);
3735         if ( svp ) {
3736             if (*svp != &PL_sv_undef)
3737                 RETPUSHYES;
3738             else
3739                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3740                             "Compilation failed in require", unixname);
3741         }
3742     }
3743
3744     LOADING_FILE_PROBE(unixname);
3745
3746     /* prepare to compile file */
3747
3748     if (!path_searchable) {
3749         /* At this point, name is SvPVX(sv)  */
3750         tryname = name;
3751         tryrsfp = doopen_pm(sv);
3752     }
3753     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3754         AV * const ar = GvAVn(PL_incgv);
3755         SSize_t i;
3756 #ifdef VMS
3757         if (vms_unixname)
3758 #endif
3759         {
3760             SV *nsv = sv;
3761             namesv = newSV_type(SVt_PV);
3762             for (i = 0; i <= AvFILL(ar); i++) {
3763                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3764
3765                 SvGETMAGIC(dirsv);
3766                 if (SvROK(dirsv)) {
3767                     int count;
3768                     SV **svp;
3769                     SV *loader = dirsv;
3770
3771                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3772                         && !SvOBJECT(SvRV(loader)))
3773                     {
3774                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3775                         SvGETMAGIC(loader);
3776                     }
3777
3778                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3779                                    PTR2UV(SvRV(dirsv)), name);
3780                     tryname = SvPVX_const(namesv);
3781                     tryrsfp = NULL;
3782
3783                     if (SvPADTMP(nsv)) {
3784                         nsv = sv_newmortal();
3785                         SvSetSV_nosteal(nsv,sv);
3786                     }
3787
3788                     ENTER_with_name("call_INC");
3789                     SAVETMPS;
3790                     EXTEND(SP, 2);
3791
3792                     PUSHMARK(SP);
3793                     PUSHs(dirsv);
3794                     PUSHs(nsv);
3795                     PUTBACK;
3796                     if (SvGMAGICAL(loader)) {
3797                         SV *l = sv_newmortal();
3798                         sv_setsv_nomg(l, loader);
3799                         loader = l;
3800                     }
3801                     if (sv_isobject(loader))
3802                         count = call_method("INC", G_ARRAY);
3803                     else
3804                         count = call_sv(loader, G_ARRAY);
3805                     SPAGAIN;
3806
3807                     if (count > 0) {
3808                         int i = 0;
3809                         SV *arg;
3810
3811                         SP -= count - 1;
3812                         arg = SP[i++];
3813
3814                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3815                             && !isGV_with_GP(SvRV(arg))) {
3816                             filter_cache = SvRV(arg);
3817
3818                             if (i < count) {
3819                                 arg = SP[i++];
3820                             }
3821                         }
3822
3823                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3824                             arg = SvRV(arg);
3825                         }
3826
3827                         if (isGV_with_GP(arg)) {
3828                             IO * const io = GvIO((const GV *)arg);
3829
3830                             ++filter_has_file;
3831
3832                             if (io) {
3833                                 tryrsfp = IoIFP(io);
3834                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3835                                     PerlIO_close(IoOFP(io));
3836                                 }
3837                                 IoIFP(io) = NULL;
3838                                 IoOFP(io) = NULL;
3839                             }
3840
3841                             if (i < count) {
3842                                 arg = SP[i++];
3843                             }
3844                         }
3845
3846                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3847                             filter_sub = arg;
3848                             SvREFCNT_inc_simple_void_NN(filter_sub);
3849
3850                             if (i < count) {
3851                                 filter_state = SP[i];
3852                                 SvREFCNT_inc_simple_void(filter_state);
3853                             }
3854                         }
3855
3856                         if (!tryrsfp && (filter_cache || filter_sub)) {
3857                             tryrsfp = PerlIO_open(BIT_BUCKET,
3858                                                   PERL_SCRIPT_MODE);
3859                         }
3860                         SP--;
3861                     }
3862
3863                     /* FREETMPS may free our filter_cache */
3864                     SvREFCNT_inc_simple_void(filter_cache);
3865
3866                     PUTBACK;
3867                     FREETMPS;
3868                     LEAVE_with_name("call_INC");
3869
3870                     /* Now re-mortalize it. */
3871                     sv_2mortal(filter_cache);
3872
3873                     /* Adjust file name if the hook has set an %INC entry.
3874                        This needs to happen after the FREETMPS above.  */
3875                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3876                     if (svp)
3877                         tryname = SvPV_nolen_const(*svp);
3878
3879                     if (tryrsfp) {
3880                         hook_sv = dirsv;
3881                         break;
3882                     }
3883
3884                     filter_has_file = 0;
3885                     filter_cache = NULL;
3886                     if (filter_state) {
3887                         SvREFCNT_dec_NN(filter_state);
3888                         filter_state = NULL;
3889                     }
3890                     if (filter_sub) {
3891                         SvREFCNT_dec_NN(filter_sub);
3892                         filter_sub = NULL;
3893                     }
3894                 }
3895                 else {
3896                   if (path_searchable) {
3897                     const char *dir;
3898                     STRLEN dirlen;
3899
3900                     if (SvOK(dirsv)) {
3901                         dir = SvPV_nomg_const(dirsv, dirlen);
3902                     } else {
3903                         dir = "";
3904                         dirlen = 0;
3905                     }
3906
3907                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3908                         continue;
3909 #ifdef VMS
3910                     if ((unixdir =
3911                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3912                          == NULL)
3913                         continue;
3914                     sv_setpv(namesv, unixdir);
3915                     sv_catpv(namesv, unixname);
3916 #else
3917 #  ifdef __SYMBIAN32__
3918                     if (PL_origfilename[0] &&
3919                         PL_origfilename[1] == ':' &&
3920                         !(dir[0] && dir[1] == ':'))
3921                         Perl_sv_setpvf(aTHX_ namesv,
3922                                        "%c:%s\\%s",
3923                                        PL_origfilename[0],
3924                                        dir, name);
3925                     else
3926                         Perl_sv_setpvf(aTHX_ namesv,
3927                                        "%s\\%s",
3928                                        dir, name);
3929 #  else
3930                     /* The equivalent of                    
3931                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3932                        but without the need to parse the format string, or
3933                        call strlen on either pointer, and with the correct
3934                        allocation up front.  */
3935                     {
3936                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3937
3938                         memcpy(tmp, dir, dirlen);
3939                         tmp +=dirlen;
3940
3941                         /* Avoid '<dir>//<file>' */
3942                         if (!dirlen || *(tmp-1) != '/') {
3943                             *tmp++ = '/';
3944                         } else {
3945                             /* So SvCUR_set reports the correct length below */
3946                             dirlen--;
3947                         }
3948
3949                         /* name came from an SV, so it will have a '\0' at the
3950                            end that we can copy as part of this memcpy().  */
3951                         memcpy(tmp, name, len + 1);
3952
3953                         SvCUR_set(namesv, dirlen + len + 1);
3954                         SvPOK_on(namesv);
3955                     }
3956 #  endif
3957 #endif
3958                     TAINT_PROPER("require");
3959                     tryname = SvPVX_const(namesv);
3960                     tryrsfp = doopen_pm(namesv);
3961                     if (tryrsfp) {
3962                         if (tryname[0] == '.' && tryname[1] == '/') {
3963                             ++tryname;
3964                             while (*++tryname == '/') {}
3965                         }
3966                         break;
3967                     }
3968                     else if (errno == EMFILE || errno == EACCES) {
3969                         /* no point in trying other paths if out of handles;
3970                          * on the other hand, if we couldn't open one of the
3971                          * files, then going on with the search could lead to
3972                          * unexpected results; see perl #113422
3973                          */
3974                         break;
3975                     }
3976                   }
3977                 }
3978             }
3979         }
3980     }
3981     saved_errno = errno; /* sv_2mortal can realloc things */
3982     sv_2mortal(namesv);
3983     if (!tryrsfp) {
3984         if (PL_op->op_type == OP_REQUIRE) {
3985             if(saved_errno == EMFILE || saved_errno == EACCES) {
3986                 /* diag_listed_as: Can't locate %s */
3987                 DIE(aTHX_ "Can't locate %s:   %s: %s",
3988                     name, tryname, Strerror(saved_errno));
3989             } else {
3990                 if (namesv) {                   /* did we lookup @INC? */
3991                     AV * const ar = GvAVn(PL_incgv);
3992                     SSize_t i;
3993                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
3994                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
3995                     for (i = 0; i <= AvFILL(ar); i++) {
3996                         sv_catpvs(inc, " ");
3997                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
3998                     }
3999                     if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4000                         const char *c, *e = name + len - 3;
4001                         sv_catpv(msg, " (you may need to install the ");
4002                         for (c = name; c < e; c++) {
4003                             if (*c == '/') {
4004                                 sv_catpvs(msg, "::");
4005                             }
4006                             else {
4007                                 sv_catpvn(msg, c, 1);
4008                             }
4009                         }
4010                         sv_catpv(msg, " module)");
4011                     }
4012                     else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4013                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4014                     }
4015                     else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4016                         sv_catpv(msg, " (did you run h2ph?)");
4017                     }
4018
4019                     /* diag_listed_as: Can't locate %s */
4020                     DIE(aTHX_
4021                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4022                         name, msg, inc);
4023                 }
4024             }
4025             DIE(aTHX_ "Can't locate %s", name);
4026         }
4027
4028         CLEAR_ERRSV();
4029         RETPUSHUNDEF;
4030     }
4031     else
4032         SETERRNO(0, SS_NORMAL);
4033
4034     /* Assume success here to prevent recursive requirement. */
4035     /* name is never assigned to again, so len is still strlen(name)  */
4036     /* Check whether a hook in @INC has already filled %INC */
4037     if (!hook_sv) {
4038         (void)hv_store(GvHVn(PL_incgv),
4039                        unixname, unixlen, newSVpv(tryname,0),0);
4040     } else {
4041         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4042         if (!svp)
4043             (void)hv_store(GvHVn(PL_incgv),
4044                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4045     }
4046
4047     ENTER_with_name("eval");
4048     SAVETMPS;
4049     SAVECOPFILE_FREE(&PL_compiling);
4050     CopFILE_set(&PL_compiling, tryname);
4051     lex_start(NULL, tryrsfp, 0);
4052
4053     if (filter_sub || filter_cache) {
4054         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4055            than hanging another SV from it. In turn, filter_add() optionally
4056            takes the SV to use as the filter (or creates a new SV if passed
4057            NULL), so simply pass in whatever value filter_cache has.  */
4058         SV * const fc = filter_cache ? newSV(0) : NULL;
4059         SV *datasv;
4060         if (fc) sv_copypv(fc, filter_cache);
4061         datasv = filter_add(S_run_user_filter, fc);
4062         IoLINES(datasv) = filter_has_file;
4063         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4064         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4065     }
4066
4067     /* switch to eval mode */
4068     PUSHBLOCK(cx, CXt_EVAL, SP);
4069     PUSHEVAL(cx, name);
4070     cx->blk_eval.retop = PL_op->op_next;
4071
4072     SAVECOPLINE(&PL_compiling);
4073     CopLINE_set(&PL_compiling, 0);
4074
4075     PUTBACK;
4076
4077     if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4078         op = DOCATCH(PL_eval_start);
4079     else
4080         op = PL_op->op_next;
4081
4082     LOADED_FILE_PROBE(unixname);
4083
4084     return op;
4085 }
4086
4087 /* This is a op added to hold the hints hash for
4088    pp_entereval. The hash can be modified by the code
4089    being eval'ed, so we return a copy instead. */
4090
4091 PP(pp_hintseval)
4092 {
4093     dSP;
4094     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4095     RETURN;
4096 }
4097
4098
4099 PP(pp_entereval)
4100 {
4101     dSP;
4102     PERL_CONTEXT *cx;
4103     SV *sv;
4104     const I32 gimme = GIMME_V;
4105     const U32 was = PL_breakable_sub_gen;
4106     char tbuf[TYPE_DIGITS(long) + 12];
4107     bool saved_delete = FALSE;
4108     char *tmpbuf = tbuf;
4109     STRLEN len;
4110     CV* runcv;
4111     U32 seq, lex_flags = 0;
4112     HV *saved_hh = NULL;
4113     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4114
4115     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4116         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4117     }
4118     else if (PL_hints & HINT_LOCALIZE_HH || (
4119                 PL_op->op_private & OPpEVAL_COPHH
4120              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4121             )) {
4122         saved_hh = cop_hints_2hv(PL_curcop, 0);
4123         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4124     }
4125     sv = POPs;
4126     if (!SvPOK(sv)) {
4127         /* make sure we've got a plain PV (no overload etc) before testing
4128          * for taint. Making a copy here is probably overkill, but better
4129          * safe than sorry */
4130         STRLEN len;
4131         const char * const p = SvPV_const(sv, len);
4132
4133         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4134         lex_flags |= LEX_START_COPIED;
4135
4136         if (bytes && SvUTF8(sv))
4137             SvPVbyte_force(sv, len);
4138     }
4139     else if (bytes && SvUTF8(sv)) {
4140         /* Don't modify someone else's scalar */
4141         STRLEN len;
4142         sv = newSVsv(sv);
4143         (void)sv_2mortal(sv);
4144         SvPVbyte_force(sv,len);
4145         lex_flags |= LEX_START_COPIED;
4146     }
4147
4148     TAINT_IF(SvTAINTED(sv));
4149     TAINT_PROPER("eval");
4150
4151     ENTER_with_name("eval");
4152     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4153                            ? LEX_IGNORE_UTF8_HINTS
4154                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4155                         )
4156              );
4157     SAVETMPS;
4158
4159     /* switch to eval mode */
4160
4161     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4162         SV * const temp_sv = sv_newmortal();
4163         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4164                        (unsigned long)++PL_evalseq,
4165                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4166         tmpbuf = SvPVX(temp_sv);
4167         len = SvCUR(temp_sv);
4168     }
4169     else
4170         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4171     SAVECOPFILE_FREE(&PL_compiling);
4172     CopFILE_set(&PL_compiling, tmpbuf+2);
4173     SAVECOPLINE(&PL_compiling);
4174     CopLINE_set(&PL_compiling, 1);
4175     /* special case: an eval '' executed within the DB package gets lexically
4176      * placed in the first non-DB CV rather than the current CV - this
4177      * allows the debugger to execute code, find lexicals etc, in the
4178      * scope of the code being debugged. Passing &seq gets find_runcv
4179      * to do the dirty work for us */
4180     runcv = find_runcv(&seq);
4181
4182     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4183     PUSHEVAL(cx, 0);
4184     cx->blk_eval.retop = PL_op->op_next;
4185
4186     /* prepare to compile string */
4187
4188     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4189         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4190     else {
4191         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4192            deleting the eval's FILEGV from the stash before gv_check() runs
4193            (i.e. before run-time proper). To work around the coredump that
4194            ensues, we always turn GvMULTI_on for any globals that were
4195            introduced within evals. See force_ident(). GSAR 96-10-12 */
4196         char *const safestr = savepvn(tmpbuf, len);
4197         SAVEDELETE(PL_defstash, safestr, len);
4198         saved_delete = TRUE;
4199     }
4200     
4201     PUTBACK;
4202
4203     if (doeval(gimme, runcv, seq, saved_hh)) {
4204         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4205             ? (PERLDB_LINE || PERLDB_SAVESRC)
4206             :  PERLDB_SAVESRC_NOSUBS) {
4207             /* Retain the filegv we created.  */
4208         } else if (!saved_delete) {
4209             char *const safestr = savepvn(tmpbuf, len);
4210             SAVEDELETE(PL_defstash, safestr, len);
4211         }
4212         return DOCATCH(PL_eval_start);
4213     } else {
4214         /* We have already left the scope set up earlier thanks to the LEAVE
4215            in doeval().  */
4216         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4217             ? (PERLDB_LINE || PERLDB_SAVESRC)
4218             :  PERLDB_SAVESRC_INVALID) {
4219             /* Retain the filegv we created.  */
4220         } else if (!saved_delete) {
4221             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4222         }
4223         return PL_op->op_next;
4224     }
4225 }
4226
4227 PP(pp_leaveeval)
4228 {
4229     dSP;
4230     SV **newsp;
4231     PMOP *newpm;
4232     I32 gimme;
4233     PERL_CONTEXT *cx;
4234     OP *retop;
4235     I32 optype;
4236     SV *namesv;
4237     CV *evalcv;
4238     /* grab this value before POPEVAL restores old PL_in_eval */
4239     bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4240
4241     PERL_ASYNC_CHECK();
4242     POPBLOCK(cx,newpm);
4243     POPEVAL(cx);
4244     namesv = cx->blk_eval.old_namesv;
4245     retop = cx->blk_eval.retop;
4246     evalcv = cx->blk_eval.cv;
4247
4248     SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
4249                                 gimme, SVs_TEMP, FALSE);
4250     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4251
4252 #ifdef DEBUGGING
4253     assert(CvDEPTH(evalcv) == 1);
4254 #endif
4255     CvDEPTH(evalcv) = 0;
4256
4257     if (optype == OP_REQUIRE &&
4258         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4259     {
4260         /* Unassume the success we assumed earlier. */
4261         (void)hv_delete(GvHVn(PL_incgv),
4262                         SvPVX_const(namesv),
4263                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4264                         G_DISCARD);
4265         Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4266         NOT_REACHED; /* NOTREACHED */
4267         /* die_unwind() did LEAVE, or we won't be here */
4268     }
4269     else {
4270         LEAVE_with_name("eval");
4271         if (!keep)
4272             CLEAR_ERRSV();
4273     }
4274
4275     RETURNOP(retop);
4276 }
4277
4278 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4279    close to the related Perl_create_eval_scope.  */
4280 void
4281 Perl_delete_eval_scope(pTHX)
4282 {
4283     SV **newsp;
4284     PMOP *newpm;
4285     I32 gimme;
4286     PERL_CONTEXT *cx;
4287     I32 optype;
4288         
4289     POPBLOCK(cx,newpm);
4290     POPEVAL(cx);
4291     PL_curpm = newpm;
4292     LEAVE_with_name("eval_scope");
4293     PERL_UNUSED_VAR(newsp);
4294     PERL_UNUSED_VAR(gimme);
4295     PERL_UNUSED_VAR(optype);
4296 }
4297
4298 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4299    also needed by Perl_fold_constants.  */
4300 PERL_CONTEXT *
4301 Perl_create_eval_scope(pTHX_ U32 flags)
4302 {
4303     PERL_CONTEXT *cx;
4304     const I32 gimme = GIMME_V;
4305         
4306     ENTER_with_name("eval_scope");
4307     SAVETMPS;
4308
4309     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4310     PUSHEVAL(cx, 0);
4311
4312     PL_in_eval = EVAL_INEVAL;
4313     if (flags & G_KEEPERR)
4314         PL_in_eval |= EVAL_KEEPERR;
4315     else
4316         CLEAR_ERRSV();
4317     if (flags & G_FAKINGEVAL) {
4318         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4319     }
4320     return cx;
4321 }
4322     
4323 PP(pp_entertry)
4324 {
4325     PERL_CONTEXT * const cx = create_eval_scope(0);
4326     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4327     return DOCATCH(PL_op->op_next);
4328 }
4329
4330 PP(pp_leavetry)
4331 {
4332     dSP;
4333     SV **newsp;
4334     PMOP *newpm;
4335     I32 gimme;
4336     PERL_CONTEXT *cx;
4337     I32 optype;
4338     OP *retop;
4339
4340     PERL_ASYNC_CHECK();
4341     POPBLOCK(cx,newpm);
4342     retop = cx->blk_eval.retop;
4343     POPEVAL(cx);
4344     PERL_UNUSED_VAR(optype);
4345
4346     SP = leave_common(newsp, SP, newsp, gimme,
4347                                SVs_PADTMP|SVs_TEMP, FALSE);
4348     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4349
4350     LEAVE_with_name("eval_scope");
4351     CLEAR_ERRSV();
4352     RETURNOP(retop);
4353 }
4354
4355 PP(pp_entergiven)
4356 {
4357     dSP;
4358     PERL_CONTEXT *cx;
4359     const I32 gimme = GIMME_V;
4360     
4361     ENTER_with_name("given");
4362     SAVETMPS;
4363
4364     if (PL_op->op_targ) {
4365         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4366         SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4367         PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4368     }
4369     else {
4370         SAVE_DEFSV;
4371         DEFSV_set(POPs);
4372     }
4373
4374     PUSHBLOCK(cx, CXt_GIVEN, SP);
4375     PUSHGIVEN(cx);
4376
4377     RETURN;
4378 }
4379
4380 PP(pp_leavegiven)
4381 {
4382     dSP;
4383     PERL_CONTEXT *cx;
4384     I32 gimme;
4385     SV **newsp;
4386     PMOP *newpm;
4387     PERL_UNUSED_CONTEXT;
4388
4389     POPBLOCK(cx,newpm);
4390     assert(CxTYPE(cx) == CXt_GIVEN);
4391
4392     SP = leave_common(newsp, SP, newsp, gimme,
4393                                SVs_PADTMP|SVs_TEMP, FALSE);
4394     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4395
4396     LEAVE_with_name("given");
4397     RETURN;
4398 }
4399
4400 /* Helper routines used by pp_smartmatch */
4401 STATIC PMOP *
4402 S_make_matcher(pTHX_ REGEXP *re)
4403 {
4404     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4405
4406     PERL_ARGS_ASSERT_MAKE_MATCHER;
4407
4408     PM_SETRE(matcher, ReREFCNT_inc(re));
4409
4410     SAVEFREEOP((OP *) matcher);
4411     ENTER_with_name("matcher"); SAVETMPS;
4412     SAVEOP();
4413     return matcher;
4414 }
4415
4416 STATIC bool
4417 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4418 {
4419     dSP;
4420     bool result;
4421
4422     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4423     
4424     PL_op = (OP *) matcher;
4425     XPUSHs(sv);
4426     PUTBACK;
4427     (void) Perl_pp_match(aTHX);
4428     SPAGAIN;
4429     result = SvTRUEx(POPs);
4430     PUTBACK;
4431
4432     return result;
4433 }
4434
4435 STATIC void
4436 S_destroy_matcher(pTHX_ PMOP *matcher)
4437 {
4438     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4439     PERL_UNUSED_ARG(matcher);
4440
4441     FREETMPS;
4442     LEAVE_with_name("matcher");
4443 }
4444
4445 /* Do a smart match */
4446 PP(pp_smartmatch)
4447 {
4448     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4449     return do_smartmatch(NULL, NULL, 0);
4450 }
4451
4452 /* This version of do_smartmatch() implements the
4453  * table of smart matches that is found in perlsyn.
4454  */
4455 STATIC OP *
4456 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4457 {
4458     dSP;
4459     
4460     bool object_on_left = FALSE;
4461     SV *e = TOPs;       /* e is for 'expression' */
4462     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4463
4464     /* Take care only to invoke mg_get() once for each argument.
4465      * Currently we do this by copying the SV if it's magical. */
4466     if (d) {
4467         if (!copied && SvGMAGICAL(d))
4468             d = sv_mortalcopy(d);
4469     }
4470     else
4471         d = &PL_sv_undef;
4472
4473     assert(e);
4474     if (SvGMAGICAL(e))
4475         e = sv_mortalcopy(e);
4476
4477     /* First of all, handle overload magic of the rightmost argument */
4478     if (SvAMAGIC(e)) {
4479         SV * tmpsv;
4480         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4481         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4482
4483         tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4484         if (tmpsv) {
4485             SPAGAIN;
4486             (void)POPs;
4487             SETs(tmpsv);
4488             RETURN;
4489         }
4490         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4491     }
4492
4493     SP -= 2;    /* Pop the values */
4494     PUTBACK;
4495
4496     /* ~~ undef */
4497     if (!SvOK(e)) {
4498         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4499         if (SvOK(d))
4500             RETPUSHNO;
4501       &n