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