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