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