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