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