Skip suid File::Copy tests on a nosuid partition
[perl.git] / pp_ctl.c
1 /*    pp_ctl.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *      Now far ahead the Road has gone,
13  *          And I must follow, if I can,
14  *      Pursuing it with eager feet,
15  *          Until it joins some larger way
16  *      Where many paths and errands meet.
17  *          And whither then?  I cannot say.
18  *
19  *     [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
20  */
21
22 /* This file contains control-oriented pp ("push/pop") functions that
23  * execute the opcodes that make up a perl program. A typical pp function
24  * expects to find its arguments on the stack, and usually pushes its
25  * results onto the stack, hence the 'pp' terminology. Each OP structure
26  * contains a pointer to the relevant pp_foo() function.
27  *
28  * Control-oriented means things like pp_enteriter() and pp_next(), which
29  * alter the flow of control of the program.
30  */
31
32
33 #include "EXTERN.h"
34 #define PERL_IN_PP_CTL_C
35 #include "perl.h"
36
37 #ifndef WORD_ALIGN
38 #define WORD_ALIGN sizeof(U32)
39 #endif
40
41 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
42
43 #define dopoptosub(plop)        dopoptosub_at(cxstack, (plop))
44
45 PP(pp_wantarray)
46 {
47     dVAR;
48     dSP;
49     I32 cxix;
50     EXTEND(SP, 1);
51
52     cxix = dopoptosub(cxstack_ix);
53     if (cxix < 0)
54         RETPUSHUNDEF;
55
56     switch (cxstack[cxix].blk_gimme) {
57     case G_ARRAY:
58         RETPUSHYES;
59     case G_SCALAR:
60         RETPUSHNO;
61     default:
62         RETPUSHUNDEF;
63     }
64 }
65
66 PP(pp_regcreset)
67 {
68     dVAR;
69     /* XXXX Should store the old value to allow for tie/overload - and
70        restore in regcomp, where marked with XXXX. */
71     PL_reginterp_cnt = 0;
72     TAINT_NOT;
73     return NORMAL;
74 }
75
76 PP(pp_regcomp)
77 {
78     dVAR;
79     dSP;
80     register PMOP *pm = (PMOP*)cLOGOP->op_other;
81     SV *tmpstr;
82     REGEXP *re = NULL;
83
84     /* prevent recompiling under /o and ithreads. */
85 #if defined(USE_ITHREADS)
86     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
87         if (PL_op->op_flags & OPf_STACKED) {
88             dMARK;
89             SP = MARK;
90         }
91         else
92             (void)POPs;
93         RETURN;
94     }
95 #endif
96
97 #define tryAMAGICregexp(rx)                     \
98     STMT_START {                                \
99         SvGETMAGIC(rx);                         \
100         if (SvROK(rx) && SvAMAGIC(rx)) {        \
101             SV *sv = AMG_CALLun(rx, regexp);    \
102             if (sv) {                           \
103                 if (SvROK(sv))                  \
104                     sv = SvRV(sv);              \
105                 if (SvTYPE(sv) != SVt_REGEXP)   \
106                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
107                 rx = sv;                        \
108             }                                   \
109         }                                       \
110     } STMT_END
111             
112
113     if (PL_op->op_flags & OPf_STACKED) {
114         /* multiple args; concatentate them */
115         dMARK; dORIGMARK;
116         tmpstr = PAD_SV(ARGTARG);
117         sv_setpvs(tmpstr, "");
118         while (++MARK <= SP) {
119             SV *msv = *MARK;
120             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             if(errno == EMFILE) {
3638                 /* diag_listed_as: Can't locate %s */
3639                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(errno));
3640             } else {
3641                 if (namesv) {                   /* did we lookup @INC? */
3642                     AV * const ar = GvAVn(PL_incgv);
3643                     I32 i;
3644                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
3645                     for (i = 0; i <= AvFILL(ar); i++) {
3646                         sv_catpvs(inc, " ");
3647                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
3648                     }
3649
3650                     /* diag_listed_as: Can't locate %s */
3651                     DIE(aTHX_
3652                         "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
3653                         name,
3654                         (memEQ(name + len - 2, ".h", 3)
3655                          ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
3656                         (memEQ(name + len - 3, ".ph", 4)
3657                          ? " (did you run h2ph?)" : ""),
3658                         inc
3659                         );
3660                 }
3661             }
3662             DIE(aTHX_ "Can't locate %s", name);
3663         }
3664
3665         RETPUSHUNDEF;
3666     }
3667     else
3668         SETERRNO(0, SS_NORMAL);
3669
3670     /* Assume success here to prevent recursive requirement. */
3671     /* name is never assigned to again, so len is still strlen(name)  */
3672     /* Check whether a hook in @INC has already filled %INC */
3673     if (!hook_sv) {
3674         (void)hv_store(GvHVn(PL_incgv),
3675                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3676     } else {
3677         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3678         if (!svp)
3679             (void)hv_store(GvHVn(PL_incgv),
3680                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3681     }
3682
3683     ENTER_with_name("eval");
3684     SAVETMPS;
3685     lex_start(NULL, tryrsfp, TRUE);
3686
3687     SAVEHINTS();
3688     PL_hints = 0;
3689     hv_clear(GvHV(PL_hintgv));
3690
3691     SAVECOMPILEWARNINGS();
3692     if (PL_dowarn & G_WARN_ALL_ON)
3693         PL_compiling.cop_warnings = pWARN_ALL ;
3694     else if (PL_dowarn & G_WARN_ALL_OFF)
3695         PL_compiling.cop_warnings = pWARN_NONE ;
3696     else
3697         PL_compiling.cop_warnings = pWARN_STD ;
3698
3699     if (filter_sub || filter_cache) {
3700         /* We can use the SvPV of the filter PVIO itself as our cache, rather
3701            than hanging another SV from it. In turn, filter_add() optionally
3702            takes the SV to use as the filter (or creates a new SV if passed
3703            NULL), so simply pass in whatever value filter_cache has.  */
3704         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3705         IoLINES(datasv) = filter_has_file;
3706         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3707         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3708     }
3709
3710     /* switch to eval mode */
3711     PUSHBLOCK(cx, CXt_EVAL, SP);
3712     PUSHEVAL(cx, name);
3713     cx->blk_eval.retop = PL_op->op_next;
3714
3715     SAVECOPLINE(&PL_compiling);
3716     CopLINE_set(&PL_compiling, 0);
3717
3718     PUTBACK;
3719
3720     /* Store and reset encoding. */
3721     encoding = PL_encoding;
3722     PL_encoding = NULL;
3723
3724     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3725         op = DOCATCH(PL_eval_start);
3726     else
3727         op = PL_op->op_next;
3728
3729     /* Restore encoding. */
3730     PL_encoding = encoding;
3731
3732     return op;
3733 }
3734
3735 /* This is a op added to hold the hints hash for
3736    pp_entereval. The hash can be modified by the code
3737    being eval'ed, so we return a copy instead. */
3738
3739 PP(pp_hintseval)
3740 {
3741     dVAR;
3742     dSP;
3743     mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3744     RETURN;
3745 }
3746
3747
3748 PP(pp_entereval)
3749 {
3750     dVAR; dSP;
3751     register PERL_CONTEXT *cx;
3752     SV *sv;
3753     const I32 gimme = GIMME_V;
3754     const U32 was = PL_breakable_sub_gen;
3755     char tbuf[TYPE_DIGITS(long) + 12];
3756     char *tmpbuf = tbuf;
3757     STRLEN len;
3758     CV* runcv;
3759     U32 seq;
3760     HV *saved_hh = NULL;
3761
3762     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3763         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3764     }
3765     sv = POPs;
3766
3767     TAINT_IF(SvTAINTED(sv));
3768     TAINT_PROPER("eval");
3769
3770     ENTER_with_name("eval");
3771     lex_start(sv, NULL, FALSE);
3772     SAVETMPS;
3773
3774     /* switch to eval mode */
3775
3776     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3777         SV * const temp_sv = sv_newmortal();
3778         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3779                        (unsigned long)++PL_evalseq,
3780                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3781         tmpbuf = SvPVX(temp_sv);
3782         len = SvCUR(temp_sv);
3783     }
3784     else
3785         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3786     SAVECOPFILE_FREE(&PL_compiling);
3787     CopFILE_set(&PL_compiling, tmpbuf+2);
3788     SAVECOPLINE(&PL_compiling);
3789     CopLINE_set(&PL_compiling, 1);
3790     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3791        deleting the eval's FILEGV from the stash before gv_check() runs
3792        (i.e. before run-time proper). To work around the coredump that
3793        ensues, we always turn GvMULTI_on for any globals that were
3794        introduced within evals. See force_ident(). GSAR 96-10-12 */
3795     SAVEHINTS();
3796     PL_hints = PL_op->op_targ;
3797     if (saved_hh) {
3798         /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3799         SvREFCNT_dec(GvHV(PL_hintgv));
3800         GvHV(PL_hintgv) = saved_hh;
3801     }
3802     SAVECOMPILEWARNINGS();
3803     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3804     if (PL_compiling.cop_hints_hash) {
3805         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3806     }
3807     if (Perl_fetch_cop_label(aTHX_ PL_curcop->cop_hints_hash, NULL, NULL)) {
3808         /* The label, if present, is the first entry on the chain. So rather
3809            than writing a blank label in front of it (which involves an
3810            allocation), just use the next entry in the chain.  */
3811         PL_compiling.cop_hints_hash
3812             = PL_curcop->cop_hints_hash->refcounted_he_next;
3813         /* Check the assumption that this removed the label.  */
3814         assert(Perl_fetch_cop_label(aTHX_ PL_compiling.cop_hints_hash, NULL,
3815                                     NULL) == NULL);
3816     }
3817     else
3818         PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3819     if (PL_compiling.cop_hints_hash) {
3820         HINTS_REFCNT_LOCK;
3821         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3822         HINTS_REFCNT_UNLOCK;
3823     }
3824     /* special case: an eval '' executed within the DB package gets lexically
3825      * placed in the first non-DB CV rather than the current CV - this
3826      * allows the debugger to execute code, find lexicals etc, in the
3827      * scope of the code being debugged. Passing &seq gets find_runcv
3828      * to do the dirty work for us */
3829     runcv = find_runcv(&seq);
3830
3831     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3832     PUSHEVAL(cx, 0);
3833     cx->blk_eval.retop = PL_op->op_next;
3834
3835     /* prepare to compile string */
3836
3837     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3838         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3839     PUTBACK;
3840
3841     if (doeval(gimme, NULL, runcv, seq)) {
3842         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3843             ? (PERLDB_LINE || PERLDB_SAVESRC)
3844             :  PERLDB_SAVESRC_NOSUBS) {
3845             /* Retain the filegv we created.  */
3846         } else {
3847             char *const safestr = savepvn(tmpbuf, len);
3848             SAVEDELETE(PL_defstash, safestr, len);
3849         }
3850         return DOCATCH(PL_eval_start);
3851     } else {
3852         /* We have already left the scope set up earler thanks to the LEAVE
3853            in doeval().  */
3854         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3855             ? (PERLDB_LINE || PERLDB_SAVESRC)
3856             :  PERLDB_SAVESRC_INVALID) {
3857             /* Retain the filegv we created.  */
3858         } else {
3859             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3860         }
3861         return PL_op->op_next;
3862     }
3863 }
3864
3865 PP(pp_leaveeval)
3866 {
3867     dVAR; dSP;
3868     register SV **mark;
3869     SV **newsp;
3870     PMOP *newpm;
3871     I32 gimme;
3872     register PERL_CONTEXT *cx;
3873     OP *retop;
3874     const U8 save_flags = PL_op -> op_flags;
3875     I32 optype;
3876     SV *namesv;
3877
3878     POPBLOCK(cx,newpm);
3879     POPEVAL(cx);
3880     namesv = cx->blk_eval.old_namesv;
3881     retop = cx->blk_eval.retop;
3882
3883     TAINT_NOT;
3884     if (gimme == G_VOID)
3885         MARK = newsp;
3886     else if (gimme == G_SCALAR) {
3887         MARK = newsp + 1;
3888         if (MARK <= SP) {
3889             if (SvFLAGS(TOPs) & SVs_TEMP)
3890                 *MARK = TOPs;
3891             else
3892                 *MARK = sv_mortalcopy(TOPs);
3893         }
3894         else {
3895             MEXTEND(mark,0);
3896             *MARK = &PL_sv_undef;
3897         }
3898         SP = MARK;
3899     }
3900     else {
3901         /* in case LEAVE wipes old return values */
3902         for (mark = newsp + 1; mark <= SP; mark++) {
3903             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3904                 *mark = sv_mortalcopy(*mark);
3905                 TAINT_NOT;      /* Each item is independent */
3906             }
3907         }
3908     }
3909     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3910
3911 #ifdef DEBUGGING
3912     assert(CvDEPTH(PL_compcv) == 1);
3913 #endif
3914     CvDEPTH(PL_compcv) = 0;
3915     lex_end();
3916
3917     if (optype == OP_REQUIRE &&
3918         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3919     {
3920         /* Unassume the success we assumed earlier. */
3921         (void)hv_delete(GvHVn(PL_incgv),
3922                         SvPVX_const(namesv), SvCUR(namesv),
3923                         G_DISCARD);
3924         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
3925                                SVfARG(namesv));
3926         /* die_unwind() did LEAVE, or we won't be here */
3927     }
3928     else {
3929         LEAVE_with_name("eval");
3930         if (!(save_flags & OPf_SPECIAL)) {
3931             CLEAR_ERRSV();
3932         }
3933     }
3934
3935     RETURNOP(retop);
3936 }
3937
3938 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3939    close to the related Perl_create_eval_scope.  */
3940 void
3941 Perl_delete_eval_scope(pTHX)
3942 {
3943     SV **newsp;
3944     PMOP *newpm;
3945     I32 gimme;
3946     register PERL_CONTEXT *cx;
3947     I32 optype;
3948         
3949     POPBLOCK(cx,newpm);
3950     POPEVAL(cx);
3951     PL_curpm = newpm;
3952     LEAVE_with_name("eval_scope");
3953     PERL_UNUSED_VAR(newsp);
3954     PERL_UNUSED_VAR(gimme);
3955     PERL_UNUSED_VAR(optype);
3956 }
3957
3958 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3959    also needed by Perl_fold_constants.  */
3960 PERL_CONTEXT *
3961 Perl_create_eval_scope(pTHX_ U32 flags)
3962 {
3963     PERL_CONTEXT *cx;
3964     const I32 gimme = GIMME_V;
3965         
3966     ENTER_with_name("eval_scope");
3967     SAVETMPS;
3968
3969     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3970     PUSHEVAL(cx, 0);
3971
3972     PL_in_eval = EVAL_INEVAL;
3973     if (flags & G_KEEPERR)
3974         PL_in_eval |= EVAL_KEEPERR;
3975     else
3976         CLEAR_ERRSV();
3977     if (flags & G_FAKINGEVAL) {
3978         PL_eval_root = PL_op; /* Only needed so that goto works right. */
3979     }
3980     return cx;
3981 }
3982     
3983 PP(pp_entertry)
3984 {
3985     dVAR;
3986     PERL_CONTEXT * const cx = create_eval_scope(0);
3987     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3988     return DOCATCH(PL_op->op_next);
3989 }
3990
3991 PP(pp_leavetry)
3992 {
3993     dVAR; dSP;
3994     SV **newsp;
3995     PMOP *newpm;
3996     I32 gimme;
3997     register PERL_CONTEXT *cx;
3998     I32 optype;
3999
4000     POPBLOCK(cx,newpm);
4001     POPEVAL(cx);
4002     PERL_UNUSED_VAR(optype);
4003
4004     TAINT_NOT;
4005     if (gimme == G_VOID)
4006         SP = newsp;
4007     else if (gimme == G_SCALAR) {
4008         register SV **mark;
4009         MARK = newsp + 1;
4010         if (MARK <= SP) {
4011             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4012                 *MARK = TOPs;
4013             else
4014                 *MARK = sv_mortalcopy(TOPs);
4015         }
4016         else {
4017             MEXTEND(mark,0);
4018             *MARK = &PL_sv_undef;
4019         }
4020         SP = MARK;
4021     }
4022     else {
4023         /* in case LEAVE wipes old return values */
4024         register SV **mark;
4025         for (mark = newsp + 1; mark <= SP; mark++) {
4026             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4027                 *mark = sv_mortalcopy(*mark);
4028                 TAINT_NOT;      /* Each item is independent */
4029             }
4030         }
4031     }
4032     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4033
4034     LEAVE_with_name("eval_scope");
4035     CLEAR_ERRSV();
4036     RETURN;
4037 }
4038
4039 PP(pp_entergiven)
4040 {
4041     dVAR; dSP;
4042     register PERL_CONTEXT *cx;
4043     const I32 gimme = GIMME_V;
4044     
4045     ENTER_with_name("given");
4046     SAVETMPS;
4047
4048     sv_setsv(PAD_SV(PL_op->op_targ), POPs);
4049
4050     PUSHBLOCK(cx, CXt_GIVEN, SP);
4051     PUSHGIVEN(cx);
4052
4053     RETURN;
4054 }
4055
4056 PP(pp_leavegiven)
4057 {
4058     dVAR; dSP;
4059     register PERL_CONTEXT *cx;
4060     I32 gimme;
4061     SV **newsp;
4062     PMOP *newpm;
4063     PERL_UNUSED_CONTEXT;
4064
4065     POPBLOCK(cx,newpm);
4066     assert(CxTYPE(cx) == CXt_GIVEN);
4067
4068     TAINT_NOT;
4069     if (gimme == G_VOID)
4070         SP = newsp;
4071     else if (gimme == G_SCALAR) {
4072         register SV **mark;
4073         MARK = newsp + 1;
4074         if (MARK <= SP) {
4075             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4076                 *MARK = TOPs;
4077             else
4078                 *MARK = sv_mortalcopy(TOPs);
4079         }
4080         else {
4081             MEXTEND(mark,0);
4082             *MARK = &PL_sv_undef;
4083         }
4084         SP = MARK;
4085     }
4086     else {
4087         /* in case LEAVE wipes old return values */
4088         register SV **mark;
4089         for (mark = newsp + 1; mark <= SP; mark++) {
4090             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4091                 *mark = sv_mortalcopy(*mark);
4092                 TAINT_NOT;      /* Each item is independent */
4093             }
4094         }
4095     }
4096     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4097
4098     LEAVE_with_name("given");
4099     RETURN;
4100 }
4101
4102 /* Helper routines used by pp_smartmatch */
4103 STATIC PMOP *
4104 S_make_matcher(pTHX_ REGEXP *re)
4105 {
4106     dVAR;
4107     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4108
4109     PERL_ARGS_ASSERT_MAKE_MATCHER;
4110
4111     PM_SETRE(matcher, ReREFCNT_inc(re));
4112
4113     SAVEFREEOP((OP *) matcher);
4114     ENTER_with_name("matcher"); SAVETMPS;
4115     SAVEOP();
4116     return matcher;
4117 }
4118
4119 STATIC bool
4120 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4121 {
4122     dVAR;
4123     dSP;
4124
4125     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4126     
4127     PL_op = (OP *) matcher;
4128     XPUSHs(sv);
4129     PUTBACK;
4130     (void) pp_match();
4131     SPAGAIN;
4132     return (SvTRUEx(POPs));
4133 }
4134
4135 STATIC void
4136 S_destroy_matcher(pTHX_ PMOP *matcher)
4137 {
4138     dVAR;
4139
4140     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4141     PERL_UNUSED_ARG(matcher);
4142
4143     FREETMPS;
4144     LEAVE_with_name("matcher");
4145 }
4146
4147 /* Do a smart match */
4148 PP(pp_smartmatch)
4149 {
4150     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4151     return do_smartmatch(NULL, NULL);
4152 }
4153
4154 /* This version of do_smartmatch() implements the
4155  * table of smart matches that is found in perlsyn.
4156  */
4157 STATIC OP *
4158 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4159 {
4160     dVAR;
4161     dSP;
4162     
4163     bool object_on_left = FALSE;
4164     SV *e = TOPs;       /* e is for 'expression' */
4165     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4166
4167     /* Take care only to invoke mg_get() once for each argument.
4168      * Currently we do this by copying the SV if it's magical. */
4169     if (d) {
4170         if (SvGMAGICAL(d))
4171             d = sv_mortalcopy(d);
4172     }
4173     else
4174         d = &PL_sv_undef;
4175
4176     assert(e);
4177     if (SvGMAGICAL(e))
4178         e = sv_mortalcopy(e);
4179
4180     /* First of all, handle overload magic of the rightmost argument */
4181     if (SvAMAGIC(e)) {
4182         SV * tmpsv;
4183         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4184         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4185
4186         tmpsv = amagic_call(d, e, smart_amg, 0);
4187         if (tmpsv) {
4188             SPAGAIN;
4189             (void)POPs;
4190             SETs(tmpsv);
4191             RETURN;
4192         }
4193         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4194     }
4195
4196     SP -= 2;    /* Pop the values */
4197
4198
4199     /* ~~ undef */
4200     if (!SvOK(e)) {
4201         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4202         if (SvOK(d))
4203             RETPUSHNO;
4204         else
4205             RETPUSHYES;
4206     }
4207
4208     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4209         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4210         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4211     }
4212     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4213         object_on_left = TRUE;
4214
4215     /* ~~ sub */
4216     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4217         I32 c;
4218         if (object_on_left) {
4219             goto sm_any_sub; /* Treat objects like scalars */
4220         }
4221         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4222             /* Test sub truth for each key */
4223             HE *he;
4224             bool andedresults = TRUE;
4225             HV *hv = (HV*) SvRV(d);
4226             I32 numkeys = hv_iterinit(hv);
4227             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4228             if (numkeys == 0)
4229                 RETPUSHYES;
4230             while ( (he = hv_iternext(hv)) ) {
4231                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4232                 ENTER_with_name("smartmatch_hash_key_test");
4233                 SAVETMPS;
4234                 PUSHMARK(SP);
4235                 PUSHs(hv_iterkeysv(he));
4236                 PUTBACK;
4237                 c = call_sv(e, G_SCALAR);
4238                 SPAGAIN;
4239                 if (c == 0)
4240                     andedresults = FALSE;
4241                 else
4242                     andedresults = SvTRUEx(POPs) && andedresults;
4243                 FREETMPS;
4244                 LEAVE_with_name("smartmatch_hash_key_test");
4245             }
4246             if (andedresults)
4247                 RETPUSHYES;
4248             else
4249                 RETPUSHNO;
4250         }
4251         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4252             /* Test sub truth for each element */
4253             I32 i;
4254             bool andedresults = TRUE;
4255             AV *av = (AV*) SvRV(d);
4256             const I32 len = av_len(av);
4257             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4258             if (len == -1)
4259                 RETPUSHYES;
4260             for (i = 0; i <= len; ++i) {
4261                 SV * const * const svp = av_fetch(av, i, FALSE);
4262                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4263                 ENTER_with_name("smartmatch_array_elem_test");
4264                 SAVETMPS;
4265                 PUSHMARK(SP);
4266                 if (svp)
4267                     PUSHs(*svp);
4268                 PUTBACK;
4269                 c = call_sv(e, G_SCALAR);
4270                 SPAGAIN;
4271                 if (c == 0)
4272                     andedresults = FALSE;
4273                 else
4274                     andedresults = SvTRUEx(POPs) && andedresults;
4275                 FREETMPS;
4276                 LEAVE_with_name("smartmatch_array_elem_test");
4277             }
4278             if (andedresults)
4279                 RETPUSHYES;
4280             else
4281                 RETPUSHNO;
4282         }
4283         else {
4284           sm_any_sub:
4285             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4286             ENTER_with_name("smartmatch_coderef");
4287             SAVETMPS;
4288             PUSHMARK(SP);
4289             PUSHs(d);
4290             PUTBACK;
4291             c = call_sv(e, G_SCALAR);
4292             SPAGAIN;
4293             if (c == 0)
4294                 PUSHs(&PL_sv_no);
4295             else if (SvTEMP(TOPs))
4296                 SvREFCNT_inc_void(TOPs);
4297             FREETMPS;
4298             LEAVE_with_name("smartmatch_coderef");
4299             RETURN;
4300         }
4301     }
4302     /* ~~ %hash */
4303     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4304         if (object_on_left) {
4305             goto sm_any_hash; /* Treat objects like scalars */
4306         }
4307         else if (!SvOK(d)) {
4308             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4309             RETPUSHNO;
4310         }
4311         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4312             /* Check that the key-sets are identical */
4313             HE *he;
4314             HV *other_hv = MUTABLE_HV(SvRV(d));
4315             bool tied = FALSE;
4316             bool other_tied = FALSE;
4317             U32 this_key_count  = 0,
4318                 other_key_count = 0;
4319             HV *hv = MUTABLE_HV(SvRV(e));
4320
4321             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4322             /* Tied hashes don't know how many keys they have. */
4323             if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4324                 tied = TRUE;
4325             }
4326             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4327                 HV * const temp = other_hv;
4328                 other_hv = hv;
4329                 hv = temp;
4330                 tied = TRUE;
4331             }
4332             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4333                 other_tied = TRUE;
4334             
4335             if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4336                 RETPUSHNO;
4337
4338             /* The hashes have the same number of keys, so it suffices
4339                to check that one is a subset of the other. */
4340             (void) hv_iterinit(hv);
4341             while ( (he = hv_iternext(hv)) ) {
4342                 SV *key = hv_iterkeysv(he);
4343
4344                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4345                 ++ this_key_count;
4346                 
4347                 if(!hv_exists_ent(other_hv, key, 0)) {
4348                     (void) hv_iterinit(hv);     /* reset iterator */
4349                     RETPUSHNO;
4350                 }
4351             }
4352             
4353             if (other_tied) {
4354                 (void) hv_iterinit(other_hv);
4355                 while ( hv_iternext(other_hv) )
4356                     ++other_key_count;
4357             }
4358             else
4359                 other_key_count = HvUSEDKEYS(other_hv);
4360             
4361             if (this_key_count != other_key_count)
4362                 RETPUSHNO;
4363             else
4364                 RETPUSHYES;
4365         }
4366         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4367             AV * const other_av = MUTABLE_AV(SvRV(d));
4368             const I32 other_len = av_len(other_av) + 1;
4369             I32 i;
4370             HV *hv = MUTABLE_HV(SvRV(e));
4371
4372             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4373             for (i = 0; i < other_len; ++i) {
4374                 SV ** const svp = av_fetch(other_av, i, FALSE);
4375                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4376                 if (svp) {      /* ??? When can this not happen? */
4377                     if (hv_exists_ent(hv, *svp, 0))
4378                         RETPUSHYES;
4379                 }
4380             }
4381             RETPUSHNO;
4382         }
4383         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4384             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4385           sm_regex_hash:
4386             {
4387                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4388                 HE *he;
4389                 HV *hv = MUTABLE_HV(SvRV(e));
4390
4391                 (void) hv_iterinit(hv);
4392                 while ( (he = hv_iternext(hv)) ) {
4393                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4394                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4395                         (void) hv_iterinit(hv);
4396                         destroy_matcher(matcher);
4397                         RETPUSHYES;
4398                     }
4399                 }
4400                 destroy_matcher(matcher);
4401                 RETPUSHNO;
4402             }
4403         }
4404         else {
4405           sm_any_hash:
4406             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4407             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4408                 RETPUSHYES;
4409             else
4410                 RETPUSHNO;
4411         }
4412     }
4413     /* ~~ @array */
4414     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4415         if (object_on_left) {
4416             goto sm_any_array; /* Treat objects like scalars */
4417         }
4418         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4419             AV * const other_av = MUTABLE_AV(SvRV(e));
4420             const I32 other_len = av_len(other_av) + 1;
4421             I32 i;
4422
4423             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4424             for (i = 0; i < other_len; ++i) {
4425                 SV ** const svp = av_fetch(other_av, i, FALSE);
4426
4427                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4428                 if (svp) {      /* ??? When can this not happen? */
4429                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4430                         RETPUSHYES;
4431                 }
4432             }
4433             RETPUSHNO;
4434         }
4435         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4436             AV *other_av = MUTABLE_AV(SvRV(d));
4437             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4438             if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4439                 RETPUSHNO;
4440             else {
4441                 I32 i;
4442                 const I32 other_len = av_len(other_av);
4443
4444                 if (NULL == seen_this) {
4445                     seen_this = newHV();
4446                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4447                 }
4448                 if (NULL == seen_other) {
4449                     seen_other = newHV();
4450                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4451                 }
4452                 for(i = 0; i <= other_len; ++i) {
4453                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4454                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4455
4456                     if (!this_elem || !other_elem) {
4457                         if ((this_elem && SvOK(*this_elem))
4458                                 || (other_elem && SvOK(*other_elem)))
4459                             RETPUSHNO;
4460                     }
4461                     else if (hv_exists_ent(seen_this,
4462                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4463                             hv_exists_ent(seen_other,
4464                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4465                     {
4466                         if (*this_elem != *other_elem)
4467                             RETPUSHNO;
4468                     }
4469                     else {
4470                         (void)hv_store_ent(seen_this,
4471                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4472                                 &PL_sv_undef, 0);
4473                         (void)hv_store_ent(seen_other,
4474                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4475                                 &PL_sv_undef, 0);
4476                         PUSHs(*other_elem);
4477                         PUSHs(*this_elem);
4478                         
4479                         PUTBACK;
4480                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4481                         (void) do_smartmatch(seen_this, seen_other);
4482                         SPAGAIN;
4483                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4484                         
4485                         if (!SvTRUEx(POPs))
4486                             RETPUSHNO;
4487                     }
4488                 }
4489                 RETPUSHYES;
4490             }
4491         }
4492         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4493             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4494           sm_regex_array:
4495             {
4496                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4497                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4498                 I32 i;
4499
4500                 for(i = 0; i <= this_len; ++i) {
4501                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4502                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4503                     if (svp && matcher_matches_sv(matcher, *svp)) {
4504                         destroy_matcher(matcher);
4505                         RETPUSHYES;
4506                     }