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