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