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