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