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