Update Module-Load-Conditional to CPAN version 0.66
[perl.git] / pp_ctl.c
1 /*    pp_ctl.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *      Now far ahead the Road has gone,
13  *          And I must follow, if I can,
14  *      Pursuing it with eager feet,
15  *          Until it joins some larger way
16  *      Where many paths and errands meet.
17  *          And whither then?  I cannot say.
18  *
19  *     [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
20  */
21
22 /* This file contains control-oriented pp ("push/pop") functions that
23  * execute the opcodes that make up a perl program. A typical pp function
24  * expects to find its arguments on the stack, and usually pushes its
25  * results onto the stack, hence the 'pp' terminology. Each OP structure
26  * contains a pointer to the relevant pp_foo() function.
27  *
28  * Control-oriented means things like pp_enteriter() and pp_next(), which
29  * alter the flow of control of the program.
30  */
31
32
33 #include "EXTERN.h"
34 #define PERL_IN_PP_CTL_C
35 #include "perl.h"
36
37 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
38
39 #define dopoptosub(plop)        dopoptosub_at(cxstack, (plop))
40
41 PP(pp_wantarray)
42 {
43     dSP;
44     I32 cxix;
45     const PERL_CONTEXT *cx;
46     EXTEND(SP, 1);
47
48     if (PL_op->op_private & OPpOFFBYONE) {
49         if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
50     }
51     else {
52       cxix = dopoptosub(cxstack_ix);
53       if (cxix < 0)
54         RETPUSHUNDEF;
55       cx = &cxstack[cxix];
56     }
57
58     switch (cx->blk_gimme) {
59     case G_ARRAY:
60         RETPUSHYES;
61     case G_SCALAR:
62         RETPUSHNO;
63     default:
64         RETPUSHUNDEF;
65     }
66 }
67
68 PP(pp_regcreset)
69 {
70     TAINT_NOT;
71     return NORMAL;
72 }
73
74 PP(pp_regcomp)
75 {
76     dSP;
77     PMOP *pm = (PMOP*)cLOGOP->op_other;
78     SV **args;
79     int nargs;
80     REGEXP *re = NULL;
81     REGEXP *new_re;
82     const regexp_engine *eng;
83     bool is_bare_re= FALSE;
84
85     if (PL_op->op_flags & OPf_STACKED) {
86         dMARK;
87         nargs = SP - MARK;
88         args  = ++MARK;
89     }
90     else {
91         nargs = 1;
92         args  = SP;
93     }
94
95     /* prevent recompiling under /o and ithreads. */
96 #if defined(USE_ITHREADS)
97     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
98         SP = args-1;
99         RETURN;
100     }
101 #endif
102
103     re = PM_GETRE(pm);
104     assert (re != (REGEXP*) &PL_sv_undef);
105     eng = re ? RX_ENGINE(re) : current_re_engine();
106
107     /*
108      In the below logic: these are basically the same - check if this regcomp is part of a split.
109
110     (PL_op->op_pmflags & PMf_split )
111     (PL_op->op_next->op_type == OP_PUSHRE)
112
113     We could add a new mask for this and copy the PMf_split, if we did
114     some bit definition fiddling first.
115
116     For now we leave this
117     */
118
119     new_re = (eng->op_comp
120                     ? eng->op_comp
121                     : &Perl_re_op_compile
122             )(aTHX_ args, nargs, pm->op_code_list, eng, re,
123                 &is_bare_re,
124                 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
125                 pm->op_pmflags |
126                     (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
127
128     if (pm->op_pmflags & PMf_HAS_CV)
129         ReANY(new_re)->qr_anoncv
130                         = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
131
132     if (is_bare_re) {
133         REGEXP *tmp;
134         /* The match's LHS's get-magic might need to access this op's regexp
135            (e.g. $' =~ /$re/ while foo; see bug 70764).  So we must call
136            get-magic now before we replace the regexp. Hopefully this hack can
137            be replaced with the approach described at
138            http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
139            some day. */
140         if (pm->op_type == OP_MATCH) {
141             SV *lhs;
142             const bool was_tainted = TAINT_get;
143             if (pm->op_flags & OPf_STACKED)
144                 lhs = args[-1];
145             else if (pm->op_targ)
146                 lhs = PAD_SV(pm->op_targ);
147             else lhs = DEFSV;
148             SvGETMAGIC(lhs);
149             /* Restore the previous value of PL_tainted (which may have been
150                modified by get-magic), to avoid incorrectly setting the
151                RXf_TAINTED flag with RX_TAINT_on further down. */
152             TAINT_set(was_tainted);
153 #ifdef NO_TAINT_SUPPORT
154             PERL_UNUSED_VAR(was_tainted);
155 #endif
156         }
157         tmp = reg_temp_copy(NULL, new_re);
158         ReREFCNT_dec(new_re);
159         new_re = tmp;
160     }
161
162     if (re != new_re) {
163         ReREFCNT_dec(re);
164         PM_SETRE(pm, new_re);
165     }
166
167
168     assert(TAINTING_get || !TAINT_get);
169     if (TAINT_get) {
170         SvTAINTED_on((SV*)new_re);
171         RX_TAINT_on(new_re);
172     }
173
174 #if !defined(USE_ITHREADS)
175     /* can't change the optree at runtime either */
176     /* PMf_KEEP is handled differently under threads to avoid these problems */
177     if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
178         pm = PL_curpm;
179     if (pm->op_pmflags & PMf_KEEP) {
180         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
181         cLOGOP->op_first->op_next = PL_op->op_next;
182     }
183 #endif
184
185     SP = args-1;
186     RETURN;
187 }
188
189
190 PP(pp_substcont)
191 {
192     dSP;
193     PERL_CONTEXT *cx = CX_CUR();
194     PMOP * const pm = (PMOP*) cLOGOP->op_other;
195     SV * const dstr = cx->sb_dstr;
196     char *s = cx->sb_s;
197     char *m = cx->sb_m;
198     char *orig = cx->sb_orig;
199     REGEXP * const rx = cx->sb_rx;
200     SV *nsv = NULL;
201     REGEXP *old = PM_GETRE(pm);
202
203     PERL_ASYNC_CHECK();
204
205     if(old != rx) {
206         if(old)
207             ReREFCNT_dec(old);
208         PM_SETRE(pm,ReREFCNT_inc(rx));
209     }
210
211     rxres_restore(&cx->sb_rxres, rx);
212
213     if (cx->sb_iters++) {
214         const SSize_t saviters = cx->sb_iters;
215         if (cx->sb_iters > cx->sb_maxiters)
216             DIE(aTHX_ "Substitution loop");
217
218         SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
219
220         /* See "how taint works" above pp_subst() */
221         if (SvTAINTED(TOPs))
222             cx->sb_rxtainted |= SUBST_TAINT_REPL;
223         sv_catsv_nomg(dstr, POPs);
224         if (CxONCE(cx) || s < orig ||
225                 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
226                              (s == m), cx->sb_targ, NULL,
227                     (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
228         {
229             SV *targ = cx->sb_targ;
230
231             assert(cx->sb_strend >= s);
232             if(cx->sb_strend > s) {
233                  if (DO_UTF8(dstr) && !SvUTF8(targ))
234                       sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
235                  else
236                       sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
237             }
238             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
239                 cx->sb_rxtainted |= SUBST_TAINT_PAT;
240
241             if (pm->op_pmflags & PMf_NONDESTRUCT) {
242                 PUSHs(dstr);
243                 /* From here on down we're using the copy, and leaving the
244                    original untouched.  */
245                 targ = dstr;
246             }
247             else {
248                 SV_CHECK_THINKFIRST_COW_DROP(targ);
249                 if (isGV(targ)) Perl_croak_no_modify();
250                 SvPV_free(targ);
251                 SvPV_set(targ, SvPVX(dstr));
252                 SvCUR_set(targ, SvCUR(dstr));
253                 SvLEN_set(targ, SvLEN(dstr));
254                 if (DO_UTF8(dstr))
255                     SvUTF8_on(targ);
256                 SvPV_set(dstr, NULL);
257
258                 PL_tainted = 0;
259                 mPUSHi(saviters - 1);
260
261                 (void)SvPOK_only_UTF8(targ);
262             }
263
264             /* update the taint state of various various variables in
265              * preparation for final exit.
266              * See "how taint works" above pp_subst() */
267             if (TAINTING_get) {
268                 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
269                     ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
270                                     == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
271                 )
272                     (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
273
274                 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
275                     && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
276                 )
277                     SvTAINTED_on(TOPs);  /* taint return value */
278                 /* needed for mg_set below */
279                 TAINT_set(
280                     cBOOL(cx->sb_rxtainted &
281                           (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
282                 );
283                 SvTAINT(TARG);
284             }
285             /* PL_tainted must be correctly set for this mg_set */
286             SvSETMAGIC(TARG);
287             TAINT_NOT;
288
289             CX_LEAVE_SCOPE(cx);
290             CX_POPSUBST(cx);
291             CX_POP(cx);
292
293             PERL_ASYNC_CHECK();
294             RETURNOP(pm->op_next);
295             NOT_REACHED; /* 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
320         /* the string being matched against may no longer be a string,
321          * e.g. $_=0; s/.../$_++/ge */
322
323         if (!SvPOK(sv))
324             SvPV_force_nomg_nolen(sv);
325
326         if (!(mg = mg_find_mglob(sv))) {
327             mg = sv_magicext_mglob(sv);
328         }
329         MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
330     }
331     if (old != rx)
332         (void)ReREFCNT_inc(rx);
333     /* update the taint state of various various variables in preparation
334      * for calling the code block.
335      * See "how taint works" above pp_subst() */
336     if (TAINTING_get) {
337         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
338             cx->sb_rxtainted |= SUBST_TAINT_PAT;
339
340         if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
341             ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
342                             == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
343         )
344             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
345
346         if (cx->sb_iters > 1 && (cx->sb_rxtainted & 
347                         (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
348             SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
349                          ? cx->sb_dstr : cx->sb_targ);
350         TAINT_NOT;
351     }
352     rxres_save(&cx->sb_rxres, rx);
353     PL_curpm = pm;
354     RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
355 }
356
357 void
358 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
359 {
360     UV *p = (UV*)*rsp;
361     U32 i;
362
363     PERL_ARGS_ASSERT_RXRES_SAVE;
364     PERL_UNUSED_CONTEXT;
365
366     if (!p || p[1] < RX_NPARENS(rx)) {
367 #ifdef PERL_ANY_COW
368         i = 7 + (RX_NPARENS(rx)+1) * 2;
369 #else
370         i = 6 + (RX_NPARENS(rx)+1) * 2;
371 #endif
372         if (!p)
373             Newx(p, i, UV);
374         else
375             Renew(p, i, UV);
376         *rsp = (void*)p;
377     }
378
379     /* what (if anything) to free on croak */
380     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
381     RX_MATCH_COPIED_off(rx);
382     *p++ = RX_NPARENS(rx);
383
384 #ifdef PERL_ANY_COW
385     *p++ = PTR2UV(RX_SAVED_COPY(rx));
386     RX_SAVED_COPY(rx) = NULL;
387 #endif
388
389     *p++ = PTR2UV(RX_SUBBEG(rx));
390     *p++ = (UV)RX_SUBLEN(rx);
391     *p++ = (UV)RX_SUBOFFSET(rx);
392     *p++ = (UV)RX_SUBCOFFSET(rx);
393     for (i = 0; i <= RX_NPARENS(rx); ++i) {
394         *p++ = (UV)RX_OFFS(rx)[i].start;
395         *p++ = (UV)RX_OFFS(rx)[i].end;
396     }
397 }
398
399 static void
400 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
401 {
402     UV *p = (UV*)*rsp;
403     U32 i;
404
405     PERL_ARGS_ASSERT_RXRES_RESTORE;
406     PERL_UNUSED_CONTEXT;
407
408     RX_MATCH_COPY_FREE(rx);
409     RX_MATCH_COPIED_set(rx, *p);
410     *p++ = 0;
411     RX_NPARENS(rx) = *p++;
412
413 #ifdef PERL_ANY_COW
414     if (RX_SAVED_COPY(rx))
415         SvREFCNT_dec (RX_SAVED_COPY(rx));
416     RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
417     *p++ = 0;
418 #endif
419
420     RX_SUBBEG(rx) = INT2PTR(char*,*p++);
421     RX_SUBLEN(rx) = (I32)(*p++);
422     RX_SUBOFFSET(rx) = (I32)*p++;
423     RX_SUBCOFFSET(rx) = (I32)*p++;
424     for (i = 0; i <= RX_NPARENS(rx); ++i) {
425         RX_OFFS(rx)[i].start = (I32)(*p++);
426         RX_OFFS(rx)[i].end = (I32)(*p++);
427     }
428 }
429
430 static void
431 S_rxres_free(pTHX_ void **rsp)
432 {
433     UV * const p = (UV*)*rsp;
434
435     PERL_ARGS_ASSERT_RXRES_FREE;
436     PERL_UNUSED_CONTEXT;
437
438     if (p) {
439         void *tmp = INT2PTR(char*,*p);
440 #ifdef PERL_POISON
441 #ifdef PERL_ANY_COW
442         U32 i = 9 + p[1] * 2;
443 #else
444         U32 i = 8 + p[1] * 2;
445 #endif
446 #endif
447
448 #ifdef PERL_ANY_COW
449         SvREFCNT_dec (INT2PTR(SV*,p[2]));
450 #endif
451 #ifdef PERL_POISON
452         PoisonFree(p, i, sizeof(UV));
453 #endif
454
455         Safefree(tmp);
456         Safefree(p);
457         *rsp = NULL;
458     }
459 }
460
461 #define FORM_NUM_BLANK (1<<30)
462 #define FORM_NUM_POINT (1<<29)
463
464 PP(pp_formline)
465 {
466     dSP; dMARK; dORIGMARK;
467     SV * const tmpForm = *++MARK;
468     SV *formsv;             /* contains text of original format */
469     U32 *fpc;       /* format ops program counter */
470     char *t;        /* current append position in target string */
471     const char *f;          /* current position in format string */
472     I32 arg;
473     SV *sv = NULL; /* current item */
474     const char *item = NULL;/* string value of current item */
475     I32 itemsize  = 0;      /* length (chars) of item, possibly truncated */
476     I32 itembytes = 0;      /* as itemsize, but length in bytes */
477     I32 fieldsize = 0;      /* width of current field */
478     I32 lines = 0;          /* number of lines that have been output */
479     bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
480     const char *chophere = NULL; /* where to chop current item */
481     STRLEN linemark = 0;    /* pos of start of line in output */
482     NV value;
483     bool gotsome = FALSE;   /* seen at least one non-blank item on this line */
484     STRLEN len;             /* length of current sv */
485     STRLEN linemax;         /* estimate of output size in bytes */
486     bool item_is_utf8 = FALSE;
487     bool targ_is_utf8 = FALSE;
488     const char *fmt;
489     MAGIC *mg = NULL;
490     U8 *source;             /* source of bytes to append */
491     STRLEN to_copy;         /* how may bytes to append */
492     char trans;             /* what chars to translate */
493
494     mg = doparseform(tmpForm);
495
496     fpc = (U32*)mg->mg_ptr;
497     /* the actual string the format was compiled from.
498      * with overload etc, this may not match tmpForm */
499     formsv = mg->mg_obj;
500
501
502     SvPV_force(PL_formtarget, len);
503     if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
504         SvTAINTED_on(PL_formtarget);
505     if (DO_UTF8(PL_formtarget))
506         targ_is_utf8 = TRUE;
507     linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
508     t = SvGROW(PL_formtarget, len + linemax + 1);
509     /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
510     t += len;
511     f = SvPV_const(formsv, len);
512
513     for (;;) {
514         DEBUG_f( {
515             const char *name = "???";
516             arg = -1;
517             switch (*fpc) {
518             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
519             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
520             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
521             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
522             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
523
524             case FF_CHECKNL:    name = "CHECKNL";       break;
525             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
526             case FF_SPACE:      name = "SPACE";         break;
527             case FF_HALFSPACE:  name = "HALFSPACE";     break;
528             case FF_ITEM:       name = "ITEM";          break;
529             case FF_CHOP:       name = "CHOP";          break;
530             case FF_LINEGLOB:   name = "LINEGLOB";      break;
531             case FF_NEWLINE:    name = "NEWLINE";       break;
532             case FF_MORE:       name = "MORE";          break;
533             case FF_LINEMARK:   name = "LINEMARK";      break;
534             case FF_END:        name = "END";           break;
535             case FF_0DECIMAL:   name = "0DECIMAL";      break;
536             case FF_LINESNGL:   name = "LINESNGL";      break;
537             }
538             if (arg >= 0)
539                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
540             else
541                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
542         } );
543         switch (*fpc++) {
544         case FF_LINEMARK: /* start (or end) of a line */
545             linemark = t - SvPVX(PL_formtarget);
546             lines++;
547             gotsome = FALSE;
548             break;
549
550         case FF_LITERAL: /* append <arg> literal chars */
551             to_copy = *fpc++;
552             source = (U8 *)f;
553             f += to_copy;
554             trans = '~';
555             item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
556             goto append;
557
558         case FF_SKIP: /* skip <arg> chars in format */
559             f += *fpc++;
560             break;
561
562         case FF_FETCH: /* get next item and set field size to <arg> */
563             arg = *fpc++;
564             f += arg;
565             fieldsize = arg;
566
567             if (MARK < SP)
568                 sv = *++MARK;
569             else {
570                 sv = &PL_sv_no;
571                 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
572             }
573             if (SvTAINTED(sv))
574                 SvTAINTED_on(PL_formtarget);
575             break;
576
577         case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
578             {
579                 const char *s = item = SvPV_const(sv, len);
580                 const char *send = s + len;
581
582                 itemsize = 0;
583                 item_is_utf8 = DO_UTF8(sv);
584                 while (s < send) {
585                     if (!isCNTRL(*s))
586                         gotsome = TRUE;
587                     else if (*s == '\n')
588                         break;
589
590                     if (item_is_utf8)
591                         s += UTF8SKIP(s);
592                     else
593                         s++;
594                     itemsize++;
595                     if (itemsize == fieldsize)
596                         break;
597                 }
598                 itembytes = s - item;
599                 chophere = s;
600                 break;
601             }
602
603         case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
604             {
605                 const char *s = item = SvPV_const(sv, len);
606                 const char *send = s + len;
607                 I32 size = 0;
608
609                 chophere = NULL;
610                 item_is_utf8 = DO_UTF8(sv);
611                 while (s < send) {
612                     /* look for a legal split position */
613                     if (isSPACE(*s)) {
614                         if (*s == '\r') {
615                             chophere = s;
616                             itemsize = size;
617                             break;
618                         }
619                         if (chopspace) {
620                             /* provisional split point */
621                             chophere = s;
622                             itemsize = size;
623                         }
624                         /* we delay testing fieldsize until after we've
625                          * processed the possible split char directly
626                          * following the last field char; so if fieldsize=3
627                          * and item="a b cdef", we consume "a b", not "a".
628                          * Ditto further down.
629                          */
630                         if (size == fieldsize)
631                             break;
632                     }
633                     else {
634                         if (strchr(PL_chopset, *s)) {
635                             /* provisional split point */
636                             /* for a non-space split char, we include
637                              * the split char; hence the '+1' */
638                             chophere = s + 1;
639                             itemsize = size;
640                         }
641                         if (size == fieldsize)
642                             break;
643                         if (!isCNTRL(*s))
644                             gotsome = TRUE;
645                     }
646
647                     if (item_is_utf8)
648                         s += UTF8SKIP(s);
649                     else
650                         s++;
651                     size++;
652                 }
653                 if (!chophere || s == send) {
654                     chophere = s;
655                     itemsize = size;
656                 }
657                 itembytes = chophere - item;
658
659                 break;
660             }
661
662         case FF_SPACE: /* append padding space (diff of field, item size) */
663             arg = fieldsize - itemsize;
664             if (arg) {
665                 fieldsize -= arg;
666                 while (arg-- > 0)
667                     *t++ = ' ';
668             }
669             break;
670
671         case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
672             arg = fieldsize - itemsize;
673             if (arg) {
674                 arg /= 2;
675                 fieldsize -= arg;
676                 while (arg-- > 0)
677                     *t++ = ' ';
678             }
679             break;
680
681         case FF_ITEM: /* append a text item, while blanking ctrl chars */
682             to_copy = itembytes;
683             source = (U8 *)item;
684             trans = 1;
685             goto append;
686
687         case FF_CHOP: /* (for ^*) chop the current item */
688             if (sv != &PL_sv_no) {
689                 const char *s = chophere;
690                 if (chopspace) {
691                     while (isSPACE(*s))
692                         s++;
693                 }
694                 if (SvPOKp(sv))
695                     sv_chop(sv,s);
696                 else
697                     /* tied, overloaded or similar strangeness.
698                      * Do it the hard way */
699                     sv_setpvn(sv, s, len - (s-item));
700                 SvSETMAGIC(sv);
701                 break;
702             }
703
704         case FF_LINESNGL: /* process ^*  */
705             chopspace = 0;
706             /* FALLTHROUGH */
707
708         case FF_LINEGLOB: /* process @*  */
709             {
710                 const bool oneline = fpc[-1] == FF_LINESNGL;
711                 const char *s = item = SvPV_const(sv, len);
712                 const char *const send = s + len;
713
714                 item_is_utf8 = DO_UTF8(sv);
715                 chophere = s + len;
716                 if (!len)
717                     break;
718                 trans = 0;
719                 gotsome = TRUE;
720                 source = (U8 *) s;
721                 to_copy = len;
722                 while (s < send) {
723                     if (*s++ == '\n') {
724                         if (oneline) {
725                             to_copy = s - item - 1;
726                             chophere = s;
727                             break;
728                         } else {
729                             if (s == send) {
730                                 to_copy--;
731                             } else
732                                 lines++;
733                         }
734                     }
735                 }
736             }
737
738         append:
739             /* append to_copy bytes from source to PL_formstring.
740              * item_is_utf8 implies source is utf8.
741              * if trans, translate certain characters during the copy */
742             {
743                 U8 *tmp = NULL;
744                 STRLEN grow = 0;
745
746                 SvCUR_set(PL_formtarget,
747                           t - SvPVX_const(PL_formtarget));
748
749                 if (targ_is_utf8 && !item_is_utf8) {
750                     source = tmp = bytes_to_utf8(source, &to_copy);
751                 } else {
752                     if (item_is_utf8 && !targ_is_utf8) {
753                         U8 *s;
754                         /* Upgrade targ to UTF8, and then we reduce it to
755                            a problem we have a simple solution for.
756                            Don't need get magic.  */
757                         sv_utf8_upgrade_nomg(PL_formtarget);
758                         targ_is_utf8 = TRUE;
759                         /* re-calculate linemark */
760                         s = (U8*)SvPVX(PL_formtarget);
761                         /* the bytes we initially allocated to append the
762                          * whole line may have been gobbled up during the
763                          * upgrade, so allocate a whole new line's worth
764                          * for safety */
765                         grow = linemax;
766                         while (linemark--)
767                             s += UTF8SKIP(s);
768                         linemark = s - (U8*)SvPVX(PL_formtarget);
769                     }
770                     /* Easy. They agree.  */
771                     assert (item_is_utf8 == targ_is_utf8);
772                 }
773                 if (!trans)
774                     /* @* and ^* are the only things that can exceed
775                      * the linemax, so grow by the output size, plus
776                      * a whole new form's worth in case of any further
777                      * output */
778                     grow = linemax + to_copy;
779                 if (grow)
780                     SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
781                 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
782
783                 Copy(source, t, to_copy, char);
784                 if (trans) {
785                     /* blank out ~ or control chars, depending on trans.
786                      * works on bytes not chars, so relies on not
787                      * matching utf8 continuation bytes */
788                     U8 *s = (U8*)t;
789                     U8 *send = s + to_copy;
790                     while (s < send) {
791                         const int ch = *s;
792                         if (trans == '~' ? (ch == '~') : isCNTRL(ch))
793                             *s = ' ';
794                         s++;
795                     }
796                 }
797
798                 t += to_copy;
799                 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
800                 if (tmp)
801                     Safefree(tmp);
802                 break;
803             }
804
805         case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
806             arg = *fpc++;
807             fmt = (const char *)
808                 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
809             goto ff_dec;
810
811         case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
812             arg = *fpc++;
813             fmt = (const char *)
814                 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
815         ff_dec:
816             /* If the field is marked with ^ and the value is undefined,
817                blank it out. */
818             if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
819                 arg = fieldsize;
820                 while (arg--)
821                     *t++ = ' ';
822                 break;
823             }
824             gotsome = TRUE;
825             value = SvNV(sv);
826             /* overflow evidence */
827             if (num_overflow(value, fieldsize, arg)) {
828                 arg = fieldsize;
829                 while (arg--)
830                     *t++ = '#';
831                 break;
832             }
833             /* Formats aren't yet marked for locales, so assume "yes". */
834             {
835                 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
836                 int len;
837                 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
838                 STORE_LC_NUMERIC_SET_TO_NEEDED();
839                 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
840 #ifdef USE_QUADMATH
841                 {
842                     const char* qfmt = quadmath_format_single(fmt);
843                     int len;
844                     if (!qfmt)
845                         Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
846                     len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
847                     if (len == -1)
848                         Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
849                     if (qfmt != fmt)
850                         Safefree(fmt);
851                 }
852 #else
853                 /* we generate fmt ourselves so it is safe */
854                 GCC_DIAG_IGNORE(-Wformat-nonliteral);
855                 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
856                 GCC_DIAG_RESTORE;
857 #endif
858                 PERL_MY_SNPRINTF_POST_GUARD(len, max);
859                 RESTORE_LC_NUMERIC();
860             }
861             t += fieldsize;
862             break;
863
864         case FF_NEWLINE: /* delete trailing spaces, then append \n */
865             f++;
866             while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
867             t++;
868             *t++ = '\n';
869             break;
870
871         case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
872             arg = *fpc++;
873             if (gotsome) {
874                 if (arg) {              /* repeat until fields exhausted? */
875                     fpc--;
876                     goto end;
877                 }
878             }
879             else {
880                 t = SvPVX(PL_formtarget) + linemark;
881                 lines--;
882             }
883             break;
884
885         case FF_MORE: /* replace long end of string with '...' */
886             {
887                 const char *s = chophere;
888                 const char *send = item + len;
889                 if (chopspace) {
890                     while (isSPACE(*s) && (s < send))
891                         s++;
892                 }
893                 if (s < send) {
894                     char *s1;
895                     arg = fieldsize - itemsize;
896                     if (arg) {
897                         fieldsize -= arg;
898                         while (arg-- > 0)
899                             *t++ = ' ';
900                     }
901                     s1 = t - 3;
902                     if (strnEQ(s1,"   ",3)) {
903                         while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
904                             s1--;
905                     }
906                     *s1++ = '.';
907                     *s1++ = '.';
908                     *s1++ = '.';
909                 }
910                 break;
911             }
912
913         case FF_END: /* tidy up, then return */
914         end:
915             assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
916             *t = '\0';
917             SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
918             if (targ_is_utf8)
919                 SvUTF8_on(PL_formtarget);
920             FmLINES(PL_formtarget) += lines;
921             SP = ORIGMARK;
922             if (fpc[-1] == FF_BLANK)
923                 RETURNOP(cLISTOP->op_first);
924             else
925                 RETPUSHYES;
926         }
927     }
928 }
929
930 PP(pp_grepstart)
931 {
932     dSP;
933     SV *src;
934
935     if (PL_stack_base + TOPMARK == SP) {
936         (void)POPMARK;
937         if (GIMME_V == G_SCALAR)
938             mXPUSHi(0);
939         RETURNOP(PL_op->op_next->op_next);
940     }
941     PL_stack_sp = PL_stack_base + TOPMARK + 1;
942     Perl_pp_pushmark(aTHX);                             /* push dst */
943     Perl_pp_pushmark(aTHX);                             /* push src */
944     ENTER_with_name("grep");                                    /* enter outer scope */
945
946     SAVETMPS;
947     SAVE_DEFSV;
948     ENTER_with_name("grep_item");                                       /* enter inner scope */
949     SAVEVPTR(PL_curpm);
950
951     src = PL_stack_base[TOPMARK];
952     if (SvPADTMP(src)) {
953         src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
954         PL_tmps_floor++;
955     }
956     SvTEMP_off(src);
957     DEFSV_set(src);
958
959     PUTBACK;
960     if (PL_op->op_type == OP_MAPSTART)
961         Perl_pp_pushmark(aTHX);                 /* push top */
962     return ((LOGOP*)PL_op->op_next)->op_other;
963 }
964
965 PP(pp_mapwhile)
966 {
967     dSP;
968     const U8 gimme = GIMME_V;
969     I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
970     I32 count;
971     I32 shift;
972     SV** src;
973     SV** dst;
974
975     /* first, move source pointer to the next item in the source list */
976     ++PL_markstack_ptr[-1];
977
978     /* if there are new items, push them into the destination list */
979     if (items && gimme != G_VOID) {
980         /* might need to make room back there first */
981         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
982             /* XXX this implementation is very pessimal because the stack
983              * is repeatedly extended for every set of items.  Is possible
984              * to do this without any stack extension or copying at all
985              * by maintaining a separate list over which the map iterates
986              * (like foreach does). --gsar */
987
988             /* everything in the stack after the destination list moves
989              * towards the end the stack by the amount of room needed */
990             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
991
992             /* items to shift up (accounting for the moved source pointer) */
993             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
994
995             /* This optimization is by Ben Tilly and it does
996              * things differently from what Sarathy (gsar)
997              * is describing.  The downside of this optimization is
998              * that leaves "holes" (uninitialized and hopefully unused areas)
999              * to the Perl stack, but on the other hand this
1000              * shouldn't be a problem.  If Sarathy's idea gets
1001              * implemented, this optimization should become
1002              * irrelevant.  --jhi */
1003             if (shift < count)
1004                 shift = count; /* Avoid shifting too often --Ben Tilly */
1005
1006             EXTEND(SP,shift);
1007             src = SP;
1008             dst = (SP += shift);
1009             PL_markstack_ptr[-1] += shift;
1010             *PL_markstack_ptr += shift;
1011             while (count--)
1012                 *dst-- = *src--;
1013         }
1014         /* copy the new items down to the destination list */
1015         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1016         if (gimme == G_ARRAY) {
1017             /* add returned items to the collection (making mortal copies
1018              * if necessary), then clear the current temps stack frame
1019              * *except* for those items. We do this splicing the items
1020              * into the start of the tmps frame (so some items may be on
1021              * the tmps stack twice), then moving PL_tmps_floor above
1022              * them, then freeing the frame. That way, the only tmps that
1023              * accumulate over iterations are the return values for map.
1024              * We have to do to this way so that everything gets correctly
1025              * freed if we die during the map.
1026              */
1027             I32 tmpsbase;
1028             I32 i = items;
1029             /* make space for the slice */
1030             EXTEND_MORTAL(items);
1031             tmpsbase = PL_tmps_floor + 1;
1032             Move(PL_tmps_stack + tmpsbase,
1033                  PL_tmps_stack + tmpsbase + items,
1034                  PL_tmps_ix - PL_tmps_floor,
1035                  SV*);
1036             PL_tmps_ix += items;
1037
1038             while (i-- > 0) {
1039                 SV *sv = POPs;
1040                 if (!SvTEMP(sv))
1041                     sv = sv_mortalcopy(sv);
1042                 *dst-- = sv;
1043                 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1044             }
1045             /* clear the stack frame except for the items */
1046             PL_tmps_floor += items;
1047             FREETMPS;
1048             /* FREETMPS may have cleared the TEMP flag on some of the items */
1049             i = items;
1050             while (i-- > 0)
1051                 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1052         }
1053         else {
1054             /* scalar context: we don't care about which values map returns
1055              * (we use undef here). And so we certainly don't want to do mortal
1056              * copies of meaningless values. */
1057             while (items-- > 0) {
1058                 (void)POPs;
1059                 *dst-- = &PL_sv_undef;
1060             }
1061             FREETMPS;
1062         }
1063     }
1064     else {
1065         FREETMPS;
1066     }
1067     LEAVE_with_name("grep_item");                                       /* exit inner scope */
1068
1069     /* All done yet? */
1070     if (PL_markstack_ptr[-1] > TOPMARK) {
1071
1072         (void)POPMARK;                          /* pop top */
1073         LEAVE_with_name("grep");                                        /* exit outer scope */
1074         (void)POPMARK;                          /* pop src */
1075         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1076         (void)POPMARK;                          /* pop dst */
1077         SP = PL_stack_base + POPMARK;           /* pop original mark */
1078         if (gimme == G_SCALAR) {
1079                 dTARGET;
1080                 XPUSHi(items);
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             src = sv_mortalcopy(src);
1096         }
1097         SvTEMP_off(src);
1098         DEFSV_set(src);
1099
1100         RETURNOP(cLOGOP->op_other);
1101     }
1102 }
1103
1104 /* Range stuff. */
1105
1106 PP(pp_range)
1107 {
1108     if (GIMME_V == G_ARRAY)
1109         return NORMAL;
1110     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1111         return cLOGOP->op_other;
1112     else
1113         return NORMAL;
1114 }
1115
1116 PP(pp_flip)
1117 {
1118     dSP;
1119
1120     if (GIMME_V == G_ARRAY) {
1121         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1122     }
1123     else {
1124         dTOPss;
1125         SV * const targ = PAD_SV(PL_op->op_targ);
1126         int flip = 0;
1127
1128         if (PL_op->op_private & OPpFLIP_LINENUM) {
1129             if (GvIO(PL_last_in_gv)) {
1130                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1131             }
1132             else {
1133                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1134                 if (gv && GvSV(gv))
1135                     flip = SvIV(sv) == SvIV(GvSV(gv));
1136             }
1137         } else {
1138             flip = SvTRUE(sv);
1139         }
1140         if (flip) {
1141             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1142             if (PL_op->op_flags & OPf_SPECIAL) {
1143                 sv_setiv(targ, 1);
1144                 SETs(targ);
1145                 RETURN;
1146             }
1147             else {
1148                 sv_setiv(targ, 0);
1149                 SP--;
1150                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1151             }
1152         }
1153         sv_setpvs(TARG, "");
1154         SETs(targ);
1155         RETURN;
1156     }
1157 }
1158
1159 /* This code tries to decide if "$left .. $right" should use the
1160    magical string increment, or if the range is numeric (we make
1161    an exception for .."0" [#18165]). AMS 20021031. */
1162
1163 #define RANGE_IS_NUMERIC(left,right) ( \
1164         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1165         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1166         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1167           looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1168          && (!SvOK(right) || looks_like_number(right))))
1169
1170 PP(pp_flop)
1171 {
1172     dSP;
1173
1174     if (GIMME_V == G_ARRAY) {
1175         dPOPPOPssrl;
1176
1177         SvGETMAGIC(left);
1178         SvGETMAGIC(right);
1179
1180         if (RANGE_IS_NUMERIC(left,right)) {
1181             IV i, j, n;
1182             if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1183                 (SvOK(right) && (SvIOK(right)
1184                                  ? SvIsUV(right) && SvUV(right) > IV_MAX
1185                                  : SvNV_nomg(right) > IV_MAX)))
1186                 DIE(aTHX_ "Range iterator outside integer range");
1187             i = SvIV_nomg(left);
1188             j = SvIV_nomg(right);
1189             if (j >= i) {
1190                 /* Dance carefully around signed max. */
1191                 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1192                 if (!overflow) {
1193                     n = j - i + 1;
1194                     /* The wraparound of signed integers is undefined
1195                      * behavior, but here we aim for count >=1, and
1196                      * negative count is just wrong. */
1197                     if (n < 1
1198 #if IVSIZE > Size_t_size
1199                         || n > SSize_t_MAX
1200 #endif
1201                         )
1202                         overflow = TRUE;
1203                 }
1204                 if (overflow)
1205                     Perl_croak(aTHX_ "Out of memory during list extend");
1206                 EXTEND_MORTAL(n);
1207                 EXTEND(SP, n);
1208             }
1209             else
1210                 n = 0;
1211             while (n--) {
1212                 SV * const sv = sv_2mortal(newSViv(i));
1213                 PUSHs(sv);
1214                 if (n) /* avoid incrementing above IV_MAX */
1215                     i++;
1216             }
1217         }
1218         else {
1219             STRLEN len, llen;
1220             const char * const lpv = SvPV_nomg_const(left, llen);
1221             const char * const tmps = SvPV_nomg_const(right, len);
1222
1223             SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1224             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1225                 XPUSHs(sv);
1226                 if (strEQ(SvPVX_const(sv),tmps))
1227                     break;
1228                 sv = sv_2mortal(newSVsv(sv));
1229                 sv_inc(sv);
1230             }
1231         }
1232     }
1233     else {
1234         dTOPss;
1235         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1236         int flop = 0;
1237         sv_inc(targ);
1238
1239         if (PL_op->op_private & OPpFLIP_LINENUM) {
1240             if (GvIO(PL_last_in_gv)) {
1241                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1242             }
1243             else {
1244                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1245                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1246             }
1247         }
1248         else {
1249             flop = SvTRUE(sv);
1250         }
1251
1252         if (flop) {
1253             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1254             sv_catpvs(targ, "E0");
1255         }
1256         SETs(targ);
1257     }
1258
1259     RETURN;
1260 }
1261
1262 /* Control. */
1263
1264 static const char * const context_name[] = {
1265     "pseudo-block",
1266     NULL, /* CXt_WHEN never actually needs "block" */
1267     NULL, /* CXt_BLOCK never actually needs "block" */
1268     NULL, /* CXt_GIVEN never actually needs "block" */
1269     NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1270     NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1271     NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1272     NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1273     NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1274     "subroutine",
1275     "format",
1276     "eval",
1277     "substitution",
1278 };
1279
1280 STATIC I32
1281 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1282 {
1283     I32 i;
1284
1285     PERL_ARGS_ASSERT_DOPOPTOLABEL;
1286
1287     for (i = cxstack_ix; i >= 0; i--) {
1288         const PERL_CONTEXT * const cx = &cxstack[i];
1289         switch (CxTYPE(cx)) {
1290         case CXt_SUBST:
1291         case CXt_SUB:
1292         case CXt_FORMAT:
1293         case CXt_EVAL:
1294         case CXt_NULL:
1295             /* diag_listed_as: Exiting subroutine via %s */
1296             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1297                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1298             if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1299                 return -1;
1300             break;
1301         case CXt_LOOP_PLAIN:
1302         case CXt_LOOP_LAZYIV:
1303         case CXt_LOOP_LAZYSV:
1304         case CXt_LOOP_LIST:
1305         case CXt_LOOP_ARY:
1306           {
1307             STRLEN cx_label_len = 0;
1308             U32 cx_label_flags = 0;
1309             const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1310             if (!cx_label || !(
1311                     ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1312                         (flags & SVf_UTF8)
1313                             ? (bytes_cmp_utf8(
1314                                         (const U8*)cx_label, cx_label_len,
1315                                         (const U8*)label, len) == 0)
1316                             : (bytes_cmp_utf8(
1317                                         (const U8*)label, len,
1318                                         (const U8*)cx_label, cx_label_len) == 0)
1319                     : (len == cx_label_len && ((cx_label == label)
1320                                     || memEQ(cx_label, label, len))) )) {
1321                 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1322                         (long)i, cx_label));
1323                 continue;
1324             }
1325             DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1326             return i;
1327           }
1328         }
1329     }
1330     return i;
1331 }
1332
1333
1334
1335 U8
1336 Perl_dowantarray(pTHX)
1337 {
1338     const U8 gimme = block_gimme();
1339     return (gimme == G_VOID) ? G_SCALAR : gimme;
1340 }
1341
1342 U8
1343 Perl_block_gimme(pTHX)
1344 {
1345     const I32 cxix = dopoptosub(cxstack_ix);
1346     U8 gimme;
1347     if (cxix < 0)
1348         return G_VOID;
1349
1350     gimme = (cxstack[cxix].blk_gimme & G_WANT);
1351     if (!gimme)
1352         Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1353     return gimme;
1354 }
1355
1356
1357 I32
1358 Perl_is_lvalue_sub(pTHX)
1359 {
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 cx_pushsub() */
1370 I32
1371 Perl_was_lvalue_sub(pTHX)
1372 {
1373     const I32 cxix = dopoptosub(cxstack_ix-1);
1374     assert(cxix >= 0);  /* We should only be called from inside subs */
1375
1376     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1377         return CxLVAL(cxstack + cxix);
1378     else
1379         return 0;
1380 }
1381
1382 STATIC I32
1383 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1384 {
1385     I32 i;
1386
1387     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1388 #ifndef DEBUGGING
1389     PERL_UNUSED_CONTEXT;
1390 #endif
1391
1392     for (i = startingblock; i >= 0; i--) {
1393         const PERL_CONTEXT * const cx = &cxstk[i];
1394         switch (CxTYPE(cx)) {
1395         default:
1396             continue;
1397         case CXt_SUB:
1398             /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1399              * twice; the first for the normal foo() call, and the second
1400              * for a faked up re-entry into the sub to execute the
1401              * code block. Hide this faked entry from the world. */
1402             if (cx->cx_type & CXp_SUB_RE_FAKE)
1403                 continue;
1404             /* FALLTHROUGH */
1405         case CXt_EVAL:
1406         case CXt_FORMAT:
1407             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1408             return i;
1409         }
1410     }
1411     return i;
1412 }
1413
1414 STATIC I32
1415 S_dopoptoeval(pTHX_ I32 startingblock)
1416 {
1417     I32 i;
1418     for (i = startingblock; i >= 0; i--) {
1419         const PERL_CONTEXT *cx = &cxstack[i];
1420         switch (CxTYPE(cx)) {
1421         default:
1422             continue;
1423         case CXt_EVAL:
1424             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1425             return i;
1426         }
1427     }
1428     return i;
1429 }
1430
1431 STATIC I32
1432 S_dopoptoloop(pTHX_ I32 startingblock)
1433 {
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) /* sort BLOCK */
1447                 return -1;
1448             break;
1449         case CXt_LOOP_PLAIN:
1450         case CXt_LOOP_LAZYIV:
1451         case CXt_LOOP_LAZYSV:
1452         case CXt_LOOP_LIST:
1453         case CXt_LOOP_ARY:
1454             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1455             return i;
1456         }
1457     }
1458     return i;
1459 }
1460
1461 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1462
1463 STATIC I32
1464 S_dopoptogivenfor(pTHX_ I32 startingblock)
1465 {
1466     I32 i;
1467     for (i = startingblock; i >= 0; i--) {
1468         const PERL_CONTEXT *cx = &cxstack[i];
1469         switch (CxTYPE(cx)) {
1470         default:
1471             continue;
1472         case CXt_GIVEN:
1473             DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1474             return i;
1475         case CXt_LOOP_PLAIN:
1476             assert(!(cx->cx_type & CXp_FOR_DEF));
1477             break;
1478         case CXt_LOOP_LAZYIV:
1479         case CXt_LOOP_LAZYSV:
1480         case CXt_LOOP_LIST:
1481         case CXt_LOOP_ARY:
1482             if (cx->cx_type & CXp_FOR_DEF) {
1483                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1484                 return i;
1485             }
1486         }
1487     }
1488     return i;
1489 }
1490
1491 STATIC I32
1492 S_dopoptowhen(pTHX_ I32 startingblock)
1493 {
1494     I32 i;
1495     for (i = startingblock; i >= 0; i--) {
1496         const PERL_CONTEXT *cx = &cxstack[i];
1497         switch (CxTYPE(cx)) {
1498         default:
1499             continue;
1500         case CXt_WHEN:
1501             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1502             return i;
1503         }
1504     }
1505     return i;
1506 }
1507
1508 /* dounwind(): pop all contexts above (but not including) cxix.
1509  * Note that it clears the savestack frame associated with each popped
1510  * context entry, but doesn't free any temps.
1511  * It does a cx_popblock() of the last frame that it pops, and leaves
1512  * cxstack_ix equal to cxix.
1513  */
1514
1515 void
1516 Perl_dounwind(pTHX_ I32 cxix)
1517 {
1518     if (!PL_curstackinfo) /* can happen if die during thread cloning */
1519         return;
1520
1521     while (cxstack_ix > cxix) {
1522         PERL_CONTEXT *cx = CX_CUR();
1523
1524         CX_DEBUG(cx, "UNWIND");
1525         /* Note: we don't need to restore the base context info till the end. */
1526
1527         CX_LEAVE_SCOPE(cx);
1528
1529         switch (CxTYPE(cx)) {
1530         case CXt_SUBST:
1531             CX_POPSUBST(cx);
1532             break;
1533         case CXt_SUB:
1534             cx_popsub(cx);
1535             break;
1536         case CXt_EVAL:
1537             cx_popeval(cx);
1538             break;
1539         case CXt_LOOP_PLAIN:
1540         case CXt_LOOP_LAZYIV:
1541         case CXt_LOOP_LAZYSV:
1542         case CXt_LOOP_LIST:
1543         case CXt_LOOP_ARY:
1544             cx_poploop(cx);
1545             break;
1546         case CXt_WHEN:
1547             cx_popwhen(cx);
1548             break;
1549         case CXt_GIVEN:
1550             cx_popgiven(cx);
1551             break;
1552         case CXt_BLOCK:
1553         case CXt_NULL:
1554             /* these two don't have a POPFOO() */
1555             break;
1556         case CXt_FORMAT:
1557             cx_popformat(cx);
1558             break;
1559         }
1560         if (cxstack_ix == cxix + 1) {
1561             cx_popblock(cx);
1562         }
1563         cxstack_ix--;
1564     }
1565
1566 }
1567
1568 void
1569 Perl_qerror(pTHX_ SV *err)
1570 {
1571     PERL_ARGS_ASSERT_QERROR;
1572
1573     if (PL_in_eval) {
1574         if (PL_in_eval & EVAL_KEEPERR) {
1575                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1576                                                     SVfARG(err));
1577         }
1578         else
1579             sv_catsv(ERRSV, err);
1580     }
1581     else if (PL_errors)
1582         sv_catsv(PL_errors, err);
1583     else
1584         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1585     if (PL_parser)
1586         ++PL_parser->error_count;
1587 }
1588
1589
1590
1591 /* pop a CXt_EVAL context and in addition, if it was a require then
1592  * based on action:
1593  *     0: do nothing extra;
1594  *     1: undef  $INC{$name}; croak "$name did not return a true value";
1595  *     2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1596  */
1597
1598 static void
1599 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1600 {
1601     SV  *namesv = NULL; /* init to avoid dumb compiler warning */
1602     bool do_croak;
1603
1604     CX_LEAVE_SCOPE(cx);
1605     do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1606     if (do_croak) {
1607         /* keep namesv alive after cx_popeval() */
1608         namesv = cx->blk_eval.old_namesv;
1609         cx->blk_eval.old_namesv = NULL;
1610         sv_2mortal(namesv);
1611     }
1612     cx_popeval(cx);
1613     cx_popblock(cx);
1614     CX_POP(cx);
1615
1616     if (do_croak) {
1617         const char *fmt;
1618         HV *inc_hv = GvHVn(PL_incgv);
1619         I32  klen  = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv);
1620         const char *key = SvPVX_const(namesv);
1621
1622         if (action == 1) {
1623             (void)hv_delete(inc_hv, key, klen, G_DISCARD);
1624             fmt = "%"SVf" did not return a true value";
1625             errsv = namesv;
1626         }
1627         else {
1628             (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0);
1629             fmt = "%"SVf"Compilation failed in require";
1630             if (!errsv)
1631                 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1632         }
1633
1634         Perl_croak(aTHX_ fmt, SVfARG(errsv));
1635     }
1636 }
1637
1638
1639 /* die_unwind(): this is the final destination for the various croak()
1640  * functions. If we're in an eval, unwind the context and other stacks
1641  * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1642  * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1643  * to is a require the exception will be rethrown, as requires don't
1644  * actually trap exceptions.
1645  */
1646
1647 void
1648 Perl_die_unwind(pTHX_ SV *msv)
1649 {
1650     SV *exceptsv = msv;
1651     U8 in_eval = PL_in_eval;
1652     PERL_ARGS_ASSERT_DIE_UNWIND;
1653
1654     if (in_eval) {
1655         I32 cxix;
1656
1657         exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1658
1659         /*
1660          * Historically, perl used to set ERRSV ($@) early in the die
1661          * process and rely on it not getting clobbered during unwinding.
1662          * That sucked, because it was liable to get clobbered, so the
1663          * setting of ERRSV used to emit the exception from eval{} has
1664          * been moved to much later, after unwinding (see just before
1665          * JMPENV_JUMP below).  However, some modules were relying on the
1666          * early setting, by examining $@ during unwinding to use it as
1667          * a flag indicating whether the current unwinding was caused by
1668          * an exception.  It was never a reliable flag for that purpose,
1669          * being totally open to false positives even without actual
1670          * clobberage, but was useful enough for production code to
1671          * semantically rely on it.
1672          *
1673          * We'd like to have a proper introspective interface that
1674          * explicitly describes the reason for whatever unwinding
1675          * operations are currently in progress, so that those modules
1676          * work reliably and $@ isn't further overloaded.  But we don't
1677          * have one yet.  In its absence, as a stopgap measure, ERRSV is
1678          * now *additionally* set here, before unwinding, to serve as the
1679          * (unreliable) flag that it used to.
1680          *
1681          * This behaviour is temporary, and should be removed when a
1682          * proper way to detect exceptional unwinding has been developed.
1683          * As of 2010-12, the authors of modules relying on the hack
1684          * are aware of the issue, because the modules failed on
1685          * perls 5.13.{1..7} which had late setting of $@ without this
1686          * early-setting hack.
1687          */
1688         if (!(in_eval & EVAL_KEEPERR))
1689             sv_setsv_flags(ERRSV, exceptsv,
1690                         (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
1691
1692         if (in_eval & EVAL_KEEPERR) {
1693             Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1694                            SVfARG(exceptsv));
1695         }
1696
1697         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1698                && PL_curstackinfo->si_prev)
1699         {
1700             dounwind(-1);
1701             POPSTACK;
1702         }
1703
1704         if (cxix >= 0) {
1705             PERL_CONTEXT *cx;
1706             SV **oldsp;
1707             U8 gimme;
1708             JMPENV *restartjmpenv;
1709             OP *restartop;
1710
1711             if (cxix < cxstack_ix)
1712                 dounwind(cxix);
1713
1714             cx = CX_CUR();
1715             assert(CxTYPE(cx) == CXt_EVAL);
1716
1717             /* return false to the caller of eval */
1718             oldsp = PL_stack_base + cx->blk_oldsp;
1719             gimme = cx->blk_gimme;
1720             if (gimme == G_SCALAR)
1721                 *++oldsp = &PL_sv_undef;
1722             PL_stack_sp = oldsp;
1723
1724             restartjmpenv = cx->blk_eval.cur_top_env;
1725             restartop     = cx->blk_eval.retop;
1726             /* Note that unlike pp_entereval, pp_require isn't supposed to
1727              * trap errors. So if we're a require, after we pop the
1728              * CXt_EVAL that pp_require pushed, rethrow the error with
1729              * croak(exceptsv). This is all handled by the call below when
1730              * action == 2.
1731              */
1732             S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
1733
1734             if (!(in_eval & EVAL_KEEPERR))
1735                 sv_setsv(ERRSV, exceptsv);
1736             PL_restartjmpenv = restartjmpenv;
1737             PL_restartop = restartop;
1738             JMPENV_JUMP(3);
1739             NOT_REACHED; /* NOTREACHED */
1740         }
1741     }
1742
1743     write_to_stderr(exceptsv);
1744     my_failure_exit();
1745     NOT_REACHED; /* NOTREACHED */
1746 }
1747
1748 PP(pp_xor)
1749 {
1750     dSP; dPOPTOPssrl;
1751     if (SvTRUE(left) != SvTRUE(right))
1752         RETSETYES;
1753     else
1754         RETSETNO;
1755 }
1756
1757 /*
1758
1759 =head1 CV Manipulation Functions
1760
1761 =for apidoc caller_cx
1762
1763 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>.  The
1764 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1765 information returned to Perl by C<caller>.  Note that XSUBs don't get a
1766 stack frame, so C<caller_cx(0, NULL)> will return information for the
1767 immediately-surrounding Perl code.
1768
1769 This function skips over the automatic calls to C<&DB::sub> made on the
1770 behalf of the debugger.  If the stack frame requested was a sub called by
1771 C<DB::sub>, the return value will be the frame for the call to
1772 C<DB::sub>, since that has the correct line number/etc. for the call
1773 site.  If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1774 frame for the sub call itself.
1775
1776 =cut
1777 */
1778
1779 const PERL_CONTEXT *
1780 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1781 {
1782     I32 cxix = dopoptosub(cxstack_ix);
1783     const PERL_CONTEXT *cx;
1784     const PERL_CONTEXT *ccstack = cxstack;
1785     const PERL_SI *top_si = PL_curstackinfo;
1786
1787     for (;;) {
1788         /* we may be in a higher stacklevel, so dig down deeper */
1789         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1790             top_si = top_si->si_prev;
1791             ccstack = top_si->si_cxstack;
1792             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1793         }
1794         if (cxix < 0)
1795             return NULL;
1796         /* caller() should not report the automatic calls to &DB::sub */
1797         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1798                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1799             count++;
1800         if (!count--)
1801             break;
1802         cxix = dopoptosub_at(ccstack, cxix - 1);
1803     }
1804
1805     cx = &ccstack[cxix];
1806     if (dbcxp) *dbcxp = cx;
1807
1808     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1809         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1810         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1811            field below is defined for any cx. */
1812         /* caller() should not report the automatic calls to &DB::sub */
1813         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1814             cx = &ccstack[dbcxix];
1815     }
1816
1817     return cx;
1818 }
1819
1820 PP(pp_caller)
1821 {
1822     dSP;
1823     const PERL_CONTEXT *cx;
1824     const PERL_CONTEXT *dbcx;
1825     U8 gimme = GIMME_V;
1826     const HEK *stash_hek;
1827     I32 count = 0;
1828     bool has_arg = MAXARG && TOPs;
1829     const COP *lcop;
1830
1831     if (MAXARG) {
1832       if (has_arg)
1833         count = POPi;
1834       else (void)POPs;
1835     }
1836
1837     cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1838     if (!cx) {
1839         if (gimme != G_ARRAY) {
1840             EXTEND(SP, 1);
1841             RETPUSHUNDEF;
1842         }
1843         RETURN;
1844     }
1845
1846     CX_DEBUG(cx, "CALLER");
1847     assert(CopSTASH(cx->blk_oldcop));
1848     stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1849       ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1850       : NULL;
1851     if (gimme != G_ARRAY) {
1852         EXTEND(SP, 1);
1853         if (!stash_hek)
1854             PUSHs(&PL_sv_undef);
1855         else {
1856             dTARGET;
1857             sv_sethek(TARG, stash_hek);
1858             PUSHs(TARG);
1859         }
1860         RETURN;
1861     }
1862
1863     EXTEND(SP, 11);
1864
1865     if (!stash_hek)
1866         PUSHs(&PL_sv_undef);
1867     else {
1868         dTARGET;
1869         sv_sethek(TARG, stash_hek);
1870         PUSHTARG;
1871     }
1872     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1873     lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1874                        cx->blk_sub.retop, TRUE);
1875     if (!lcop)
1876         lcop = cx->blk_oldcop;
1877     mPUSHu(CopLINE(lcop));
1878     if (!has_arg)
1879         RETURN;
1880     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1881         /* So is ccstack[dbcxix]. */
1882         if (CvHASGV(dbcx->blk_sub.cv)) {
1883             PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1884             PUSHs(boolSV(CxHASARGS(cx)));
1885         }
1886         else {
1887             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1888             PUSHs(boolSV(CxHASARGS(cx)));
1889         }
1890     }
1891     else {
1892         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1893         mPUSHi(0);
1894     }
1895     gimme = cx->blk_gimme;
1896     if (gimme == G_VOID)
1897         PUSHs(&PL_sv_undef);
1898     else
1899         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1900     if (CxTYPE(cx) == CXt_EVAL) {
1901         /* eval STRING */
1902         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1903             SV *cur_text = cx->blk_eval.cur_text;
1904             if (SvCUR(cur_text) >= 2) {
1905                 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1906                                      SvUTF8(cur_text)|SVs_TEMP));
1907             }
1908             else {
1909                 /* I think this is will always be "", but be sure */
1910                 PUSHs(sv_2mortal(newSVsv(cur_text)));
1911             }
1912
1913             PUSHs(&PL_sv_no);
1914         }
1915         /* require */
1916         else if (cx->blk_eval.old_namesv) {
1917             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1918             PUSHs(&PL_sv_yes);
1919         }
1920         /* eval BLOCK (try blocks have old_namesv == 0) */
1921         else {
1922             PUSHs(&PL_sv_undef);
1923             PUSHs(&PL_sv_undef);
1924         }
1925     }
1926     else {
1927         PUSHs(&PL_sv_undef);
1928         PUSHs(&PL_sv_undef);
1929     }
1930     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1931         && CopSTASH_eq(PL_curcop, PL_debstash))
1932     {
1933         /* slot 0 of the pad contains the original @_ */
1934         AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
1935                             PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1936                                 cx->blk_sub.olddepth+1]))[0]);
1937         const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1938
1939         Perl_init_dbargs(aTHX);
1940
1941         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1942             av_extend(PL_dbargs, AvFILLp(ary) + off);
1943         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1944         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1945     }
1946     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1947     {
1948         SV * mask ;
1949         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1950
1951         if  (old_warnings == pWARN_NONE)
1952             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1953         else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1954             mask = &PL_sv_undef ;
1955         else if (old_warnings == pWARN_ALL ||
1956                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1957             /* Get the bit mask for $warnings::Bits{all}, because
1958              * it could have been extended by warnings::register */
1959             SV **bits_all;
1960             HV * const bits = get_hv("warnings::Bits", 0);
1961             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1962                 mask = newSVsv(*bits_all);
1963             }
1964             else {
1965                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1966             }
1967         }
1968         else
1969             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1970         mPUSHs(mask);
1971     }
1972
1973     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1974           sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1975           : &PL_sv_undef);
1976     RETURN;
1977 }
1978
1979 PP(pp_reset)
1980 {
1981     dSP;
1982     const char * tmps;
1983     STRLEN len = 0;
1984     if (MAXARG < 1 || (!TOPs && !POPs))
1985         tmps = NULL, len = 0;
1986     else
1987         tmps = SvPVx_const(POPs, len);
1988     sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1989     PUSHs(&PL_sv_yes);
1990     RETURN;
1991 }
1992
1993 /* like pp_nextstate, but used instead when the debugger is active */
1994
1995 PP(pp_dbstate)
1996 {
1997     PL_curcop = (COP*)PL_op;
1998     TAINT_NOT;          /* Each statement is presumed innocent */
1999     PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
2000     FREETMPS;
2001
2002     PERL_ASYNC_CHECK();
2003
2004     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2005             || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2006     {
2007         dSP;
2008         PERL_CONTEXT *cx;
2009         const U8 gimme = G_ARRAY;
2010         GV * const gv = PL_DBgv;
2011         CV * cv = NULL;
2012
2013         if (gv && isGV_with_GP(gv))
2014             cv = GvCV(gv);
2015
2016         if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2017             DIE(aTHX_ "No DB::DB routine defined");
2018
2019         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2020             /* don't do recursive DB::DB call */
2021             return NORMAL;
2022
2023         if (CvISXSUB(cv)) {
2024             ENTER;
2025             SAVEI32(PL_debug);
2026             PL_debug = 0;
2027             SAVESTACK_POS();
2028             SAVETMPS;
2029             PUSHMARK(SP);
2030             (void)(*CvXSUB(cv))(aTHX_ cv);
2031             FREETMPS;
2032             LEAVE;
2033             return NORMAL;
2034         }
2035         else {
2036             cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
2037             cx_pushsub(cx, cv, PL_op->op_next, 0);
2038             /* OP_DBSTATE's op_private holds hint bits rather than
2039              * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2040              * any CxLVAL() flags that have now been mis-calculated */
2041             cx->blk_u16 = 0;
2042
2043             SAVEI32(PL_debug);
2044             PL_debug = 0;
2045             SAVESTACK_POS();
2046             CvDEPTH(cv)++;
2047             if (CvDEPTH(cv) >= 2)
2048                 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2049             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2050             RETURNOP(CvSTART(cv));
2051         }
2052     }
2053     else
2054         return NORMAL;
2055 }
2056
2057
2058 PP(pp_enter)
2059 {
2060     U8 gimme = GIMME_V;
2061
2062     (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2063     return NORMAL;
2064 }
2065
2066
2067 PP(pp_leave)
2068 {
2069     PERL_CONTEXT *cx;
2070     SV **oldsp;
2071     U8 gimme;
2072
2073     cx = CX_CUR();
2074     assert(CxTYPE(cx) == CXt_BLOCK);
2075
2076     if (PL_op->op_flags & OPf_SPECIAL)
2077         /* fake block should preserve $1 et al; e.g.  /(...)/ while ...; */
2078         cx->blk_oldpm = PL_curpm;
2079
2080     oldsp = PL_stack_base + cx->blk_oldsp;
2081     gimme = cx->blk_gimme;
2082
2083     if (gimme == G_VOID)
2084         PL_stack_sp = oldsp;
2085     else
2086         leave_adjust_stacks(oldsp, oldsp, gimme,
2087                                 PL_op->op_private & OPpLVALUE ? 3 : 1);
2088
2089     CX_LEAVE_SCOPE(cx);
2090     cx_popblock(cx);
2091     CX_POP(cx);
2092
2093     return NORMAL;
2094 }
2095
2096 static bool
2097 S_outside_integer(pTHX_ SV *sv)
2098 {
2099   if (SvOK(sv)) {
2100     const NV nv = SvNV_nomg(sv);
2101     if (Perl_isinfnan(nv))
2102       return TRUE;
2103 #ifdef NV_PRESERVES_UV
2104     if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2105       return TRUE;
2106 #else
2107     if (nv <= (NV)IV_MIN)
2108       return TRUE;
2109     if ((nv > 0) &&
2110         ((nv > (NV)UV_MAX ||
2111           SvUV_nomg(sv) > (UV)IV_MAX)))
2112       return TRUE;
2113 #endif
2114   }
2115   return FALSE;
2116 }
2117
2118 PP(pp_enteriter)
2119 {
2120     dSP; dMARK;
2121     PERL_CONTEXT *cx;
2122     const U8 gimme = GIMME_V;
2123     void *itervarp; /* GV or pad slot of the iteration variable */
2124     SV   *itersave; /* the old var in the iterator var slot */
2125     U8 cxflags = 0;
2126
2127     if (PL_op->op_targ) {                        /* "my" variable */
2128         itervarp = &PAD_SVl(PL_op->op_targ);
2129         itersave = *(SV**)itervarp;
2130         assert(itersave);
2131         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2132             /* the SV currently in the pad slot is never live during
2133              * iteration (the slot is always aliased to one of the items)
2134              * so it's always stale */
2135             SvPADSTALE_on(itersave);
2136         }
2137         SvREFCNT_inc_simple_void_NN(itersave);
2138         cxflags = CXp_FOR_PAD;
2139     }
2140     else {
2141         SV * const sv = POPs;
2142         itervarp = (void *)sv;
2143         if (LIKELY(isGV(sv))) {         /* symbol table variable */
2144             itersave = GvSV(sv);
2145             SvREFCNT_inc_simple_void(itersave);
2146             cxflags = CXp_FOR_GV;
2147             if (PL_op->op_private & OPpITER_DEF)
2148                 cxflags |= CXp_FOR_DEF;
2149         }
2150         else {                          /* LV ref: for \$foo (...) */
2151             assert(SvTYPE(sv) == SVt_PVMG);
2152             assert(SvMAGIC(sv));
2153             assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2154             itersave = NULL;
2155             cxflags = CXp_FOR_LVREF;
2156         }
2157     }
2158     /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2159     assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2160
2161     /* Note that this context is initially set as CXt_NULL. Further on
2162      * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2163      * there mustn't be anything in the blk_loop substruct that requires
2164      * freeing or undoing, in case we die in the meantime. And vice-versa.
2165      */
2166     cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2167     cx_pushloop_for(cx, itervarp, itersave);
2168
2169     if (PL_op->op_flags & OPf_STACKED) {
2170         /* OPf_STACKED implies either a single array: for(@), with a
2171          * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2172          * the stack */
2173         SV *maybe_ary = POPs;
2174         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2175             /* range */
2176             dPOPss;
2177             SV * const right = maybe_ary;
2178             if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2179                 DIE(aTHX_ "Assigned value is not a reference");
2180             SvGETMAGIC(sv);
2181             SvGETMAGIC(right);
2182             if (RANGE_IS_NUMERIC(sv,right)) {
2183                 cx->cx_type |= CXt_LOOP_LAZYIV;
2184                 if (S_outside_integer(aTHX_ sv) ||
2185                     S_outside_integer(aTHX_ right))
2186                     DIE(aTHX_ "Range iterator outside integer range");
2187                 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2188                 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2189             }
2190             else {
2191                 cx->cx_type |= CXt_LOOP_LAZYSV;
2192                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2193                 cx->blk_loop.state_u.lazysv.end = right;
2194                 SvREFCNT_inc_simple_void_NN(right);
2195                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2196                 /* This will do the upgrade to SVt_PV, and warn if the value
2197                    is uninitialised.  */
2198                 (void) SvPV_nolen_const(right);
2199                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2200                    to replace !SvOK() with a pointer to "".  */
2201                 if (!SvOK(right)) {
2202                     SvREFCNT_dec(right);
2203                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2204                 }
2205             }
2206         }
2207         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2208             /* for (@array) {} */
2209             cx->cx_type |= CXt_LOOP_ARY;
2210             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2211             SvREFCNT_inc_simple_void_NN(maybe_ary);
2212             cx->blk_loop.state_u.ary.ix =
2213                 (PL_op->op_private & OPpITER_REVERSED) ?
2214                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2215                 -1;
2216         }
2217         /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
2218     }
2219     else { /* iterating over items on the stack */
2220         cx->cx_type |= CXt_LOOP_LIST;
2221         cx->blk_oldsp = SP - PL_stack_base;
2222         cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2223         cx->blk_loop.state_u.stack.ix =
2224             (PL_op->op_private & OPpITER_REVERSED)
2225                 ? cx->blk_oldsp + 1
2226                 : cx->blk_loop.state_u.stack.basesp;
2227         /* pre-extend stack so pp_iter doesn't have to check every time
2228          * it pushes yes/no */
2229         EXTEND(SP, 1);
2230     }
2231
2232     RETURN;
2233 }
2234
2235 PP(pp_enterloop)
2236 {
2237     PERL_CONTEXT *cx;
2238     const U8 gimme = GIMME_V;
2239
2240     cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2241     cx_pushloop_plain(cx);
2242     return NORMAL;
2243 }
2244
2245
2246 PP(pp_leaveloop)
2247 {
2248     PERL_CONTEXT *cx;
2249     U8 gimme;
2250     SV **oldsp;
2251     SV **mark;
2252
2253     cx = CX_CUR();
2254     assert(CxTYPE_is_LOOP(cx));
2255     mark = PL_stack_base + cx->blk_oldsp;
2256     oldsp = CxTYPE(cx) == CXt_LOOP_LIST
2257                 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2258                 : mark;
2259     gimme = cx->blk_gimme;
2260
2261     if (gimme == G_VOID)
2262         PL_stack_sp = oldsp;
2263     else
2264         leave_adjust_stacks(MARK, oldsp, gimme,
2265                                 PL_op->op_private & OPpLVALUE ? 3 : 1);
2266
2267     CX_LEAVE_SCOPE(cx);
2268     cx_poploop(cx);     /* Stack values are safe: release loop vars ... */
2269     cx_popblock(cx);
2270     CX_POP(cx);
2271
2272     return NORMAL;
2273 }
2274
2275
2276 /* This duplicates most of pp_leavesub, but with additional code to handle
2277  * return args in lvalue context. It was forked from pp_leavesub to
2278  * avoid slowing down that function any further.
2279  *
2280  * Any changes made to this function may need to be copied to pp_leavesub
2281  * and vice-versa.
2282  *
2283  * also tail-called by pp_return
2284  */
2285
2286 PP(pp_leavesublv)
2287 {
2288     U8 gimme;
2289     PERL_CONTEXT *cx;
2290     SV **oldsp;
2291     OP *retop;
2292
2293     cx = CX_CUR();
2294     assert(CxTYPE(cx) == CXt_SUB);
2295
2296     if (CxMULTICALL(cx)) {
2297         /* entry zero of a stack is always PL_sv_undef, which
2298          * simplifies converting a '()' return into undef in scalar context */
2299         assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2300         return 0;
2301     }
2302
2303     gimme = cx->blk_gimme;
2304     oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2305
2306     if (gimme == G_VOID)
2307         PL_stack_sp = oldsp;
2308     else {
2309         U8   lval    = CxLVAL(cx);
2310         bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2311         const char *what = NULL;
2312
2313         if (gimme == G_SCALAR) {
2314             if (is_lval) {
2315                 /* check for bad return arg */
2316                 if (oldsp < PL_stack_sp) {
2317                     SV *sv = *PL_stack_sp;
2318                     if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2319                         what =
2320                             SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2321                             : "a readonly value" : "a temporary";
2322                     }
2323                     else goto ok;
2324                 }
2325                 else {
2326                     /* sub:lvalue{} will take us here. */
2327                     what = "undef";
2328                 }
2329               croak:
2330                 Perl_croak(aTHX_
2331                           "Can't return %s from lvalue subroutine", what);
2332             }
2333
2334           ok:
2335             leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2336
2337             if (lval & OPpDEREF) {
2338                 /* lval_sub()->{...} and similar */
2339                 dSP;
2340                 SvGETMAGIC(TOPs);
2341                 if (!SvOK(TOPs)) {
2342                     TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2343                 }
2344                 PUTBACK;
2345             }
2346         }
2347         else {
2348             assert(gimme == G_ARRAY);
2349             assert (!(lval & OPpDEREF));
2350
2351             if (is_lval) {
2352                 /* scan for bad return args */
2353                 SV **p;
2354                 for (p = PL_stack_sp; p > oldsp; p--) {
2355                     SV *sv = *p;
2356                     /* the PL_sv_undef exception is to allow things like
2357                      * this to work, where PL_sv_undef acts as 'skip'
2358                      * placeholder on the LHS of list assigns:
2359                      *    sub foo :lvalue { undef }
2360                      *    ($a, undef, foo(), $b) = 1..4;
2361                      */
2362                     if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2363                     {
2364                         /* Might be flattened array after $#array =  */
2365                         what = SvREADONLY(sv)
2366                                 ? "a readonly value" : "a temporary";
2367                         goto croak;
2368                     }
2369                 }
2370             }
2371
2372             leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2373         }
2374     }
2375
2376     CX_LEAVE_SCOPE(cx);
2377     cx_popsub(cx);      /* Stack values are safe: release CV and @_ ... */
2378     cx_popblock(cx);
2379     retop =  cx->blk_sub.retop;
2380     CX_POP(cx);
2381
2382     return retop;
2383 }
2384
2385
2386 PP(pp_return)
2387 {
2388     dSP; dMARK;
2389     PERL_CONTEXT *cx;
2390     const I32 cxix = dopoptosub(cxstack_ix);
2391
2392     assert(cxstack_ix >= 0);
2393     if (cxix < cxstack_ix) {
2394         if (cxix < 0) {
2395             if (!(       PL_curstackinfo->si_type == PERLSI_SORT
2396                   || (   PL_curstackinfo->si_type == PERLSI_MULTICALL
2397                       && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2398                  )
2399             )
2400                 DIE(aTHX_ "Can't return outside a subroutine");
2401             /* We must be in:
2402              *  a sort block, which is a CXt_NULL not a CXt_SUB;
2403              *  or a /(?{...})/ block.
2404              * Handle specially. */
2405             assert(CxTYPE(&cxstack[0]) == CXt_NULL
2406                     || (   CxTYPE(&cxstack[0]) == CXt_SUB
2407                         && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2408             if (cxstack_ix > 0) {
2409                 /* See comment below about context popping. Since we know
2410                  * we're scalar and not lvalue, we can preserve the return
2411                  * value in a simpler fashion than there. */
2412                 SV *sv = *SP;
2413                 assert(cxstack[0].blk_gimme == G_SCALAR);
2414                 if (   (sp != PL_stack_base)
2415                     && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2416                 )
2417                     *SP = sv_mortalcopy(sv);
2418                 dounwind(0);
2419             }
2420             /* caller responsible for popping cxstack[0] */
2421             return 0;
2422         }
2423
2424         /* There are contexts that need popping. Doing this may free the
2425          * return value(s), so preserve them first: e.g. popping the plain
2426          * loop here would free $x:
2427          *     sub f {  { my $x = 1; return $x } }
2428          * We may also need to shift the args down; for example,
2429          *    for (1,2) { return 3,4 }
2430          * leaves 1,2,3,4 on the stack. Both these actions will be done by
2431          * leave_adjust_stacks(), along with freeing any temps. Note that
2432          * whoever we tail-call (e.g. pp_leaveeval) will also call
2433          * leave_adjust_stacks(); however, the second call is likely to
2434          * just see a bunch of SvTEMPs with a ref count of 1, and so just
2435          * pass them through, rather than copying them again. So this
2436          * isn't as inefficient as it sounds.
2437          */
2438         cx = &cxstack[cxix];
2439         PUTBACK;
2440         if (cx->blk_gimme != G_VOID)
2441             leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2442                     cx->blk_gimme,
2443                     CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2444                         ? 3 : 0);
2445         SPAGAIN;
2446         dounwind(cxix);
2447         cx = &cxstack[cxix]; /* CX stack may have been realloced */
2448     }
2449     else {
2450         /* Like in the branch above, we need to handle any extra junk on
2451          * the stack. But because we're not also popping extra contexts, we
2452          * don't have to worry about prematurely freeing args. So we just
2453          * need to do the bare minimum to handle junk, and leave the main
2454          * arg processing in the function we tail call, e.g. pp_leavesub.
2455          * In list context we have to splice out the junk; in scalar
2456          * context we can leave as-is (pp_leavesub will later return the
2457          * top stack element). But for an  empty arg list, e.g.
2458          *    for (1,2) { return }
2459          * we need to set sp = oldsp so that pp_leavesub knows to push
2460          * &PL_sv_undef onto the stack.
2461          */
2462         SV **oldsp;
2463         cx = &cxstack[cxix];
2464         oldsp = PL_stack_base + cx->blk_oldsp;
2465         if (oldsp != MARK) {
2466             SSize_t nargs = SP - MARK;
2467             if (nargs) {
2468                 if (cx->blk_gimme == G_ARRAY) {
2469                     /* shift return args to base of call stack frame */
2470                     Move(MARK + 1, oldsp + 1, nargs, SV*);
2471                     PL_stack_sp  = oldsp + nargs;
2472                 }
2473             }
2474             else
2475                 PL_stack_sp  = oldsp;
2476         }
2477     }
2478
2479     /* fall through to a normal exit */
2480     switch (CxTYPE(cx)) {
2481     case CXt_EVAL:
2482         return CxTRYBLOCK(cx)
2483             ? Perl_pp_leavetry(aTHX)
2484             : Perl_pp_leaveeval(aTHX);
2485     case CXt_SUB:
2486         return CvLVALUE(cx->blk_sub.cv)
2487             ? Perl_pp_leavesublv(aTHX)
2488             : Perl_pp_leavesub(aTHX);
2489     case CXt_FORMAT:
2490         return Perl_pp_leavewrite(aTHX);
2491     default:
2492         DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2493     }
2494 }
2495
2496 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2497
2498 static PERL_CONTEXT *
2499 S_unwind_loop(pTHX)
2500 {
2501     I32 cxix;
2502     if (PL_op->op_flags & OPf_SPECIAL) {
2503         cxix = dopoptoloop(cxstack_ix);
2504         if (cxix < 0)
2505             /* diag_listed_as: Can't "last" outside a loop block */
2506             Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2507                 OP_NAME(PL_op));
2508     }
2509     else {
2510         dSP;
2511         STRLEN label_len;
2512         const char * const label =
2513             PL_op->op_flags & OPf_STACKED
2514                 ? SvPV(TOPs,label_len)
2515                 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2516         const U32 label_flags =
2517             PL_op->op_flags & OPf_STACKED
2518                 ? SvUTF8(POPs)
2519                 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2520         PUTBACK;
2521         cxix = dopoptolabel(label, label_len, label_flags);
2522         if (cxix < 0)
2523             /* diag_listed_as: Label not found for "last %s" */
2524             Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2525                                        OP_NAME(PL_op),
2526                                        SVfARG(PL_op->op_flags & OPf_STACKED
2527                                               && !SvGMAGICAL(TOPp1s)
2528                                               ? TOPp1s
2529                                               : newSVpvn_flags(label,
2530                                                     label_len,
2531                                                     label_flags | SVs_TEMP)));
2532     }
2533     if (cxix < cxstack_ix)
2534         dounwind(cxix);
2535     return &cxstack[cxix];
2536 }
2537
2538
2539 PP(pp_last)
2540 {
2541     PERL_CONTEXT *cx;
2542     OP* nextop;
2543
2544     cx = S_unwind_loop(aTHX);
2545
2546     assert(CxTYPE_is_LOOP(cx));
2547     PL_stack_sp = PL_stack_base
2548                 + (CxTYPE(cx) == CXt_LOOP_LIST
2549                     ?  cx->blk_loop.state_u.stack.basesp
2550                     : cx->blk_oldsp
2551                 );
2552
2553     TAINT_NOT;
2554
2555     /* Stack values are safe: */
2556     CX_LEAVE_SCOPE(cx);
2557     cx_poploop(cx);     /* release loop vars ... */
2558     cx_popblock(cx);
2559     nextop = cx->blk_loop.my_op->op_lastop->op_next;
2560     CX_POP(cx);
2561
2562     return nextop;
2563 }
2564
2565 PP(pp_next)
2566 {
2567     PERL_CONTEXT *cx;
2568
2569     /* if not a bare 'next' in the main scope, search for it */
2570     cx = CX_CUR();
2571     if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
2572         cx = S_unwind_loop(aTHX);
2573
2574     cx_topblock(cx);
2575     PL_curcop = cx->blk_oldcop;
2576     PERL_ASYNC_CHECK();
2577     return (cx)->blk_loop.my_op->op_nextop;
2578 }
2579
2580 PP(pp_redo)
2581 {
2582     PERL_CONTEXT *cx = S_unwind_loop(aTHX);
2583     OP* redo_op = cx->blk_loop.my_op->op_redoop;
2584
2585     if (redo_op->op_type == OP_ENTER) {
2586         /* pop one less context to avoid $x being freed in while (my $x..) */
2587         cxstack_ix++;
2588         cx = CX_CUR();
2589         assert(CxTYPE(cx) == CXt_BLOCK);
2590         redo_op = redo_op->op_next;
2591     }
2592
2593     FREETMPS;
2594     CX_LEAVE_SCOPE(cx);
2595     cx_topblock(cx);
2596     PL_curcop = cx->blk_oldcop;
2597     PERL_ASYNC_CHECK();
2598     return redo_op;
2599 }
2600
2601 STATIC OP *
2602 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2603 {
2604     OP **ops = opstack;
2605     static const char* const too_deep = "Target of goto is too deeply nested";
2606
2607     PERL_ARGS_ASSERT_DOFINDLABEL;
2608
2609     if (ops >= oplimit)
2610         Perl_croak(aTHX_ "%s", too_deep);
2611     if (o->op_type == OP_LEAVE ||
2612         o->op_type == OP_SCOPE ||
2613         o->op_type == OP_LEAVELOOP ||
2614         o->op_type == OP_LEAVESUB ||
2615         o->op_type == OP_LEAVETRY)
2616     {
2617         *ops++ = cUNOPo->op_first;
2618         if (ops >= oplimit)
2619             Perl_croak(aTHX_ "%s", too_deep);
2620     }
2621     *ops = 0;
2622     if (o->op_flags & OPf_KIDS) {
2623         OP *kid;
2624         /* First try all the kids at this level, since that's likeliest. */
2625         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2626             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2627                 STRLEN kid_label_len;
2628                 U32 kid_label_flags;
2629                 const char *kid_label = CopLABEL_len_flags(kCOP,
2630                                                     &kid_label_len, &kid_label_flags);
2631                 if (kid_label && (
2632                     ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2633                         (flags & SVf_UTF8)
2634                             ? (bytes_cmp_utf8(
2635                                         (const U8*)kid_label, kid_label_len,
2636                                         (const U8*)label, len) == 0)
2637                             : (bytes_cmp_utf8(
2638                                         (const U8*)label, len,
2639                                         (const U8*)kid_label, kid_label_len) == 0)
2640                     : ( len == kid_label_len && ((kid_label == label)
2641                                     || memEQ(kid_label, label, len)))))
2642                     return kid;
2643             }
2644         }
2645         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2646             if (kid == PL_lastgotoprobe)
2647                 continue;
2648             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2649                 if (ops == opstack)
2650                     *ops++ = kid;
2651                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2652                          ops[-1]->op_type == OP_DBSTATE)
2653                     ops[-1] = kid;
2654                 else
2655                     *ops++ = kid;
2656             }
2657             if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2658                 return o;
2659         }
2660     }
2661     *ops = 0;
2662     return 0;
2663 }
2664
2665
2666 /* also used for: pp_dump() */
2667
2668 PP(pp_goto)
2669 {
2670     dVAR; dSP;
2671     OP *retop = NULL;
2672     I32 ix;
2673     PERL_CONTEXT *cx;
2674 #define GOTO_DEPTH 64
2675     OP *enterops[GOTO_DEPTH];
2676     const char *label = NULL;
2677     STRLEN label_len = 0;
2678     U32 label_flags = 0;
2679     const bool do_dump = (PL_op->op_type == OP_DUMP);
2680     static const char* const must_have_label = "goto must have label";
2681
2682     if (PL_op->op_flags & OPf_STACKED) {
2683         /* goto EXPR  or  goto &foo */
2684
2685         SV * const sv = POPs;
2686         SvGETMAGIC(sv);
2687
2688         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2689             /* This egregious kludge implements goto &subroutine */
2690             I32 cxix;
2691             PERL_CONTEXT *cx;
2692             CV *cv = MUTABLE_CV(SvRV(sv));
2693             AV *arg = GvAV(PL_defgv);
2694
2695             while (!CvROOT(cv) && !CvXSUB(cv)) {
2696                 const GV * const gv = CvGV(cv);
2697                 if (gv) {
2698                     GV *autogv;
2699                     SV *tmpstr;
2700                     /* autoloaded stub? */
2701                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2702                         continue;
2703                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2704                                           GvNAMELEN(gv),
2705                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2706                     if (autogv && (cv = GvCV(autogv)))
2707                         continue;
2708                     tmpstr = sv_newmortal();
2709                     gv_efullname3(tmpstr, gv, NULL);
2710                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2711                 }
2712                 DIE(aTHX_ "Goto undefined subroutine");
2713             }
2714
2715             cxix = dopoptosub(cxstack_ix);
2716             if (cxix < 0) {
2717                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2718             }
2719             cx  = &cxstack[cxix];
2720             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2721             if (CxTYPE(cx) == CXt_EVAL) {
2722                 if (CxREALEVAL(cx))
2723                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2724                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2725                 else
2726                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2727                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2728             }
2729             else if (CxMULTICALL(cx))
2730                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2731
2732             /* First do some returnish stuff. */
2733
2734             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2735             FREETMPS;
2736             if (cxix < cxstack_ix) {
2737                 dounwind(cxix);
2738             }
2739             cx = CX_CUR();
2740             cx_topblock(cx);
2741             SPAGAIN;
2742
2743             /* protect @_ during save stack unwind. */
2744             if (arg)
2745                 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
2746
2747             assert(PL_scopestack_ix == cx->blk_oldscopesp);
2748             CX_LEAVE_SCOPE(cx);
2749
2750             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2751                 /* this is part of cx_popsub_args() */
2752                 AV* av = MUTABLE_AV(PAD_SVl(0));
2753                 assert(AvARRAY(MUTABLE_AV(
2754                     PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2755                             CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2756
2757                 /* we are going to donate the current @_ from the old sub
2758                  * to the new sub. This first part of the donation puts a
2759                  * new empty AV in the pad[0] slot of the old sub,
2760                  * unless pad[0] and @_ differ (e.g. if the old sub did
2761                  * local *_ = []); in which case clear the old pad[0]
2762                  * array in the usual way */
2763                 if (av == arg || AvREAL(av))
2764                     clear_defarray(av, av == arg);
2765                 else CLEAR_ARGARRAY(av);
2766             }
2767
2768             /* don't restore PL_comppad here. It won't be needed if the
2769              * sub we're going to is non-XS, but restoring it early then
2770              * croaking (e.g. the "Goto undefined subroutine" below)
2771              * means the CX block gets processed again in dounwind,
2772              * but this time with the wrong PL_comppad */
2773
2774             /* A destructor called during LEAVE_SCOPE could have undefined
2775              * our precious cv.  See bug #99850. */
2776             if (!CvROOT(cv) && !CvXSUB(cv)) {
2777                 const GV * const gv = CvGV(cv);
2778                 if (gv) {
2779                     SV * const tmpstr = sv_newmortal();
2780                     gv_efullname3(tmpstr, gv, NULL);
2781                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2782                                SVfARG(tmpstr));
2783                 }
2784                 DIE(aTHX_ "Goto undefined subroutine");
2785             }
2786
2787             if (CxTYPE(cx) == CXt_SUB) {
2788                 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2789                 SvREFCNT_dec_NN(cx->blk_sub.cv);
2790             }
2791
2792             /* Now do some callish stuff. */
2793             if (CvISXSUB(cv)) {
2794                 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2795                 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2796                 SV** mark;
2797
2798                 ENTER;
2799                 SAVETMPS;
2800                 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2801
2802                 /* put GvAV(defgv) back onto stack */
2803                 if (items) {
2804                     EXTEND(SP, items+1); /* @_ could have been extended. */
2805                 }
2806                 mark = SP;
2807                 if (items) {
2808                     SSize_t index;
2809                     bool r = cBOOL(AvREAL(arg));
2810                     for (index=0; index<items; index++)
2811                     {
2812                         SV *sv;
2813                         if (m) {
2814                             SV ** const svp = av_fetch(arg, index, 0);
2815                             sv = svp ? *svp : NULL;
2816                         }
2817                         else sv = AvARRAY(arg)[index];
2818                         SP[index+1] = sv
2819                             ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2820                             : sv_2mortal(newSVavdefelem(arg, index, 1));
2821                     }
2822                 }
2823                 SP += items;
2824                 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2825                     /* Restore old @_ */
2826                     CX_POP_SAVEARRAY(cx);
2827                 }
2828
2829                 retop = cx->blk_sub.retop;
2830                 PL_comppad = cx->blk_sub.prevcomppad;
2831                 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2832
2833                 /* XS subs don't have a CXt_SUB, so pop it;
2834                  * this is a cx_popblock(), less all the stuff we already did
2835                  * for cx_topblock() earlier */
2836                 PL_curcop = cx->blk_oldcop;
2837                 CX_POP(cx);
2838
2839                 /* Push a mark for the start of arglist */
2840                 PUSHMARK(mark);
2841                 PUTBACK;
2842                 (void)(*CvXSUB(cv))(aTHX_ cv);
2843                 LEAVE;
2844                 goto _return;
2845             }
2846             else {
2847                 PADLIST * const padlist = CvPADLIST(cv);
2848
2849                 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2850
2851                 /* partial unrolled cx_pushsub(): */
2852
2853                 cx->blk_sub.cv = cv;
2854                 cx->blk_sub.olddepth = CvDEPTH(cv);
2855
2856                 CvDEPTH(cv)++;
2857                 SvREFCNT_inc_simple_void_NN(cv);
2858                 if (CvDEPTH(cv) > 1) {
2859                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2860                         sub_crush_depth(cv);
2861                     pad_push(padlist, CvDEPTH(cv));
2862                 }
2863                 PL_curcop = cx->blk_oldcop;
2864                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2865                 if (CxHASARGS(cx))
2866                 {
2867                     /* second half of donating @_ from the old sub to the
2868                      * new sub: abandon the original pad[0] AV in the
2869                      * new sub, and replace it with the donated @_.
2870                      * pad[0] takes ownership of the extra refcount
2871                      * we gave arg earlier */
2872                     if (arg) {
2873                         SvREFCNT_dec(PAD_SVl(0));
2874                         PAD_SVl(0) = (SV *)arg;
2875                         SvREFCNT_inc_simple_void_NN(arg);
2876                     }
2877
2878                     /* GvAV(PL_defgv) might have been modified on scope
2879                        exit, so point it at arg again. */
2880                     if (arg != GvAV(PL_defgv)) {
2881                         AV * const av = GvAV(PL_defgv);
2882                         GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2883                         SvREFCNT_dec(av);
2884                     }
2885                 }
2886
2887                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2888                     Perl_get_db_sub(aTHX_ NULL, cv);
2889                     if (PERLDB_GOTO) {
2890                         CV * const gotocv = get_cvs("DB::goto", 0);
2891                         if (gotocv) {
2892                             PUSHMARK( PL_stack_sp );
2893                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2894                             PL_stack_sp--;
2895                         }
2896                     }
2897                 }
2898                 retop = CvSTART(cv);
2899                 goto putback_return;
2900             }
2901         }
2902         else {
2903             /* goto EXPR */
2904             label       = SvPV_nomg_const(sv, label_len);
2905             label_flags = SvUTF8(sv);
2906         }
2907     }
2908     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2909         /* goto LABEL  or  dump LABEL */
2910         label       = cPVOP->op_pv;
2911         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2912         label_len   = strlen(label);
2913     }
2914     if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2915
2916     PERL_ASYNC_CHECK();
2917
2918     if (label_len) {
2919         OP *gotoprobe = NULL;
2920         bool leaving_eval = FALSE;
2921         bool in_block = FALSE;
2922         PERL_CONTEXT *last_eval_cx = NULL;
2923
2924         /* find label */
2925
2926         PL_lastgotoprobe = NULL;
2927         *enterops = 0;
2928         for (ix = cxstack_ix; ix >= 0; ix--) {
2929             cx = &cxstack[ix];
2930             switch (CxTYPE(cx)) {
2931             case CXt_EVAL:
2932                 leaving_eval = TRUE;
2933                 if (!CxTRYBLOCK(cx)) {
2934                     gotoprobe = (last_eval_cx ?
2935                                 last_eval_cx->blk_eval.old_eval_root :
2936                                 PL_eval_root);
2937                     last_eval_cx = cx;
2938                     break;
2939                 }
2940                 /* else fall through */
2941             case CXt_LOOP_PLAIN:
2942             case CXt_LOOP_LAZYIV:
2943             case CXt_LOOP_LAZYSV:
2944             case CXt_LOOP_LIST:
2945             case CXt_LOOP_ARY:
2946             case CXt_GIVEN:
2947             case CXt_WHEN:
2948                 gotoprobe = OpSIBLING(cx->blk_oldcop);
2949                 break;
2950             case CXt_SUBST:
2951                 continue;
2952             case CXt_BLOCK:
2953                 if (ix) {
2954                     gotoprobe = OpSIBLING(cx->blk_oldcop);
2955                     in_block = TRUE;
2956                 } else
2957                     gotoprobe = PL_main_root;
2958                 break;
2959             case CXt_SUB:
2960                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2961                     gotoprobe = CvROOT(cx->blk_sub.cv);
2962                     break;
2963                 }
2964                 /* FALLTHROUGH */
2965             case CXt_FORMAT:
2966             case CXt_NULL:
2967                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2968             default:
2969                 if (ix)
2970                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
2971                         CxTYPE(cx), (long) ix);
2972                 gotoprobe = PL_main_root;
2973                 break;
2974             }
2975             if (gotoprobe) {
2976                 OP *sibl1, *sibl2;
2977
2978                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
2979                                     enterops, enterops + GOTO_DEPTH);
2980                 if (retop)
2981                     break;
2982                 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
2983                      sibl1->op_type == OP_UNSTACK &&
2984                      (sibl2 = OpSIBLING(sibl1)))
2985                 {
2986                     retop = dofindlabel(sibl2,
2987                                         label, label_len, label_flags, enterops,
2988                                         enterops + GOTO_DEPTH);
2989                     if (retop)
2990                         break;
2991                 }
2992             }
2993             PL_lastgotoprobe = gotoprobe;
2994         }
2995         if (!retop)
2996             DIE(aTHX_ "Can't find label %"UTF8f, 
2997                        UTF8fARG(label_flags, label_len, label));
2998
2999         /* if we're leaving an eval, check before we pop any frames
3000            that we're not going to punt, otherwise the error
3001            won't be caught */
3002
3003         if (leaving_eval && *enterops && enterops[1]) {
3004             I32 i;
3005             for (i = 1; enterops[i]; i++)
3006                 if (enterops[i]->op_type == OP_ENTERITER)
3007                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3008         }
3009
3010         if (*enterops && enterops[1]) {
3011             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3012             if (enterops[i])
3013                 deprecate("\"goto\" to jump into a construct");
3014         }
3015
3016         /* pop unwanted frames */
3017
3018         if (ix < cxstack_ix) {
3019             if (ix < 0)
3020                 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3021             dounwind(ix);
3022             cx = CX_CUR();
3023             cx_topblock(cx);
3024         }
3025
3026         /* push wanted frames */
3027
3028         if (*enterops && enterops[1]) {
3029             OP * const oldop = PL_op;
3030             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3031             for (; enterops[ix]; ix++) {
3032                 PL_op = enterops[ix];
3033                 /* Eventually we may want to stack the needed arguments
3034                  * for each op.  For now, we punt on the hard ones. */
3035                 if (PL_op->op_type == OP_ENTERITER)
3036                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3037                 PL_op->op_ppaddr(aTHX);
3038             }
3039             PL_op = oldop;
3040         }
3041     }
3042
3043     if (do_dump) {
3044 #ifdef VMS
3045         if (!retop) retop = PL_main_start;
3046 #endif
3047         PL_restartop = retop;
3048         PL_do_undump = TRUE;
3049
3050         my_unexec();
3051
3052         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3053         PL_do_undump = FALSE;
3054     }
3055
3056     putback_return:
3057     PL_stack_sp = sp;
3058     _return:
3059     PERL_ASYNC_CHECK();
3060     return retop;
3061 }
3062
3063 PP(pp_exit)
3064 {
3065     dSP;
3066     I32 anum;
3067
3068     if (MAXARG < 1)
3069         anum = 0;
3070     else if (!TOPs) {
3071         anum = 0; (void)POPs;
3072     }
3073     else {
3074         anum = SvIVx(POPs);
3075 #ifdef VMS
3076         if (anum == 1
3077          && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3078             anum = 0;
3079         VMSISH_HUSHED  =
3080             VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3081 #endif
3082     }
3083     PL_exit_flags |= PERL_EXIT_EXPECTED;
3084     my_exit(anum);
3085     PUSHs(&PL_sv_undef);
3086     RETURN;
3087 }
3088
3089 /* Eval. */
3090
3091 STATIC void
3092 S_save_lines(pTHX_ AV *array, SV *sv)
3093 {
3094     const char *s = SvPVX_const(sv);
3095     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3096     I32 line = 1;
3097
3098     PERL_ARGS_ASSERT_SAVE_LINES;
3099
3100     while (s && s < send) {
3101         const char *t;
3102         SV * const tmpstr = newSV_type(SVt_PVMG);
3103
3104         t = (const char *)memchr(s, '\n', send - s);
3105         if (t)
3106             t++;
3107         else
3108             t = send;
3109
3110         sv_setpvn(tmpstr, s, t - s);
3111         av_store(array, line++, tmpstr);
3112         s = t;
3113     }
3114 }
3115
3116 /*
3117 =for apidoc docatch
3118
3119 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3120
3121 0 is used as continue inside eval,
3122
3123 3 is used for a die caught by an inner eval - continue inner loop
3124
3125 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3126 establish a local jmpenv to handle exception traps.
3127
3128 =cut
3129 */
3130 STATIC OP *
3131 S_docatch(pTHX_ OP *o)
3132 {
3133     int ret;
3134     OP * const oldop = PL_op;
3135     dJMPENV;
3136
3137 #ifdef DEBUGGING
3138     assert(CATCH_GET == TRUE);
3139 #endif
3140     PL_op = o;
3141
3142     JMPENV_PUSH(ret);
3143     switch (ret) {
3144     case 0:
3145         assert(cxstack_ix >= 0);
3146         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3147         CX_CUR()->blk_eval.cur_top_env = PL_top_env;
3148  redo_body:
3149         CALLRUNOPS(aTHX);
3150         break;
3151     case 3:
3152         /* die caught by an inner eval - continue inner loop */
3153         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3154             PL_restartjmpenv = NULL;
3155             PL_op = PL_restartop;
3156             PL_restartop = 0;
3157             goto redo_body;
3158         }
3159         /* FALLTHROUGH */
3160     default:
3161         JMPENV_POP;
3162         PL_op = oldop;
3163         JMPENV_JUMP(ret);
3164         NOT_REACHED; /* NOTREACHED */
3165     }
3166     JMPENV_POP;
3167     PL_op = oldop;
3168     return NULL;
3169 }
3170
3171
3172 /*
3173 =for apidoc find_runcv
3174
3175 Locate the CV corresponding to the currently executing sub or eval.
3176 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3177 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3178 entered.  (This allows debuggers to eval in the scope of the breakpoint
3179 rather than in the scope of the debugger itself.)
3180
3181 =cut
3182 */
3183
3184 CV*
3185 Perl_find_runcv(pTHX_ U32 *db_seqp)
3186 {
3187     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3188 }
3189
3190 /* If this becomes part of the API, it might need a better name. */
3191 CV *
3192 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3193 {
3194     PERL_SI      *si;
3195     int          level = 0;
3196
3197     if (db_seqp)
3198         *db_seqp =
3199             PL_curcop == &PL_compiling
3200                 ? PL_cop_seqmax
3201                 : PL_curcop->cop_seq;
3202
3203     for (si = PL_curstackinfo; si; si = si->si_prev) {
3204         I32 ix;
3205         for (ix = si->si_cxix; ix >= 0; ix--) {
3206             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3207             CV *cv = NULL;
3208             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3209                 cv = cx->blk_sub.cv;
3210                 /* skip DB:: code */
3211                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3212                     *db_seqp = cx->blk_oldcop->cop_seq;
3213                     continue;
3214                 }
3215                 if (cx->cx_type & CXp_SUB_RE)
3216                     continue;
3217             }
3218             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3219                 cv = cx->blk_eval.cv;
3220             if (cv) {
3221                 switch (cond) {
3222                 case FIND_RUNCV_padid_eq:
3223                     if (!CvPADLIST(cv)
3224                      || CvPADLIST(cv)->xpadl_id != (U32)arg)
3225                         continue;
3226                     return cv;
3227                 case FIND_RUNCV_level_eq:
3228                     if (level++ != arg) continue;
3229                     /* GERONIMO! */
3230                 default:
3231                     return cv;
3232                 }
3233             }
3234         }
3235     }
3236     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3237 }
3238
3239
3240 /* Run yyparse() in a setjmp wrapper. Returns:
3241  *   0: yyparse() successful
3242  *   1: yyparse() failed
3243  *   3: yyparse() died
3244  */
3245 STATIC int
3246 S_try_yyparse(pTHX_ int gramtype)
3247 {
3248     int ret;
3249     dJMPENV;
3250
3251     assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3252     JMPENV_PUSH(ret);
3253     switch (ret) {
3254     case 0:
3255         ret = yyparse(gramtype) ? 1 : 0;
3256         break;
3257     case 3:
3258         break;
3259     default:
3260         JMPENV_POP;
3261         JMPENV_JUMP(ret);
3262         NOT_REACHED; /* NOTREACHED */
3263     }
3264     JMPENV_POP;
3265     return ret;
3266 }
3267
3268
3269 /* Compile a require/do or an eval ''.
3270  *
3271  * outside is the lexically enclosing CV (if any) that invoked us.
3272  * seq     is the current COP scope value.
3273  * hh      is the saved hints hash, if any.
3274  *
3275  * Returns a bool indicating whether the compile was successful; if so,
3276  * PL_eval_start contains the first op of the compiled code; otherwise,
3277  * pushes undef.
3278  *
3279  * This function is called from two places: pp_require and pp_entereval.
3280  * These can be distinguished by whether PL_op is entereval.
3281  */
3282
3283 STATIC bool
3284 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3285 {
3286     dSP;
3287     OP * const saveop = PL_op;
3288     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3289     COP * const oldcurcop = PL_curcop;
3290     bool in_require = (saveop->op_type == OP_REQUIRE);
3291     int yystatus;
3292     CV *evalcv;
3293
3294     PL_in_eval = (in_require
3295                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3296                   : (EVAL_INEVAL |
3297                         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3298                             ? EVAL_RE_REPARSING : 0)));
3299
3300     PUSHMARK(SP);
3301
3302     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3303     CvEVAL_on(evalcv);
3304     assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3305     CX_CUR()->blk_eval.cv = evalcv;
3306     CX_CUR()->blk_gimme = gimme;
3307
3308     CvOUTSIDE_SEQ(evalcv) = seq;
3309     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3310
3311     /* set up a scratch pad */
3312
3313     CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3314     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3315
3316
3317     SAVEMORTALIZESV(evalcv);    /* must remain until end of current statement */
3318
3319     /* make sure we compile in the right package */
3320
3321     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3322         SAVEGENERICSV(PL_curstash);
3323         PL_curstash = (HV *)CopSTASH(PL_curcop);
3324         if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3325         else SvREFCNT_inc_simple_void(PL_curstash);
3326     }
3327     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3328     SAVESPTR(PL_beginav);
3329     PL_beginav = newAV();
3330     SAVEFREESV(PL_beginav);
3331     SAVESPTR(PL_unitcheckav);
3332     PL_unitcheckav = newAV();
3333     SAVEFREESV(PL_unitcheckav);
3334
3335
3336     ENTER_with_name("evalcomp");
3337     SAVESPTR(PL_compcv);
3338     PL_compcv = evalcv;
3339
3340     /* try to compile it */
3341
3342     PL_eval_root = NULL;
3343     PL_curcop = &PL_compiling;
3344     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3345         PL_in_eval |= EVAL_KEEPERR;
3346     else
3347         CLEAR_ERRSV();
3348
3349     SAVEHINTS();
3350     if (clear_hints) {
3351         PL_hints = 0;
3352         hv_clear(GvHV(PL_hintgv));
3353     }
3354     else {
3355         PL_hints = saveop->op_private & OPpEVAL_COPHH
3356                      ? oldcurcop->cop_hints : saveop->op_targ;
3357
3358         /* making 'use re eval' not be in scope when compiling the
3359          * qr/mabye_has_runtime_code_block/ ensures that we don't get
3360          * infinite recursion when S_has_runtime_code() gives a false
3361          * positive: the second time round, HINT_RE_EVAL isn't set so we
3362          * don't bother calling S_has_runtime_code() */
3363         if (PL_in_eval & EVAL_RE_REPARSING)
3364             PL_hints &= ~HINT_RE_EVAL;
3365
3366         if (hh) {
3367             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3368             SvREFCNT_dec(GvHV(PL_hintgv));
3369             GvHV(PL_hintgv) = hh;
3370         }
3371     }
3372     SAVECOMPILEWARNINGS();
3373     if (clear_hints) {
3374         if (PL_dowarn & G_WARN_ALL_ON)
3375             PL_compiling.cop_warnings = pWARN_ALL ;
3376         else if (PL_dowarn & G_WARN_ALL_OFF)
3377             PL_compiling.cop_warnings = pWARN_NONE ;
3378         else
3379             PL_compiling.cop_warnings = pWARN_STD ;
3380     }
3381     else {
3382         PL_compiling.cop_warnings =
3383             DUP_WARNINGS(oldcurcop->cop_warnings);
3384         cophh_free(CopHINTHASH_get(&PL_compiling));
3385         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3386             /* The label, if present, is the first entry on the chain. So rather
3387                than writing a blank label in front of it (which involves an
3388                allocation), just use the next entry in the chain.  */
3389             PL_compiling.cop_hints_hash
3390                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3391             /* Check the assumption that this removed the label.  */
3392             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3393         }
3394         else
3395             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3396     }
3397
3398     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3399
3400     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3401      * so honour CATCH_GET and trap it here if necessary */
3402
3403
3404     /* compile the code */
3405     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3406
3407     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3408         PERL_CONTEXT *cx;
3409         SV *errsv;
3410
3411         PL_op = saveop;
3412         /* note that if yystatus == 3, then the require/eval died during
3413          * compilation, so the EVAL CX block has already been popped, and
3414          * various vars restored */
3415         if (yystatus != 3) {
3416             if (PL_eval_root) {
3417                 op_free(PL_eval_root);
3418                 PL_eval_root = NULL;
3419             }
3420             SP = PL_stack_base + POPMARK;       /* pop original mark */
3421             cx = CX_CUR();
3422             assert(CxTYPE(cx) == CXt_EVAL);
3423             /* pop the CXt_EVAL, and if was a require, croak */
3424             S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
3425         }
3426
3427         /* die_unwind() re-croaks when in require, having popped the
3428          * require EVAL context. So we should never catch a require
3429          * exception here */
3430         assert(!in_require);
3431
3432         errsv = ERRSV;
3433         if (!*(SvPV_nolen_const(errsv)))
3434             sv_setpvs(errsv, "Compilation error");
3435
3436         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3437         PUTBACK;
3438         return FALSE;
3439     }
3440
3441     /* Compilation successful. Now clean up */
3442
3443     LEAVE_with_name("evalcomp");
3444
3445     CopLINE_set(&PL_compiling, 0);
3446     SAVEFREEOP(PL_eval_root);
3447     cv_forget_slab(evalcv);
3448
3449     DEBUG_x(dump_eval());
3450
3451     /* Register with debugger: */
3452     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3453         CV * const cv = get_cvs("DB::postponed", 0);
3454         if (cv) {
3455             dSP;
3456             PUSHMARK(SP);
3457             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3458             PUTBACK;
3459             call_sv(MUTABLE_SV(cv), G_DISCARD);
3460         }
3461     }
3462
3463     if (PL_unitcheckav) {
3464         OP *es = PL_eval_start;
3465         call_list(PL_scopestack_ix, PL_unitcheckav);
3466         PL_eval_start = es;
3467     }
3468
3469     CvDEPTH(evalcv) = 1;
3470     SP = PL_stack_base + POPMARK;               /* pop original mark */
3471     PL_op = saveop;                     /* The caller may need it. */
3472     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3473
3474     PUTBACK;
3475     return TRUE;
3476 }
3477
3478
3479 STATIC PerlIO *
3480 S_check_type_and_open(pTHX_ SV *name)
3481 {
3482     Stat_t st;
3483     STRLEN len;
3484     PerlIO * retio;
3485     const char *p = SvPV_const(name, len);
3486     int st_rc;
3487
3488     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3489
3490     /* checking here captures a reasonable error message when
3491      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3492      * user gets a confusing message about looking for the .pmc file
3493      * rather than for the .pm file so do the check in S_doopen_pm when
3494      * PMC is on instead of here. S_doopen_pm calls this func.
3495      * This check prevents a \0 in @INC causing problems.
3496      */
3497 #ifdef PERL_DISABLE_PMC
3498     if (!IS_SAFE_PATHNAME(p, len, "require"))
3499         return NULL;
3500 #endif
3501
3502     /* on Win32 stat is expensive (it does an open() and close() twice and
3503        a couple other IO calls), the open will fail with a dir on its own with
3504        errno EACCES, so only do a stat to separate a dir from a real EACCES
3505        caused by user perms */
3506 #ifndef WIN32
3507     /* we use the value of errno later to see how stat() or open() failed.
3508      * We don't want it set if the stat succeeded but we still failed,
3509      * such as if the name exists, but is a directory */
3510     errno = 0;
3511
3512     st_rc = PerlLIO_stat(p, &st);
3513
3514     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3515         return NULL;
3516     }
3517 #endif
3518
3519     retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3520 #ifdef WIN32
3521     /* EACCES stops the INC search early in pp_require to implement
3522        feature RT #113422 */
3523     if(!retio && errno == EACCES) { /* exists but probably a directory */
3524         int eno;
3525         st_rc = PerlLIO_stat(p, &st);
3526         if (st_rc >= 0) {
3527             if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3528                 eno = 0;
3529             else
3530                 eno = EACCES;
3531             errno = eno;
3532         }
3533     }
3534 #endif
3535     return retio;
3536 }
3537
3538 #ifndef PERL_DISABLE_PMC
3539 STATIC PerlIO *
3540 S_doopen_pm(pTHX_ SV *name)
3541 {
3542     STRLEN namelen;
3543     const char *p = SvPV_const(name, namelen);
3544
3545     PERL_ARGS_ASSERT_DOOPEN_PM;
3546
3547     /* check the name before trying for the .pmc name to avoid the
3548      * warning referring to the .pmc which the user probably doesn't
3549      * know or care about
3550      */
3551     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3552         return NULL;
3553
3554     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3555         SV *const pmcsv = sv_newmortal();
3556         PerlIO * pmcio;
3557
3558         SvSetSV_nosteal(pmcsv,name);
3559         sv_catpvs(pmcsv, "c");
3560
3561         pmcio = check_type_and_open(pmcsv);
3562         if (pmcio)
3563             return pmcio;
3564     }
3565     return check_type_and_open(name);
3566 }
3567 #else
3568 #  define doopen_pm(name) check_type_and_open(name)
3569 #endif /* !PERL_DISABLE_PMC */
3570
3571 /* require doesn't search for absolute names, or when the name is
3572    explicitly relative the current directory */
3573 PERL_STATIC_INLINE bool
3574 S_path_is_searchable(const char *name)
3575 {
3576     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3577
3578     if (PERL_FILE_IS_ABSOLUTE(name)
3579 #ifdef WIN32
3580         || (*name == '.' && ((name[1] == '/' ||
3581                              (name[1] == '.' && name[2] == '/'))
3582                          || (name[1] == '\\' ||
3583                              ( name[1] == '.' && name[2] == '\\')))
3584             )
3585 #else
3586         || (*name == '.' && (name[1] == '/' ||
3587                              (name[1] == '.' && name[2] == '/')))
3588 #endif
3589          )
3590     {
3591         return FALSE;
3592     }
3593     else
3594         return TRUE;
3595 }
3596
3597
3598 /* implement 'require 5.010001' */
3599
3600 static OP *
3601 S_require_version(pTHX_ SV *sv)
3602 {
3603     dVAR; dSP;
3604
3605     sv = sv_2mortal(new_version(sv));
3606     if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3607         upg_version(PL_patchlevel, TRUE);
3608     if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3609         if ( vcmp(sv,PL_patchlevel) <= 0 )
3610             DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3611                 SVfARG(sv_2mortal(vnormal(sv))),
3612                 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3613             );
3614     }
3615     else {
3616         if ( vcmp(sv,PL_patchlevel) > 0 ) {
3617             I32 first = 0;
3618             AV *lav;
3619             SV * const req = SvRV(sv);
3620             SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3621
3622             /* get the left hand term */
3623             lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3624
3625             first  = SvIV(*av_fetch(lav,0,0));
3626             if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3627                 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3628                 || av_tindex(lav) > 1            /* FP with > 3 digits */
3629                 || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3630                ) {
3631                 DIE(aTHX_ "Perl %"SVf" required--this is only "
3632                     "%"SVf", stopped",
3633                     SVfARG(sv_2mortal(vnormal(req))),
3634                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3635                 );
3636             }
3637             else { /* probably 'use 5.10' or 'use 5.8' */
3638                 SV *hintsv;
3639                 I32 second = 0;
3640
3641                 if (av_tindex(lav)>=1)
3642                     second = SvIV(*av_fetch(lav,1,0));
3643
3644                 second /= second >= 600  ? 100 : 10;
3645                 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3646                                        (int)first, (int)second);
3647                 upg_version(hintsv, TRUE);
3648
3649                 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3650                     "--this is only %"SVf", stopped",
3651                     SVfARG(sv_2mortal(vnormal(req))),
3652                     SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3653                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3654                 );
3655             }
3656         }
3657     }
3658
3659     RETPUSHYES;
3660 }
3661
3662 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
3663  * The first form will have already been converted at compile time to
3664  * the second form */
3665
3666 static OP *
3667 S_require_file(pTHX_ SV *const sv)
3668 {
3669     dVAR; dSP;
3670
3671     PERL_CONTEXT *cx;
3672     const char *name;
3673     STRLEN len;
3674     char * unixname;
3675     STRLEN unixlen;
3676 #ifdef VMS
3677     int vms_unixname = 0;
3678     char *unixdir;
3679 #endif
3680     const char *tryname = NULL;
3681     SV *namesv = NULL;
3682     const U8 gimme = GIMME_V;
3683     int filter_has_file = 0;
3684     PerlIO *tryrsfp = NULL;
3685     SV *filter_cache = NULL;
3686     SV *filter_state = NULL;
3687     SV *filter_sub = NULL;
3688     SV *hook_sv = NULL;
3689     OP *op;
3690     int saved_errno;
3691     bool path_searchable;
3692     I32 old_savestack_ix;
3693
3694     if (!SvOK(sv))
3695         DIE(aTHX_ "Missing or undefined argument to require");
3696     name = SvPV_nomg_const(sv, len);
3697     if (!(name && len > 0 && *name))
3698         DIE(aTHX_ "Missing or undefined argument to require");
3699
3700     if (!IS_SAFE_PATHNAME(name, len, "require")) {
3701         DIE(aTHX_ "Can't locate %s:   %s",
3702             pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
3703                       NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3704             Strerror(ENOENT));
3705     }
3706     TAINT_PROPER("require");
3707
3708     path_searchable = path_is_searchable(name);
3709
3710 #ifdef VMS
3711     /* The key in the %ENV hash is in the syntax of file passed as the argument
3712      * usually this is in UNIX format, but sometimes in VMS format, which
3713      * can result in a module being pulled in more than once.
3714      * To prevent this, the key must be stored in UNIX format if the VMS
3715      * name can be translated to UNIX.
3716      */
3717     
3718     if ((unixname =
3719           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3720          != NULL) {
3721         unixlen = strlen(unixname);
3722         vms_unixname = 1;
3723     }
3724     else
3725 #endif
3726     {
3727         /* if not VMS or VMS name can not be translated to UNIX, pass it
3728          * through.
3729          */
3730         unixname = (char *) name;
3731         unixlen = len;
3732     }
3733     if (PL_op->op_type == OP_REQUIRE) {
3734         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3735                                           unixname, unixlen, 0);
3736         if ( svp ) {
3737             if (*svp != &PL_sv_undef)
3738                 RETPUSHYES;
3739             else
3740                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3741                             "Compilation failed in require", unixname);
3742         }
3743
3744         if (PL_op->op_flags & OPf_KIDS) {
3745             SVOP * const kid = (SVOP*)cUNOP->op_first;
3746
3747             if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3748                 /* require foo (or use foo) with a bareword.
3749                    Perl_load_module fakes up the identical optree, but its
3750                    arguments aren't restricted by the parser to real barewords.
3751                 */
3752                 const STRLEN package_len = len - 3;
3753                 const char slashdot[2] = {'/', '.'};
3754 #ifdef DOSISH
3755                 const char backslashdot[2] = {'\\', '.'};
3756 #endif
3757
3758                 /* Disallow *purported* barewords that map to absolute
3759                    filenames, filenames relative to the current or parent
3760                    directory, or (*nix) hidden filenames.  Also sanity check
3761                    that the generated filename ends .pm  */
3762                 if (!path_searchable || len < 3 || name[0] == '.'
3763                     || !memEQ(name + package_len, ".pm", 3))
3764                     DIE(aTHX_ "Bareword in require maps to disallowed filename \"%"SVf"\"", sv);
3765                 if (memchr(name, 0, package_len)) {
3766                     /* diag_listed_as: Bareword in require contains "%s" */
3767                     DIE(aTHX_ "Bareword in require contains \"\\0\"");
3768                 }
3769                 if (ninstr(name, name + package_len, slashdot,
3770                            slashdot + sizeof(slashdot))) {
3771                     /* diag_listed_as: Bareword in require contains "%s" */
3772                     DIE(aTHX_ "Bareword in require contains \"/.\"");
3773                 }
3774 #ifdef DOSISH
3775                 if (ninstr(name, name + package_len, backslashdot,
3776                            backslashdot + sizeof(backslashdot))) {
3777                     /* diag_listed_as: Bareword in require contains "%s" */
3778                     DIE(aTHX_ "Bareword in require contains \"\\.\"");
3779                 }
3780 #endif
3781             }
3782         }
3783     }
3784
3785     PERL_DTRACE_PROBE_FILE_LOADING(unixname);
3786
3787     /* prepare to compile file */
3788
3789     if (!path_searchable) {
3790         /* At this point, name is SvPVX(sv)  */
3791         tryname = name;
3792         tryrsfp = doopen_pm(sv);
3793     }
3794     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3795         AV * const ar = GvAVn(PL_incgv);
3796         SSize_t i;
3797 #ifdef VMS
3798         if (vms_unixname)
3799 #endif
3800         {
3801             SV *nsv = sv;
3802             namesv = newSV_type(SVt_PV);
3803             for (i = 0; i <= AvFILL(ar); i++) {
3804                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3805
3806                 SvGETMAGIC(dirsv);
3807                 if (SvROK(dirsv)) {
3808                     int count;
3809                     SV **svp;
3810                     SV *loader = dirsv;
3811
3812                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3813                         && !SvOBJECT(SvRV(loader)))
3814                     {
3815                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3816                         SvGETMAGIC(loader);
3817                     }
3818
3819                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3820                                    PTR2UV(SvRV(dirsv)), name);
3821                     tryname = SvPVX_const(namesv);
3822                     tryrsfp = NULL;
3823
3824                     if (SvPADTMP(nsv)) {
3825                         nsv = sv_newmortal();
3826                         SvSetSV_nosteal(nsv,sv);
3827                     }
3828
3829                     ENTER_with_name("call_INC");
3830                     SAVETMPS;
3831                     EXTEND(SP, 2);
3832
3833                     PUSHMARK(SP);
3834                     PUSHs(dirsv);
3835                     PUSHs(nsv);
3836                     PUTBACK;
3837                     if (SvGMAGICAL(loader)) {
3838                         SV *l = sv_newmortal();
3839                         sv_setsv_nomg(l, loader);
3840                         loader = l;
3841                     }
3842                     if (sv_isobject(loader))
3843                         count = call_method("INC", G_ARRAY);
3844                     else
3845                         count = call_sv(loader, G_ARRAY);
3846                     SPAGAIN;
3847
3848                     if (count > 0) {
3849                         int i = 0;
3850                         SV *arg;
3851
3852                         SP -= count - 1;
3853                         arg = SP[i++];
3854
3855                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3856                             && !isGV_with_GP(SvRV(arg))) {
3857                             filter_cache = SvRV(arg);
3858
3859                             if (i < count) {
3860                                 arg = SP[i++];
3861                             }
3862                         }
3863
3864                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3865                             arg = SvRV(arg);
3866                         }
3867
3868                         if (isGV_with_GP(arg)) {
3869                             IO * const io = GvIO((const GV *)arg);
3870
3871                             ++filter_has_file;
3872
3873                             if (io) {
3874                                 tryrsfp = IoIFP(io);
3875                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3876                                     PerlIO_close(IoOFP(io));
3877                                 }
3878                                 IoIFP(io) = NULL;
3879                                 IoOFP(io) = NULL;
3880                             }
3881
3882                             if (i < count) {
3883                                 arg = SP[i++];
3884                             }
3885                         }
3886
3887                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3888                             filter_sub = arg;
3889                             SvREFCNT_inc_simple_void_NN(filter_sub);
3890
3891                             if (i < count) {
3892                                 filter_state = SP[i];
3893                                 SvREFCNT_inc_simple_void(filter_state);
3894                             }
3895                         }
3896
3897                         if (!tryrsfp && (filter_cache || filter_sub)) {
3898                             tryrsfp = PerlIO_open(BIT_BUCKET,
3899                                                   PERL_SCRIPT_MODE);
3900                         }
3901                         SP--;
3902                     }
3903
3904                     /* FREETMPS may free our filter_cache */
3905                     SvREFCNT_inc_simple_void(filter_cache);
3906
3907                     PUTBACK;
3908                     FREETMPS;
3909                     LEAVE_with_name("call_INC");
3910
3911                     /* Now re-mortalize it. */
3912                     sv_2mortal(filter_cache);
3913
3914                     /* Adjust file name if the hook has set an %INC entry.
3915                        This needs to happen after the FREETMPS above.  */
3916                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3917                     if (svp)
3918                         tryname = SvPV_nolen_const(*svp);
3919
3920                     if (tryrsfp) {
3921                         hook_sv = dirsv;
3922                         break;
3923                     }
3924
3925                     filter_has_file = 0;
3926                     filter_cache = NULL;
3927                     if (filter_state) {
3928                         SvREFCNT_dec_NN(filter_state);
3929                         filter_state = NULL;
3930                     }
3931                     if (filter_sub) {
3932                         SvREFCNT_dec_NN(filter_sub);
3933                         filter_sub = NULL;
3934                     }
3935                 }
3936                 else {
3937                   if (path_searchable) {
3938                     const char *dir;
3939                     STRLEN dirlen;
3940
3941                     if (SvOK(dirsv)) {
3942                         dir = SvPV_nomg_const(dirsv, dirlen);
3943                     } else {
3944                         dir = "";
3945                         dirlen = 0;
3946                     }
3947
3948                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3949                         continue;
3950 #ifdef VMS
3951                     if ((unixdir =
3952                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3953                          == NULL)
3954                         continue;
3955                     sv_setpv(namesv, unixdir);
3956                     sv_catpv(namesv, unixname);
3957 #else
3958 #  ifdef __SYMBIAN32__
3959                     if (PL_origfilename[0] &&
3960                         PL_origfilename[1] == ':' &&
3961                         !(dir[0] && dir[1] == ':'))
3962                         Perl_sv_setpvf(aTHX_ namesv,
3963                                        "%c:%s\\%s",
3964                                        PL_origfilename[0],
3965                                        dir, name);
3966                     else
3967                         Perl_sv_setpvf(aTHX_ namesv,
3968                                        "%s\\%s",
3969                                        dir, name);
3970 #  else
3971                     /* The equivalent of                    
3972                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3973                        but without the need to parse the format string, or
3974                        call strlen on either pointer, and with the correct
3975                        allocation up front.  */
3976                     {
3977                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3978
3979                         memcpy(tmp, dir, dirlen);
3980                         tmp +=dirlen;
3981
3982                         /* Avoid '<dir>//<file>' */
3983                         if (!dirlen || *(tmp-1) != '/') {
3984                             *tmp++ = '/';
3985                         } else {
3986                             /* So SvCUR_set reports the correct length below */
3987                             dirlen--;
3988                         }
3989
3990                         /* name came from an SV, so it will have a '\0' at the
3991                            end that we can copy as part of this memcpy().  */
3992                         memcpy(tmp, name, len + 1);
3993
3994                         SvCUR_set(namesv, dirlen + len + 1);
3995                         SvPOK_on(namesv);
3996                     }
3997 #  endif
3998 #endif
3999                     TAINT_PROPER("require");
4000                     tryname = SvPVX_const(namesv);
4001                     tryrsfp = doopen_pm(namesv);
4002                     if (tryrsfp) {
4003                         if (tryname[0] == '.' && tryname[1] == '/') {
4004                             ++tryname;
4005                             while (*++tryname == '/') {}
4006                         }
4007                         break;
4008                     }
4009                     else if (errno == EMFILE || errno == EACCES) {
4010                         /* no point in trying other paths if out of handles;
4011                          * on the other hand, if we couldn't open one of the
4012                          * files, then going on with the search could lead to
4013                          * unexpected results; see perl #113422
4014                          */
4015                         break;
4016                     }
4017                   }
4018                 }
4019             }
4020         }
4021     }
4022     saved_errno = errno; /* sv_2mortal can realloc things */
4023     sv_2mortal(namesv);
4024     if (!tryrsfp) {
4025         if (PL_op->op_type == OP_REQUIRE) {
4026             if(saved_errno == EMFILE || saved_errno == EACCES) {
4027                 /* diag_listed_as: Can't locate %s */
4028                 DIE(aTHX_ "Can't locate %s:   %s: %s",
4029                     name, tryname, Strerror(saved_errno));
4030             } else {
4031                 if (namesv) {                   /* did we lookup @INC? */
4032                     AV * const ar = GvAVn(PL_incgv);
4033                     SSize_t i;
4034                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
4035                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4036                     for (i = 0; i <= AvFILL(ar); i++) {
4037                         sv_catpvs(inc, " ");
4038                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4039                     }
4040                     if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4041                         const char *c, *e = name + len - 3;
4042                         sv_catpv(msg, " (you may need to install the ");
4043                         for (c = name; c < e; c++) {
4044                             if (*c == '/') {
4045                                 sv_catpvs(msg, "::");
4046                             }
4047                             else {
4048                                 sv_catpvn(msg, c, 1);
4049                             }
4050                         }
4051                         sv_catpv(msg, " module)");
4052                     }
4053                     else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4054                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4055                     }
4056                     else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4057                         sv_catpv(msg, " (did you run h2ph?)");
4058                     }
4059
4060                     /* diag_listed_as: Can't locate %s */
4061                     DIE(aTHX_
4062                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4063                         name, msg, inc);
4064                 }
4065             }
4066             DIE(aTHX_ "Can't locate %s", name);
4067         }
4068
4069         CLEAR_ERRSV();
4070         RETPUSHUNDEF;
4071     }
4072     else
4073         SETERRNO(0, SS_NORMAL);
4074
4075     /* Assume success here to prevent recursive requirement. */
4076     /* name is never assigned to again, so len is still strlen(name)  */
4077     /* Check whether a hook in @INC has already filled %INC */
4078     if (!hook_sv) {
4079         (void)hv_store(GvHVn(PL_incgv),
4080                        unixname, unixlen, newSVpv(tryname,0),0);
4081     } else {
4082         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4083         if (!svp)
4084             (void)hv_store(GvHVn(PL_incgv),
4085                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4086     }
4087
4088     old_savestack_ix = PL_savestack_ix;
4089     SAVECOPFILE_FREE(&PL_compiling);
4090     CopFILE_set(&PL_compiling, tryname);
4091     lex_start(NULL, tryrsfp, 0);
4092
4093     if (filter_sub || filter_cache) {
4094         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4095            than hanging another SV from it. In turn, filter_add() optionally
4096            takes the SV to use as the filter (or creates a new SV if passed
4097            NULL), so simply pass in whatever value filter_cache has.  */
4098         SV * const fc = filter_cache ? newSV(0) : NULL;
4099         SV *datasv;
4100         if (fc) sv_copypv(fc, filter_cache);
4101         datasv = filter_add(S_run_user_filter, fc);
4102         IoLINES(datasv) = filter_has_file;
4103         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4104         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4105     }
4106
4107     /* switch to eval mode */
4108     cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4109     cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4110
4111     SAVECOPLINE(&PL_compiling);
4112     CopLINE_set(&PL_compiling, 0);
4113
4114     PUTBACK;
4115
4116     if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4117         op = DOCATCH(PL_eval_start);
4118     else
4119         op = PL_op->op_next;
4120
4121     PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4122
4123     return op;
4124 }
4125
4126
4127 /* also used for: pp_dofile() */
4128
4129 PP(pp_require)
4130 {
4131     dSP;
4132     SV *sv = POPs;
4133     SvGETMAGIC(sv);
4134     PUTBACK;
4135     return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4136         ? S_require_version(aTHX_ sv)
4137         : S_require_file(aTHX_ sv);
4138 }
4139
4140
4141 /* This is a op added to hold the hints hash for
4142    pp_entereval. The hash can be modified by the code
4143    being eval'ed, so we return a copy instead. */
4144
4145 PP(pp_hintseval)
4146 {
4147     dSP;
4148     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4149     RETURN;
4150 }
4151
4152
4153 PP(pp_entereval)
4154 {
4155     dSP;
4156     PERL_CONTEXT *cx;
4157     SV *sv;
4158     const U8 gimme = GIMME_V;
4159     const U32 was = PL_breakable_sub_gen;
4160     char tbuf[TYPE_DIGITS(long) + 12];
4161     bool saved_delete = FALSE;
4162     char *tmpbuf = tbuf;
4163     STRLEN len;
4164     CV* runcv;
4165     U32 seq, lex_flags = 0;
4166     HV *saved_hh = NULL;
4167     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4168     I32 old_savestack_ix;
4169
4170     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4171         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4172     }
4173     else if (PL_hints & HINT_LOCALIZE_HH || (
4174                 PL_op->op_private & OPpEVAL_COPHH
4175              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4176             )) {
4177         saved_hh = cop_hints_2hv(PL_curcop, 0);
4178         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4179     }
4180     sv = POPs;
4181     if (!SvPOK(sv)) {
4182         /* make sure we've got a plain PV (no overload etc) before testing
4183          * for taint. Making a copy here is probably overkill, but better
4184          * safe than sorry */
4185         STRLEN len;
4186         const char * const p = SvPV_const(sv, len);
4187
4188         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4189         lex_flags |= LEX_START_COPIED;
4190
4191         if (bytes && SvUTF8(sv))
4192             SvPVbyte_force(sv, len);
4193     }
4194     else if (bytes && SvUTF8(sv)) {
4195         /* Don't modify someone else's scalar */
4196         STRLEN len;
4197         sv = newSVsv(sv);
4198         (void)sv_2mortal(sv);
4199         SvPVbyte_force(sv,len);
4200         lex_flags |= LEX_START_COPIED;
4201     }
4202
4203     TAINT_IF(SvTAINTED(sv));
4204     TAINT_PROPER("eval");
4205
4206     old_savestack_ix = PL_savestack_ix;
4207
4208     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4209                            ? LEX_IGNORE_UTF8_HINTS
4210                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4211                         )
4212              );
4213
4214     /* switch to eval mode */
4215
4216     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4217         SV * const temp_sv = sv_newmortal();
4218         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4219                        (unsigned long)++PL_evalseq,
4220                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4221         tmpbuf = SvPVX(temp_sv);
4222         len = SvCUR(temp_sv);
4223     }
4224     else
4225         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4226     SAVECOPFILE_FREE(&PL_compiling);
4227     CopFILE_set(&PL_compiling, tmpbuf+2);
4228     SAVECOPLINE(&PL_compiling);
4229     CopLINE_set(&PL_compiling, 1);
4230     /* special case: an eval '' executed within the DB package gets lexically
4231      * placed in the first non-DB CV rather than the current CV - this
4232      * allows the debugger to execute code, find lexicals etc, in the
4233      * scope of the code being debugged. Passing &seq gets find_runcv
4234      * to do the dirty work for us */
4235     runcv = find_runcv(&seq);
4236
4237     cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
4238     cx_pusheval(cx, PL_op->op_next, NULL);
4239
4240     /* prepare to compile string */
4241
4242     if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4243         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4244     else {
4245         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4246            deleting the eval's FILEGV from the stash before gv_check() runs
4247            (i.e. before run-time proper). To work around the coredump that
4248            ensues, we always turn GvMULTI_on for any globals that were
4249            introduced within evals. See force_ident(). GSAR 96-10-12 */
4250         char *const safestr = savepvn(tmpbuf, len);
4251         SAVEDELETE(PL_defstash, safestr, len);
4252         saved_delete = TRUE;
4253     }
4254     
4255     PUTBACK;
4256
4257     if (doeval_compile(gimme, runcv, seq, saved_hh)) {
4258         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4259             ?  PERLDB_LINE_OR_SAVESRC
4260             :  PERLDB_SAVESRC_NOSUBS) {
4261             /* Retain the filegv we created.  */
4262         } else if (!saved_delete) {
4263             char *const safestr = savepvn(tmpbuf, len);
4264             SAVEDELETE(PL_defstash, safestr, len);
4265         }
4266         return DOCATCH(PL_eval_start);
4267     } else {
4268         /* We have already left the scope set up earlier thanks to the LEAVE
4269            in doeval_compile().  */
4270         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4271             ?  PERLDB_LINE_OR_SAVESRC
4272             :  PERLDB_SAVESRC_INVALID) {
4273             /* Retain the filegv we created.  */
4274         } else if (!saved_delete) {
4275             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4276         }
4277         return PL_op->op_next;
4278     }
4279 }
4280
4281
4282 /* also tail-called by pp_return */
4283
4284 PP(pp_leaveeval)
4285 {
4286     SV **oldsp;
4287     U8 gimme;
4288     PERL_CONTEXT *cx;
4289     OP *retop;
4290     int failed;
4291     CV *evalcv;
4292     bool keep;
4293
4294     PERL_ASYNC_CHECK();
4295
4296     cx = CX_CUR();
4297     assert(CxTYPE(cx) == CXt_EVAL);
4298
4299     oldsp = PL_stack_base + cx->blk_oldsp;
4300     gimme = cx->blk_gimme;
4301
4302     /* did require return a false value? */
4303     failed =    CxOLD_OP_TYPE(cx) == OP_REQUIRE
4304              && !(gimme == G_SCALAR
4305                     ? SvTRUE(*PL_stack_sp)
4306                     : PL_stack_sp > oldsp);
4307
4308     if (gimme == G_VOID)
4309         PL_stack_sp = oldsp;
4310     else
4311         leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4312
4313     /* the cx_popeval does a leavescope, which frees the optree associated
4314      * with eval, which if it frees the nextstate associated with
4315      * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
4316      * regex when running under 'use re Debug' because it needs PL_curcop
4317      * to get the current hints. So restore it early.
4318      */
4319     PL_curcop = cx->blk_oldcop;
4320
4321     /* grab this value before cx_popeval restores the old PL_in_eval */
4322     keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4323     retop = cx->blk_eval.retop;
4324     evalcv = cx->blk_eval.cv;
4325 #ifdef DEBUGGING
4326     assert(CvDEPTH(evalcv) == 1);
4327 #endif
4328     CvDEPTH(evalcv) = 0;
4329
4330     /* pop the CXt_EVAL, and if a require failed, croak */
4331     S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
4332
4333     if (!keep)
4334         CLEAR_ERRSV();
4335
4336     return retop;
4337 }
4338
4339 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4340    close to the related Perl_create_eval_scope.  */
4341 void
4342 Perl_delete_eval_scope(pTHX)
4343 {
4344     PERL_CONTEXT *cx;
4345         
4346     cx = CX_CUR();
4347     CX_LEAVE_SCOPE(cx);
4348     cx_popeval(cx);
4349     cx_popblock(cx);
4350     CX_POP(cx);
4351 }
4352
4353 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4354    also needed by Perl_fold_constants.  */
4355 void
4356 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
4357 {
4358     PERL_CONTEXT *cx;
4359     const U8 gimme = GIMME_V;
4360         
4361     cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
4362                     PL_stack_sp, PL_savestack_ix);
4363     cx_pusheval(cx, retop, NULL);
4364
4365     PL_in_eval = EVAL_INEVAL;
4366     if (flags & G_KEEPERR)
4367         PL_in_eval |= EVAL_KEEPERR;
4368     else
4369         CLEAR_ERRSV();
4370     if (flags & G_FAKINGEVAL) {
4371         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4372     }
4373 }
4374     
4375 PP(pp_entertry)
4376 {
4377     create_eval_scope(cLOGOP->op_other->op_next, 0);
4378     return DOCATCH(PL_op->op_next);
4379 }
4380
4381
4382 /* also tail-called by pp_return */
4383
4384 PP(pp_leavetry)
4385 {
4386     SV **oldsp;
4387     U8 gimme;
4388     PERL_CONTEXT *cx;
4389     OP *retop;
4390
4391     PERL_ASYNC_CHECK();
4392
4393     cx = CX_CUR();
4394     assert(CxTYPE(cx) == CXt_EVAL);
4395     oldsp = PL_stack_base + cx->blk_oldsp;
4396     gimme = cx->blk_gimme;
4397
4398     if (gimme == G_VOID)
4399         PL_stack_sp = oldsp;
4400     else
4401         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4402     CX_LEAVE_SCOPE(cx);
4403     cx_popeval(cx);
4404     cx_popblock(cx);
4405     retop = cx->blk_eval.retop;
4406     CX_POP(cx);
4407
4408     CLEAR_ERRSV();
4409     return retop;
4410 }
4411
4412 PP(pp_entergiven)
4413 {
4414     dSP;
4415     PERL_CONTEXT *cx;
4416     const U8 gimme = GIMME_V;
4417     SV *origsv = DEFSV;
4418     SV *newsv = POPs;
4419     
4420     assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4421     GvSV(PL_defgv) = SvREFCNT_inc(newsv);
4422
4423     cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
4424     cx_pushgiven(cx, origsv);
4425
4426     RETURN;
4427 }
4428
4429 PP(pp_leavegiven)
4430 {
4431     PERL_CONTEXT *cx;
4432     U8 gimme;
4433     SV **oldsp;
4434     PERL_UNUSED_CONTEXT;
4435
4436     cx = CX_CUR();
4437     assert(CxTYPE(cx) == CXt_GIVEN);
4438     oldsp = PL_stack_base + cx->blk_oldsp;
4439     gimme = cx->blk_gimme;
4440
4441     if (gimme == G_VOID)
4442         PL_stack_sp = oldsp;
4443     else
4444         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4445
4446     CX_LEAVE_SCOPE(cx);
4447     cx_popgiven(cx);
4448     cx_popblock(cx);
4449     CX_POP(cx);
4450
4451     return NORMAL;
4452 }
4453
4454 /* Helper routines used by pp_smartmatch */
4455 STATIC PMOP *
4456 S_make_matcher(pTHX_ REGEXP *re)
4457 {
4458     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4459
4460     PERL_ARGS_ASSERT_MAKE_MATCHER;
4461
4462     PM_SETRE(matcher, ReREFCNT_inc(re));
4463
4464     SAVEFREEOP((OP *) matcher);
4465     ENTER_with_name("matcher"); SAVETMPS;
4466     SAVEOP();
4467     return matcher;
4468 }
4469
4470 STATIC bool
4471 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4472 {
4473     dSP;
4474     bool result;
4475
4476     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4477     
4478     PL_op = (OP *) matcher;
4479     XPUSHs(sv);
4480     PUTBACK;
4481     (void) Perl_pp_match(aTHX);
4482     SPAGAIN;
4483     result = SvTRUEx(POPs);
4484     PUTBACK;
4485
4486     return result;
4487 }
4488
4489 STATIC void
4490 S_destroy_matcher(pTHX_ PMOP *matcher)
4491 {
4492     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4493     PERL_UNUSED_ARG(matcher);
4494
4495     FREETMPS;
4496     LEAVE_with_name("matcher");
4497 }
4498
4499 /* Do a smart match */
4500 PP(pp_smartmatch)
4501 {
4502     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4503     return do_smartmatch(NULL, NULL, 0);
4504 }
4505
4506 /* This version of do_smartmatch() implements the
4507  * table of smart matches that is found in perlsyn.
4508  */
4509 STATIC OP *
4510 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4511 {
4512     dSP;
4513     
4514     bool object_on_left = FALSE;
4515     SV *e = TOPs;       /* e is for 'expression' */
4516     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4517
4518     /* Take care only to invoke mg_get() once for each argument.
4519      * Currently we do this by copying the SV if it's magical. */
4520     if (d) {
4521         if (!copied && SvGMAGICAL(d))
4522             d = sv_mortalcopy(d);
4523     }
4524     else
4525         d = &PL_sv_undef;
4526
4527     assert(e);
4528     if (SvGMAGICAL(e))
4529         e = sv_mortalcopy(e);
4530
4531     /* First of all, handle overload magic of the rightmost argument */
4532     if (SvAMAGIC(e)) {
4533         SV * tmpsv;
4534         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4535         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4536
4537         tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4538         if (tmpsv) {
4539             SPAGAIN;
4540             (void)POPs;
4541             SETs(tmpsv);
4542             RETURN;
4543         }
4544         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4545     }
4546
4547     SP -= 2;    /* Pop the values */
4548     PUTBACK;
4549
4550     /* ~~ undef */
4551     if (!SvOK(e)) {
4552         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4553         if (SvOK(d))
4554             RETPUSHNO;
4555         else
4556             RETPUSHYES;
4557     }
4558
4559     if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4560         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4561         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4562     }
4563     if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4564         object_on_left = TRUE;
4565
4566     /* ~~ sub */
4567     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4568         I32 c;
4569         if (object_on_left) {
4570             goto sm_any_sub; /* Treat objects like scalars */
4571         }
4572         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4573             /* Test sub truth for each key */
4574             HE *he;
4575             bool andedresults = TRUE;
4576             HV *hv = (HV*) SvRV(d);
4577             I32 numkeys = hv_iterinit(hv);
4578             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4579             if (numkeys == 0)
4580                 RETPUSHYES;
4581             while ( (he = hv_iternext(hv)) ) {
4582                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4583                 ENTER_with_name("smartmatch_hash_key_test");
4584                 SAVETMPS;
4585                 PUSHMARK(SP);
4586                 PUSHs(hv_iterkeysv(he));
4587                 PUTBACK;
4588                 c = call_sv(e, G_SCALAR);
4589                 SPAGAIN;
4590                 if (c == 0)
4591                     andedresults = FALSE;
4592                 else
4593                     andedresults = SvTRUEx(POPs) && andedresults;
4594                 FREETMPS;
4595                 LEAVE_with_name("smartmatch_hash_key_test");
4596             }
4597             if (andedresults)
4598                 RETPUSHYES;
4599             else
4600                 RETPUSHNO;
4601         }
4602         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4603             /* Test sub truth for each element */
4604             SSize_t i;
4605             bool andedresults = TRUE;
4606             AV *av = (AV*) SvRV(d);
4607             const I32 len = av_tindex(av);
4608             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4609             if (len == -1)
4610                 RETPUSHYES;
4611             for (i = 0; i <= len; ++i) {
4612                 SV * const * const svp = av_fetch(av, i, FALSE);
4613                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4614                 ENTER_with_name("smartmatch_array_elem_test");
4615                 SAVETMPS;
4616                 PUSHMARK(SP);
4617                 if (svp)
4618                     PUSHs(*svp);
4619                 PUTBACK;
4620                 c = call_sv(e, G_SCALAR);
4621                 SPAGAIN;
4622                 if (c == 0)
4623                     andedresults = FALSE;
4624                 else
4625                     andedresults = SvTRUEx(POPs) && andedresults;
4626                 FREETMPS;
4627                 LEAVE_with_name("smartmatch_array_elem_test");
4628             }
4629             if (andedresults)
4630                 RETPUSHYES;
4631             else
4632                 RETPUSHNO;
4633         }
4634         else {
4635           sm_any_sub:
4636             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4637             ENTER_with_name("smartmatch_coderef");
4638             SAVETMPS;
4639             PUSHMARK(SP);
4640             PUSHs(d);
4641             PUTBACK;
4642             c = call_sv(e, G_SCALAR);
4643             SPAGAIN;
4644             if (c == 0)
4645                 PUSHs(&PL_sv_no);
4646             else if (SvTEMP(TOPs))
4647                 SvREFCNT_inc_void(TOPs);
4648             FREETMPS;
4649             LEAVE_with_name("smartmatch_coderef");
4650             RETURN;
4651         }
4652     }
4653     /* ~~ %hash */
4654     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4655         if (object_on_left) {
4656             goto sm_any_hash; /* Treat objects like scalars */
4657         }
4658         else if (!SvOK(d)) {
4659             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4660             RETPUSHNO;
4661         }
4662         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4663             /* Check that the key-sets are identical */
4664             HE *he;
4665             HV *other_hv = MUTABLE_HV(SvRV(d));
4666             bool tied;
4667             bool other_tied;
4668             U32 this_key_count  = 0,
4669                 other_key_count = 0;
4670             HV *hv = MUTABLE_HV(SvRV(e));
4671
4672             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4673             /* Tied hashes don't know how many keys they have. */
4674             tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4675             other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4676             if (!tied ) {
4677                 if(other_tied) {
4678                     /* swap HV sides */
4679                     HV * const temp = other_hv;
4680                     other_hv = hv;
4681                     hv = temp;
4682                     tied = TRUE;
4683                     other_tied = FALSE;
4684                 }
4685                 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4686                     RETPUSHNO;
4687             }
4688
4689             /* The hashes have the same number of keys, so it suffices
4690                to check that one is a subset of the other. */
4691             (void) hv_iterinit(hv);
4692             while ( (he = hv_iternext(hv)) ) {
4693                 SV *key = hv_iterkeysv(he);
4694
4695                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4696                 ++ this_key_count;
4697                 
4698                 if(!hv_exists_ent(other_hv, key, 0)) {
4699                     (void) hv_iterinit(hv);     /* reset iterator */
4700                     RETPUSHNO;
4701                 }
4702             }
4703             
4704             if (other_tied) {
4705                 (void) hv_iterinit(other_hv);
4706                 while ( hv_iternext(other_hv) )
4707                     ++other_key_count;
4708             }
4709             else
4710                 other_key_count = HvUSEDKEYS(other_hv);
4711             
4712             if (this_key_count != other_key_count)
4713                 RETPUSHNO;
4714             else
4715                 RETPUSHYES;
4716         }
4717         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4718             AV * const other_av = MUTABLE_AV(SvRV(d));
4719             const SSize_t other_len = av_tindex(other_av) + 1;
4720             SSize_t i;
4721             HV *hv = MUTABLE_HV(SvRV(e));
4722
4723             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4724             for (i = 0; i < other_len; ++i) {
4725                 SV ** const svp = av_fetch(other_av, i, FALSE);
4726                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4727                 if (svp) {      /* ??? When can this not happen? */
4728                     if (hv_exists_ent(hv, *svp, 0))
4729                         RETPUSHYES;
4730                 }
4731             }
4732             RETPUSHNO;
4733         }
4734         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4735             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4736           sm_regex_hash:
4737             {
4738                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4739                 HE *he;
4740                 HV *hv = MUTABLE_HV(SvRV(e));
4741
4742                 (void) hv_iterinit(hv);
4743                 while ( (he = hv_iternext(hv)) ) {
4744                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4745                     PUTBACK;
4746                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4747                         SPAGAIN;
4748                         (void) hv_iterinit(hv);
4749                         destroy_matcher(matcher);
4750                         RETPUSHYES;
4751                     }
4752                     SPAGAIN;
4753                 }
4754                 destroy_matcher(matcher);
4755                 RETPUSHNO;
4756             }
4757         }
4758         else {
4759           sm_any_hash:
4760             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4761             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4762                 RETPUSHYES;
4763             else
4764                 RETPUSHNO;
4765         }
4766     }
4767     /* ~~ @array */
4768     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4769         if (object_on_left) {
4770             goto sm_any_array; /* Treat objects like scalars */
4771         }
4772         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4773             AV * const other_av = MUTABLE_AV(SvRV(e));
4774             const SSize_t other_len = av_tindex(other_av) + 1;
4775             SSize_t i;
4776
4777             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4778             for (i = 0; i < other_len; ++i) {
4779                 SV ** const svp = av_fetch(other_av, i, FALSE);
4780
4781                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4782                 if (svp) {      /* ??? When can this not happen? */
4783                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4784                         RETPUSHYES;
4785                 }
4786             }
4787             RETPUSHNO;
4788         }
4789         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4790             AV *other_av = MUTABLE_AV(SvRV(d));
4791             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4792             if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4793                 RETPUSHNO;
4794             else {
4795                 SSize_t i;
4796                 const SSize_t other_len = av_tindex(other_av);
4797
4798                 if (NULL == seen_this) {
4799                     seen_this = newHV();
4800                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4801                 }
4802                 if (NULL == seen_other) {
4803                     seen_other = newHV();
4804                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4805                 }
4806                 for(i = 0; i <= other_len; ++i) {
4807                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4808                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4809
4810                     if (!this_elem || !other_elem) {
4811                         if ((this_elem && SvOK(*this_elem))
4812                                 || (other_elem && SvOK(*other_elem)))
4813                             RETPUSHNO;
4814                     }
4815                     else if (hv_exists_ent(seen_this,
4816                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4817                             hv_exists_ent(seen_other,
4818                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4819                     {
4820                         if (*this_elem != *other_elem)
4821                             RETPUSHNO;
4822                     }
4823                     else {
4824                         (void)hv_store_ent(seen_this,
4825                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4826                                 &PL_sv_undef, 0);
4827                         (void)hv_store_ent(seen_other,
4828                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4829                                 &PL_sv_undef, 0);
4830                         PUSHs(*other_elem);
4831                         PUSHs(*this_elem);
4832                         
4833                         PUTBACK;
4834                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4835                         (void) do_smartmatch(seen_this, seen_other, 0);
4836                         SPAGAIN;
4837                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4838                         
4839                         if (!SvTRUEx(POPs))
4840                             RETPUSHNO;
4841                     }
4842                 }
4843                 RETPUSHYES;
4844             }
4845         }
4846         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4847             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4848           sm_regex_array:
4849             {
4850                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4851                 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4852                 SSize_t i;
4853
4854                 for(i = 0; i <= this_len; ++i) {
4855                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4856                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4857                     PUTBACK;
4858                     if (svp && matcher_matches_sv(matcher, *svp)) {
4859                         SPAGAIN;
4860                         destroy_matcher(matcher);
4861                         RETPUSHYES;
4862                     }
4863                     SPAGAIN;
4864                 }
4865                 destroy_matcher(matcher);
4866                 RETPUSHNO;
4867             }
4868         }
4869         else if (!SvOK(d)) {
4870             /* undef ~~ array */
4871             const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4872             SSize_t i;
4873
4874             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4875             for (i = 0; i <= this_len; ++i) {
4876                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4877                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4878                 if (!svp || !SvOK(*svp))
4879                     RETPUSHYES;
4880             }
4881             RETPUSHNO;
4882         }
4883         else {
4884           sm_any_array:
4885             {
4886                 SSize_t i;
4887                 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4888
4889                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4890                 for (i = 0; i <= this_len; ++i) {
4891                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4892                     if (!svp)
4893                         continue;
4894
4895                     PUSHs(d);
4896                     PUSHs(*svp);
4897                     PUTBACK;
4898                     /* infinite recursion isn't supposed to happen here */
4899                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4900                     (void) do_smartmatch(NULL, NULL, 1);
4901                     SPAGAIN;
4902                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4903                     if (SvTRUEx(POPs))
4904                         RETPUSHYES;
4905                 }
4906                 RETPUSHNO;
4907             }
4908         }
4909     }
4910     /* ~~ qr// */
4911     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4912         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4913             SV *t = d; d = e; e = t;
4914             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4915             goto sm_regex_hash;
4916         }
4917         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4918             SV *t = d; d = e; e = t;
4919             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4920             goto sm_regex_array;
4921         }
4922         else {
4923             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4924             bool result;
4925
4926             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4927             PUTBACK;
4928             result = matcher_matches_sv(matcher, d);
4929             SPAGAIN;
4930             PUSHs(result ? &PL_sv_yes : &PL_sv_no);
4931             destroy_matcher(matcher);
4932             RETURN;
4933         }
4934     }
4935     /* ~~ scalar */
4936     /* See if there is overload magic on left */
4937     else if (object_on_left && SvAMAGIC(d)) {
4938         SV *tmpsv;
4939         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4940         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4941         PUSHs(d); PUSHs(e);
4942         PUTBACK;
4943         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4944         if (tmpsv) {
4945             SPAGAIN;
4946             (void)POPs;
4947             SETs(tmpsv);
4948             RETURN;
4949         }
4950         SP -= 2;
4951         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4952         goto sm_any_scalar;
4953     }
4954     else if (!SvOK(d)) {
4955         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4956         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4957         RETPUSHNO;
4958     }
4959     else
4960   sm_any_scalar:
4961     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4962         DEBUG_M(if (SvNIOK(e))
4963                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4964                 else
4965                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4966         );
4967         /* numeric comparison */
4968         PUSHs(d); PUSHs(e);
4969         PUTBACK;
4970         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4971             (void) Perl_pp_i_eq(aTHX);
4972         else
4973             (void) Perl_pp_eq(aTHX);
4974         SPAGAIN;
4975         if (SvTRUEx(POPs))
4976             RETPUSHYES;
4977         else
4978             RETPUSHNO;
4979     }
4980     
4981     /* As a last resort, use string comparison */
4982     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4983     PUSHs(d); PUSHs(e);
4984     PUTBACK;
4985     return Perl_pp_seq(aTHX);
4986 }
4987
4988 PP(pp_enterwhen)
4989 {
4990     dSP;
4991     PERL_CONTEXT *cx;
4992     const U8 gimme = GIMME_V;
4993
4994     /* This is essentially an optimization: if the match
4995        fails, we don't want to push a context and then
4996        pop it again right away, so we skip straight
4997        to the op that follows the leavewhen.
4998        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4999     */
5000     if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs))
5001         RETURNOP(cLOGOP->op_other->op_next);
5002
5003     cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
5004     cx_pushwhen(cx);
5005
5006     RETURN;
5007 }
5008
5009 PP(pp_leavewhen)
5010 {
5011     I32 cxix;
5012     PERL_CONTEXT *cx;
5013     U8 gimme;
5014     SV **oldsp;
5015
5016     cx = CX_CUR();
5017     assert(CxTYPE(cx) == CXt_WHEN);
5018     gimme = cx->blk_gimme;
5019
5020     cxix = dopoptogivenfor(cxstack_ix);
5021     if (cxix < 0)
5022         /* diag_listed_as: Can't "when" outside a topicalizer */
5023         DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5024                    PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5025
5026     oldsp = PL_stack_base + cx->blk_oldsp;
5027     if (gimme == G_VOID)
5028         PL_stack_sp = oldsp;
5029     else
5030         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5031
5032     /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
5033     assert(cxix < cxstack_ix);
5034     dounwind(cxix);
5035
5036     cx = &cxstack[cxix];
5037
5038     if (CxFOREACH(cx)) {
5039         /* emulate pp_next. Note that any stack(s) cleanup will be
5040          * done by the pp_unstack which op_nextop should point to */
5041         cx = CX_CUR();
5042         cx_topblock(cx);
5043         PL_curcop = cx->blk_oldcop;
5044         return cx->blk_loop.my_op->op_nextop;
5045     }
5046     else {
5047         PERL_ASYNC_CHECK();
5048         assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
5049         return cx->blk_givwhen.leave_op;
5050     }
5051 }
5052
5053 PP(pp_continue)
5054 {
5055     I32 cxix;
5056     PERL_CONTEXT *cx;
5057     OP *nextop;
5058     
5059     cxix = dopoptowhen(cxstack_ix); 
5060     if (cxix < 0)   
5061         DIE(aTHX_ "Can't \"continue\" outside a when block");
5062
5063     if (cxix < cxstack_ix)
5064         dounwind(cxix);
5065     
5066     cx = CX_CUR();
5067     assert(CxTYPE(cx) == CXt_WHEN);
5068     PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5069     CX_LEAVE_SCOPE(cx);
5070     cx_popwhen(cx);
5071     cx_popblock(cx);
5072     nextop = cx->blk_givwhen.leave_op->op_next;
5073     CX_POP(cx);
5074
5075     return nextop;
5076 }
5077
5078 PP(pp_break)
5079 {
5080     I32 cxix;
5081     PERL_CONTEXT *cx;
5082
5083     cxix = dopoptogivenfor(cxstack_ix);
5084     if (cxix < 0)
5085         DIE(aTHX_ "Can't \"break\" outside a given block");
5086
5087     cx = &cxstack[cxix];
5088     if (CxFOREACH(cx))
5089         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5090
5091     if (cxix < cxstack_ix)
5092         dounwind(cxix);
5093
5094     /* Restore the sp at the time we entered the given block */
5095     cx = CX_CUR();
5096     PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5097
5098     return cx->blk_givwhen.leave_op;
5099 }
5100
5101 static MAGIC *
5102 S_doparseform(pTHX_ SV *sv)
5103 {
5104     STRLEN len;
5105     char *s = SvPV(sv, len);
5106     char *send;
5107     char *base = NULL; /* start of current field */
5108     I32 skipspaces = 0; /* number of contiguous spaces seen */
5109     bool noblank   = FALSE; /* ~ or ~~ seen on this line */
5110     bool repeat    = FALSE; /* ~~ seen on this line */
5111     bool postspace = FALSE; /* a text field may need right padding */
5112     U32 *fops;
5113     U32 *fpc;
5114     U32 *linepc = NULL;     /* position of last FF_LINEMARK */
5115     I32 arg;
5116     bool ischop;            /* it's a ^ rather than a @ */
5117     bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5118     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5119     MAGIC *mg = NULL;
5120     SV *sv_copy;
5121
5122     PERL_ARGS_ASSERT_DOPARSEFORM;
5123
5124     if (len == 0)
5125         Perl_croak(aTHX_ "Null picture in formline");
5126
5127     if (SvTYPE(sv) >= SVt_PVMG) {
5128         /* This might, of course, still return NULL.  */
5129         mg = mg_find(sv, PERL_MAGIC_fm);
5130     } else {
5131         sv_upgrade(sv, SVt_PVMG);
5132     }
5133
5134     if (mg) {
5135         /* still the same as previously-compiled string? */
5136         SV *old = mg->mg_obj;
5137         if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5138               && len == SvCUR(old)
5139               && strnEQ(SvPVX(old), SvPVX(sv), len)
5140         ) {
5141             DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5142             return mg;
5143         }
5144
5145         DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5146         Safefree(mg->mg_ptr);
5147         mg->mg_ptr = NULL;
5148         SvREFCNT_dec(old);
5149         mg->mg_obj = NULL;
5150     }
5151     else {
5152         DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5153         mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5154     }
5155
5156     sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5157     s = SvPV(sv_copy, len); /* work on the copy, not the original */
5158     send = s + len;
5159
5160
5161     /* estimate the buffer size needed */
5162     for (base = s; s <= send; s++) {
5163         if (*s == '\n' || *s == '@' || *s == '^')
5164             maxops += 10;
5165     }
5166     s = base;
5167     base = NULL;
5168
5169     Newx(fops, maxops, U32);
5170     fpc = fops;
5171
5172     if (s < send) {
5173         linepc = fpc;
5174         *fpc++ = FF_LINEMARK;
5175         noblank = repeat = FALSE;
5176         base = s;
5177     }
5178
5179     while (s <= send) {
5180         switch (*s++) {
5181         default:
5182             skipspaces = 0;
5183             continue;
5184
5185         case '~':
5186             if (*s == '~') {
5187                 repeat = TRUE;
5188                 skipspaces++;
5189                 s++;
5190             }
5191             noblank = TRUE;
5192             /* FALLTHROUGH */
5193         case ' ': case '\t':
5194             skipspaces++;
5195             continue;
5196         case 0:
5197             if (s < send) {
5198                 skipspaces = 0;
5199                 continue;
5200             } /* else FALL THROUGH */
5201         case '\n':
5202             arg = s - base;
5203             skipspaces++;
5204             arg -= skipspaces;
5205             if (arg) {
5206                 if (postspace)
5207                     *fpc++ = FF_SPACE;
5208                 *fpc++ = FF_LITERAL;
5209                 *fpc++ = (U32)arg;
5210             }
5211             postspace = FALSE;
5212             if (s <= send)
5213                 skipspaces--;
5214             if (skipspaces) {
5215                 *fpc++ = FF_SKIP;
5216                 *fpc++ = (U32)skipspaces;
5217             }
5218             skipspaces = 0;
5219             if (s <= send)
5220                 *fpc++ = FF_NEWLINE;
5221             if (noblank) {
5222                 *fpc++ = FF_BLANK;
5223                 if (repeat)
5224                     arg = fpc - linepc + 1;
5225                 else
5226                     arg = 0;
5227                 *fpc++ = (U32)arg;
5228             }
5229             if (s < send) {
5230                 linepc = fpc;
5231                 *fpc++ = FF_LINEMARK;
5232                 noblank = repeat = FALSE;
5233                 base = s;
5234             }
5235             else
5236                 s++;
5237             continue;
5238
5239         case '@':
5240         case '^':
5241             ischop = s[-1] == '^';
5242
5243             if (postspace) {
5244                 *fpc++ = FF_SPACE;
5245                 postspace = FALSE;
5246             }
5247             arg = (s - base) - 1;
5248             if (arg) {
5249                 *fpc++ = FF_LITERAL;
5250                 *fpc++ = (U32)arg;
5251             }
5252
5253             base = s - 1;
5254             *fpc++ = FF_FETCH;
5255             if (*s == '*') { /*  @* or ^*  */
5256                 s++;
5257                 *fpc++ = 2;  /* skip the @* or ^* */
5258                 if (ischop) {
5259                     *fpc++ = FF_LINESNGL;
5260                     *fpc++ = FF_CHOP;
5261                 } else
5262                     *fpc++ = FF_LINEGLOB;
5263             }
5264             else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5265                 arg = ischop ? FORM_NUM_BLANK : 0;
5266                 base = s - 1;
5267                 while (*s == '#')
5268                     s++;
5269                 if (*s == '.') {
5270                     const char * const f = ++s;
5271                     while (*s == '#')
5272                         s++;
5273                     arg |= FORM_NUM_POINT + (s - f);
5274                 }
5275                 *fpc++ = s - base;              /* fieldsize for FETCH */
5276                 *fpc++ = FF_DECIMAL;
5277                 *fpc++ = (U32)arg;
5278                 unchopnum |= ! ischop;
5279             }
5280             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
5281                 arg = ischop ? FORM_NUM_BLANK : 0;
5282                 base = s - 1;
5283                 s++;                                /* skip the '0' first */
5284                 while (*s == '#')
5285                     s++;
5286                 if (*s == '.') {
5287                     const char * const f = ++s;
5288                     while (*s == '#')
5289                         s++;
5290                     arg |= FORM_NUM_POINT + (s - f);
5291                 }
5292                 *fpc++ = s - base;                /* fieldsize for FETCH */
5293                 *fpc++ = FF_0DECIMAL;
5294                 *fpc++ = (U32)arg;
5295                 unchopnum |= ! ischop;
5296             }
5297             else {                              /* text field */
5298                 I32 prespace = 0;
5299                 bool ismore = FALSE;
5300
5301                 if (*s == '>') {
5302                     while (*++s == '>') ;
5303                     prespace = FF_SPACE;
5304                 }
5305                 else if (*s == '|') {
5306                     while (*++s == '|') ;
5307                     prespace = FF_HALFSPACE;
5308                     postspace = TRUE;
5309                 }
5310                 else {
5311                     if (*s == '<')
5312                         while (*++s == '<') ;
5313                     postspace = TRUE;
5314                 }
5315                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5316                     s += 3;
5317                     ismore = TRUE;
5318                 }
5319                 *fpc++ = s - base;              /* fieldsize for FETCH */
5320
5321                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5322
5323                 if (prespace)
5324                     *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5325                 *fpc++ = FF_ITEM;
5326                 if (ismore)
5327                     *fpc++ = FF_MORE;
5328                 if (ischop)
5329                     *fpc++ = FF_CHOP;
5330             }
5331             base = s;
5332             skipspaces = 0;
5333             continue;
5334         }
5335     }
5336     *fpc++ = FF_END;
5337
5338     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5339     arg = fpc - fops;
5340
5341     mg->mg_ptr = (char *) fops;
5342     mg->mg_len = arg * sizeof(U32);
5343     mg->mg_obj = sv_copy;
5344     mg->mg_flags |= MGf_REFCOUNTED;
5345
5346     if (unchopnum && repeat)
5347         Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5348
5349     return mg;
5350 }
5351
5352
5353 STATIC bool
5354 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5355 {
5356     /* Can value be printed in fldsize chars, using %*.*f ? */
5357     NV pwr = 1;
5358     NV eps = 0.5;
5359     bool res = FALSE;
5360     int intsize = fldsize - (value < 0 ? 1 : 0);
5361
5362     if (frcsize & FORM_NUM_POINT)
5363         intsize--;
5364     frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5365     intsize -= frcsize;
5366
5367     while (intsize--) pwr *= 10.0;
5368     while (frcsize--) eps /= 10.0;
5369
5370     if( value >= 0 ){
5371         if (value + eps >= pwr)
5372             res = TRUE;
5373     } else {
5374         if (value - eps <= -pwr)
5375             res = TRUE;
5376     }
5377     return res;
5378 }
5379
5380 static I32
5381 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5382 {
5383     SV * const datasv = FILTER_DATA(idx);
5384     const int filter_has_file = IoLINES(datasv);
5385     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5386     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5387     int status = 0;
5388     SV *upstream;
5389     STRLEN got_len;
5390     char *got_p = NULL;
5391     char *prune_from = NULL;
5392     bool read_from_cache = FALSE;
5393     STRLEN umaxlen;
5394     SV *err = NULL;
5395
5396     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5397
5398     assert(maxlen >= 0);
5399     umaxlen = maxlen;
5400
5401     /* I was having segfault trouble under Linux 2.2.5 after a
5402        parse error occurred.  (Had to hack around it with a test
5403        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5404        not sure where the trouble is yet.  XXX */
5405
5406     {
5407         SV *const cache = datasv;
5408         if (SvOK(cache)) {
5409             STRLEN cache_len;
5410             const char *cache_p = SvPV(cache, cache_len);
5411             STRLEN take = 0;
5412
5413             if (umaxlen) {
5414                 /* Running in block mode and we have some cached data already.
5415                  */
5416                 if (cache_len >= umaxlen) {
5417                     /* In fact, so much data we don't even need to call
5418                        filter_read.  */
5419                     take = umaxlen;
5420                 }
5421             } else {
5422                 const char *const first_nl =
5423                     (const char *)memchr(cache_p, '\n', cache_len);
5424                 if (first_nl) {
5425                     take = first_nl + 1 - cache_p;
5426                 }
5427             }
5428             if (take) {
5429                 sv_catpvn(buf_sv, cache_p, take);
5430                 sv_chop(cache, cache_p + take);
5431                 /* Definitely not EOF  */
5432                 return 1;
5433             }
5434
5435             sv_catsv(buf_sv, cache);
5436             if (umaxlen) {
5437                 umaxlen -= cache_len;
5438             }
5439             SvOK_off(cache);
5440             read_from_cache = TRUE;
5441         }
5442     }
5443
5444     /* Filter API says that the filter appends to the contents of the buffer.
5445        Usually the buffer is "", so the details don't matter. But if it's not,
5446        then clearly what it contains is already filtered by this filter, so we
5447        don't want to pass it in a second time.
5448        I'm going to use a mortal in case the upstream filter croaks.  */
5449     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5450         ? sv_newmortal() : buf_sv;
5451     SvUPGRADE(upstream, SVt_PV);
5452         
5453     if (filter_has_file) {
5454         status = FILTER_READ(idx+1, upstream, 0);
5455     }
5456
5457     if (filter_sub && status >= 0) {
5458         dSP;
5459         int count;
5460
5461         ENTER_with_name("call_filter_sub");
5462         SAVE_DEFSV;
5463         SAVETMPS;
5464         EXTEND(SP, 2);
5465
5466         DEFSV_set(upstream);
5467         PUSHMARK(SP);
5468         mPUSHi(0);
5469         if (filter_state) {
5470             PUSHs(filter_state);
5471         }
5472         PUTBACK;
5473         count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5474         SPAGAIN;
5475
5476         if (count > 0) {
5477             SV *out = POPs;
5478             SvGETMAGIC(out);
5479             if (SvOK(out)) {
5480                 status = SvIV(out);
5481             }
5482             else {
5483                 SV * const errsv = ERRSV;
5484                 if (SvTRUE_NN(errsv))
5485                     err = newSVsv(errsv);
5486             }
5487         }
5488
5489         PUTBACK;
5490         FREETMPS;
5491         LEAVE_with_name("call_filter_sub");
5492     }
5493
5494     if (SvGMAGICAL(upstream)) {
5495         mg_get(upstream);
5496         if (upstream == buf_sv) mg_free(buf_sv);
5497     }
5498     if (SvIsCOW(upstream)) sv_force_normal(upstream);
5499     if(!err && SvOK(upstream)) {
5500         got_p = SvPV_nomg(upstream, got_len);
5501         if (umaxlen) {
5502             if (got_len > umaxlen) {
5503                 prune_from = got_p + umaxlen;
5504             }
5505         } else {
5506             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5507             if (first_nl && first_nl + 1 < got_p + got_len) {
5508                 /* There's a second line here... */
5509                 prune_from = first_nl + 1;
5510             }
5511         }
5512     }
5513     if (!err && prune_from) {
5514         /* Oh. Too long. Stuff some in our cache.  */
5515         STRLEN cached_len = got_p + got_len - prune_from;
5516         SV *const cache = datasv;
5517
5518         if (SvOK(cache)) {
5519             /* Cache should be empty.  */
5520             assert(!SvCUR(cache));
5521         }
5522
5523         sv_setpvn(cache, prune_from, cached_len);
5524         /* If you ask for block mode, you may well split UTF-8 characters.
5525            "If it breaks, you get to keep both parts"
5526            (Your code is broken if you  don't put them back together again
5527            before something notices.) */
5528         if (SvUTF8(upstream)) {
5529             SvUTF8_on(cache);
5530         }
5531         if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5532         else
5533             /* Cannot just use sv_setpvn, as that could free the buffer
5534                before we have a chance to assign it. */
5535             sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5536                       got_len - cached_len);
5537         *prune_from = 0;
5538         /* Can't yet be EOF  */
5539         if (status == 0)
5540             status = 1;
5541     }
5542
5543     /* If they are at EOF but buf_sv has something in it, then they may never
5544        have touched the SV upstream, so it may be undefined.  If we naively
5545        concatenate it then we get a warning about use of uninitialised value.
5546     */
5547     if (!err && upstream != buf_sv &&
5548         SvOK(upstream)) {
5549         sv_catsv_nomg(buf_sv, upstream);
5550     }
5551     else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5552
5553     if (status <= 0) {
5554         IoLINES(datasv) = 0;
5555         if (filter_state) {
5556             SvREFCNT_dec(filter_state);
5557             IoTOP_GV(datasv) = NULL;
5558         }
5559         if (filter_sub) {
5560             SvREFCNT_dec(filter_sub);
5561             IoBOTTOM_GV(datasv) = NULL;
5562         }
5563         filter_del(S_run_user_filter);
5564     }
5565
5566     if (err)
5567         croak_sv(err);
5568
5569     if (status == 0 && read_from_cache) {
5570         /* If we read some data from the cache (and by getting here it implies
5571            that we emptied the cache) then we aren't yet at EOF, and mustn't
5572            report that to our caller.  */
5573         return 1;
5574     }
5575     return status;
5576 }
5577
5578 /*
5579  * ex: set ts=8 sts=4 sw=4 et:
5580  */