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
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.
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.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
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.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
37 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
39 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
48 cxix = dopoptosub(cxstack_ix);
52 switch (cxstack[cxix].blk_gimme) {
65 /* XXXX Should store the old value to allow for tie/overload - and
66 restore in regcomp, where marked with XXXX. */
76 register PMOP *pm = (PMOP*)cLOGOP->op_other;
80 /* prevent recompiling under /o and ithreads. */
81 #if defined(USE_ITHREADS)
82 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
83 if (PL_op->op_flags & OPf_STACKED) {
93 #define tryAMAGICregexp(rx) \
96 if (SvROK(rx) && SvAMAGIC(rx)) { \
97 SV *sv = AMG_CALLunary(rx, regexp_amg); \
101 if (SvTYPE(sv) != SVt_REGEXP) \
102 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
109 if (PL_op->op_flags & OPf_STACKED) {
110 /* multiple args; concatenate them */
112 tmpstr = PAD_SV(ARGTARG);
113 sv_setpvs(tmpstr, "");
114 while (++MARK <= SP) {
118 tryAMAGICregexp(msv);
120 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
121 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
123 sv_setsv(tmpstr, sv);
126 sv_catsv_nomg(tmpstr, msv);
133 tryAMAGICregexp(tmpstr);
136 #undef tryAMAGICregexp
139 SV * const sv = SvRV(tmpstr);
140 if (SvTYPE(sv) == SVt_REGEXP)
143 else if (SvTYPE(tmpstr) == SVt_REGEXP)
144 re = (REGEXP*) tmpstr;
147 /* The match's LHS's get-magic might need to access this op's reg-
148 exp (as is sometimes the case with $'; see bug 70764). So we
149 must call get-magic now before we replace the regexp. Hopeful-
150 ly this hack can be replaced with the approach described at
151 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
152 /msg122415.html some day. */
153 if(pm->op_type == OP_MATCH) {
155 const bool was_tainted = PL_tainted;
156 if (pm->op_flags & OPf_STACKED)
158 else if (pm->op_private & OPpTARGET_MY)
159 lhs = PAD_SV(pm->op_targ);
162 /* Restore the previous value of PL_tainted (which may have been
163 modified by get-magic), to avoid incorrectly setting the
164 RXf_TAINTED flag further down. */
165 PL_tainted = was_tainted;
168 re = reg_temp_copy(NULL, re);
169 ReREFCNT_dec(PM_GETRE(pm));
174 const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
177 assert (re != (REGEXP*) &PL_sv_undef);
179 /* Check against the last compiled regexp. */
180 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
181 memNE(RX_PRECOMP(re), t, len))
183 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
184 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
188 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
190 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
192 } else if (PL_curcop->cop_hints_hash) {
193 SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
194 if (ptr && SvIOK(ptr) && SvIV(ptr))
195 eng = INT2PTR(regexp_engine*,SvIV(ptr));
198 if (PL_op->op_flags & OPf_SPECIAL)
199 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
201 if (DO_UTF8(tmpstr)) {
202 assert (SvUTF8(tmpstr));
203 } else if (SvUTF8(tmpstr)) {
204 /* Not doing UTF-8, despite what the SV says. Is this only if
205 we're trapped in use 'bytes'? */
206 /* Make a copy of the octet sequence, but without the flag on,
207 as the compiler now honours the SvUTF8 flag on tmpstr. */
209 const char *const p = SvPV(tmpstr, len);
210 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
212 else if (SvAMAGIC(tmpstr)) {
213 /* make a copy to avoid extra stringifies */
214 tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
217 /* If it is gmagical, create a mortal copy, but without calling
218 get-magic, as we have already done that. */
219 if(SvGMAGICAL(tmpstr)) {
220 SV *mortalcopy = sv_newmortal();
221 sv_setsv_flags(mortalcopy, tmpstr, 0);
226 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
228 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
230 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
231 inside tie/overload accessors. */
237 #ifndef INCOMPLETE_TAINTS
240 SvTAINTED_on((SV*)re);
241 RX_EXTFLAGS(re) |= RXf_TAINTED;
246 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
250 #if !defined(USE_ITHREADS)
251 /* can't change the optree at runtime either */
252 /* PMf_KEEP is handled differently under threads to avoid these problems */
253 if (pm->op_pmflags & PMf_KEEP) {
254 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
255 cLOGOP->op_first->op_next = PL_op->op_next;
265 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
266 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
267 register SV * const dstr = cx->sb_dstr;
268 register char *s = cx->sb_s;
269 register char *m = cx->sb_m;
270 char *orig = cx->sb_orig;
271 register REGEXP * const rx = cx->sb_rx;
273 REGEXP *old = PM_GETRE(pm);
280 PM_SETRE(pm,ReREFCNT_inc(rx));
283 rxres_restore(&cx->sb_rxres, rx);
284 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
286 if (cx->sb_iters++) {
287 const I32 saviters = cx->sb_iters;
288 if (cx->sb_iters > cx->sb_maxiters)
289 DIE(aTHX_ "Substitution loop");
291 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
293 /* See "how taint works" above pp_subst() */
295 cx->sb_rxtainted |= SUBST_TAINT_REPL;
296 sv_catsv_nomg(dstr, POPs);
297 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
301 if (CxONCE(cx) || s < orig ||
302 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
303 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
304 ((cx->sb_rflags & REXEC_COPY_STR)
305 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
306 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
308 SV * const targ = cx->sb_targ;
310 assert(cx->sb_strend >= s);
311 if(cx->sb_strend > s) {
312 if (DO_UTF8(dstr) && !SvUTF8(targ))
313 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
315 sv_catpvn(dstr, s, cx->sb_strend - s);
317 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
318 cx->sb_rxtainted |= SUBST_TAINT_PAT;
320 #ifdef PERL_OLD_COPY_ON_WRITE
322 sv_force_normal_flags(targ, SV_COW_DROP_PV);
328 SvPV_set(targ, SvPVX(dstr));
329 SvCUR_set(targ, SvCUR(dstr));
330 SvLEN_set(targ, SvLEN(dstr));
333 SvPV_set(dstr, NULL);
335 if (pm->op_pmflags & PMf_NONDESTRUCT)
338 mPUSHi(saviters - 1);
340 (void)SvPOK_only_UTF8(targ);
342 /* update the taint state of various various variables in
343 * preparation for final exit.
344 * See "how taint works" above pp_subst() */
346 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
347 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
348 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
350 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
352 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
353 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
355 SvTAINTED_on(TOPs); /* taint return value */
356 /* needed for mg_set below */
357 PL_tainted = cBOOL(cx->sb_rxtainted &
358 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
361 /* PL_tainted must be correctly set for this mg_set */
364 LEAVE_SCOPE(cx->sb_oldsave);
366 RETURNOP(pm->op_next);
369 cx->sb_iters = saviters;
371 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
374 cx->sb_orig = orig = RX_SUBBEG(rx);
376 cx->sb_strend = s + (cx->sb_strend - m);
378 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
380 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
381 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
383 sv_catpvn(dstr, s, m-s);
385 cx->sb_s = RX_OFFS(rx)[0].end + orig;
386 { /* Update the pos() information. */
387 SV * const sv = cx->sb_targ;
389 SvUPGRADE(sv, SVt_PVMG);
390 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
391 #ifdef PERL_OLD_COPY_ON_WRITE
393 sv_force_normal_flags(sv, 0);
395 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
398 mg->mg_len = m - orig;
401 (void)ReREFCNT_inc(rx);
402 /* update the taint state of various various variables in preparation
403 * for calling the code block.
404 * See "how taint works" above pp_subst() */
406 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
407 cx->sb_rxtainted |= SUBST_TAINT_PAT;
409 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
410 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
411 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
413 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
415 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
416 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
417 SvTAINTED_on(cx->sb_targ);
420 rxres_save(&cx->sb_rxres, rx);
422 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
426 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
431 PERL_ARGS_ASSERT_RXRES_SAVE;
434 if (!p || p[1] < RX_NPARENS(rx)) {
435 #ifdef PERL_OLD_COPY_ON_WRITE
436 i = 7 + RX_NPARENS(rx) * 2;
438 i = 6 + RX_NPARENS(rx) * 2;
447 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
448 RX_MATCH_COPIED_off(rx);
450 #ifdef PERL_OLD_COPY_ON_WRITE
451 *p++ = PTR2UV(RX_SAVED_COPY(rx));
452 RX_SAVED_COPY(rx) = NULL;
455 *p++ = RX_NPARENS(rx);
457 *p++ = PTR2UV(RX_SUBBEG(rx));
458 *p++ = (UV)RX_SUBLEN(rx);
459 for (i = 0; i <= RX_NPARENS(rx); ++i) {
460 *p++ = (UV)RX_OFFS(rx)[i].start;
461 *p++ = (UV)RX_OFFS(rx)[i].end;
466 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
471 PERL_ARGS_ASSERT_RXRES_RESTORE;
474 RX_MATCH_COPY_FREE(rx);
475 RX_MATCH_COPIED_set(rx, *p);
478 #ifdef PERL_OLD_COPY_ON_WRITE
479 if (RX_SAVED_COPY(rx))
480 SvREFCNT_dec (RX_SAVED_COPY(rx));
481 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
485 RX_NPARENS(rx) = *p++;
487 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
488 RX_SUBLEN(rx) = (I32)(*p++);
489 for (i = 0; i <= RX_NPARENS(rx); ++i) {
490 RX_OFFS(rx)[i].start = (I32)(*p++);
491 RX_OFFS(rx)[i].end = (I32)(*p++);
496 S_rxres_free(pTHX_ void **rsp)
498 UV * const p = (UV*)*rsp;
500 PERL_ARGS_ASSERT_RXRES_FREE;
505 void *tmp = INT2PTR(char*,*p);
508 PoisonFree(*p, 1, sizeof(*p));
510 Safefree(INT2PTR(char*,*p));
512 #ifdef PERL_OLD_COPY_ON_WRITE
514 SvREFCNT_dec (INT2PTR(SV*,p[1]));
524 dVAR; dSP; dMARK; dORIGMARK;
525 register SV * const tmpForm = *++MARK;
526 SV *formsv; /* contains text of original format */
527 register U32 *fpc; /* format ops program counter */
528 register char *t; /* current append position in target string */
529 const char *f; /* current position in format string */
531 register SV *sv = NULL; /* current item */
532 const char *item = NULL;/* string value of current item */
533 I32 itemsize = 0; /* length of current item, possibly truncated */
534 I32 fieldsize = 0; /* width of current field */
535 I32 lines = 0; /* number of lines that have been output */
536 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
537 const char *chophere = NULL; /* where to chop current item */
538 char *linemark = NULL; /* pos of start of line in output */
540 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
542 STRLEN fudge; /* estimate of output size in bytes */
543 bool item_is_utf8 = FALSE;
544 bool targ_is_utf8 = FALSE;
548 U8 *source; /* source of bytes to append */
549 STRLEN to_copy; /* how may bytes to append */
551 mg = doparseform(tmpForm);
553 fpc = (U32*)mg->mg_ptr;
554 /* the actual string the format was compiled from.
555 * with overload etc, this may not match tmpForm */
559 SvPV_force(PL_formtarget, len);
560 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
561 SvTAINTED_on(PL_formtarget);
562 if (DO_UTF8(PL_formtarget))
564 fudge = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
565 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
567 f = SvPV_const(formsv, len);
571 const char *name = "???";
574 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
575 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
576 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
577 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
578 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
580 case FF_CHECKNL: name = "CHECKNL"; break;
581 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
582 case FF_SPACE: name = "SPACE"; break;
583 case FF_HALFSPACE: name = "HALFSPACE"; break;
584 case FF_ITEM: name = "ITEM"; break;
585 case FF_CHOP: name = "CHOP"; break;
586 case FF_LINEGLOB: name = "LINEGLOB"; break;
587 case FF_NEWLINE: name = "NEWLINE"; break;
588 case FF_MORE: name = "MORE"; break;
589 case FF_LINEMARK: name = "LINEMARK"; break;
590 case FF_END: name = "END"; break;
591 case FF_0DECIMAL: name = "0DECIMAL"; break;
592 case FF_LINESNGL: name = "LINESNGL"; break;
595 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
597 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
608 if (targ_is_utf8 && !SvUTF8(formsv)) {
610 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
613 /* this is an unrolled sv_catpvn_utf8_upgrade(),
614 * but with the addition of s/~/ /g */
616 nsv = newSVpvn_flags(f, arg, SVs_TEMP);
618 sv_setpvn(nsv, f, arg);
620 for (s = SvPVX(nsv); s <= SvEND(nsv); s++)
623 sv_utf8_upgrade(nsv);
624 sv_catsv(PL_formtarget, nsv);
626 t = SvEND(PL_formtarget);
630 if (!targ_is_utf8 && DO_UTF8(formsv)) {
631 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
633 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
634 t = SvEND(PL_formtarget);
638 *t++ = (*f == '~') ? ' ' : *f;
656 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
659 SvTAINTED_on(PL_formtarget);
665 const char *s = item = SvPV_const(sv, len);
668 itemsize = sv_len_utf8(sv);
669 if (itemsize != (I32)len) {
671 if (itemsize > fieldsize) {
672 itemsize = fieldsize;
673 itembytes = itemsize;
674 sv_pos_u2b(sv, &itembytes, 0);
678 send = chophere = s + itembytes;
688 sv_pos_b2u(sv, &itemsize);
692 item_is_utf8 = FALSE;
693 if (itemsize > fieldsize)
694 itemsize = fieldsize;
695 send = chophere = s + itemsize;
709 const char *s = item = SvPV_const(sv, len);
712 itemsize = sv_len_utf8(sv);
713 if (itemsize != (I32)len) {
715 if (itemsize <= fieldsize) {
716 const char *send = chophere = s + itemsize;
729 itemsize = fieldsize;
730 itembytes = itemsize;
731 sv_pos_u2b(sv, &itembytes, 0);
732 send = chophere = s + itembytes;
733 while (s < send || (s == send && isSPACE(*s))) {
743 if (strchr(PL_chopset, *s))
748 itemsize = chophere - item;
749 sv_pos_b2u(sv, &itemsize);
755 item_is_utf8 = FALSE;
756 if (itemsize <= fieldsize) {
757 const char *const send = chophere = s + itemsize;
770 itemsize = fieldsize;
771 send = chophere = s + itemsize;
772 while (s < send || (s == send && isSPACE(*s))) {
782 if (strchr(PL_chopset, *s))
787 itemsize = chophere - item;
793 arg = fieldsize - itemsize;
802 arg = fieldsize - itemsize;
813 const char *s = item;
817 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
819 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
821 t = SvEND(PL_formtarget);
825 if (UTF8_IS_CONTINUED(*s)) {
826 STRLEN skip = UTF8SKIP(s);
843 if ( !((*t++ = *s++) & ~31) )
849 if (targ_is_utf8 && !item_is_utf8) {
850 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
852 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
853 for (; t < SvEND(PL_formtarget); t++) {
866 const int ch = *t++ = *s++;
869 if ( !((*t++ = *s++) & ~31) )
878 const char *s = chophere;
892 const bool oneline = fpc[-1] == FF_LINESNGL;
893 const char *s = item = SvPV_const(sv, len);
894 const char *const send = s + len;
896 item_is_utf8 = DO_UTF8(sv);
901 chophere = s + itemsize;
907 to_copy = s - SvPVX_const(sv) - 1;
923 if (targ_is_utf8 && !item_is_utf8) {
924 source = tmp = bytes_to_utf8(source, &to_copy);
925 SvCUR_set(PL_formtarget,
926 t - SvPVX_const(PL_formtarget));
928 if (item_is_utf8 && !targ_is_utf8) {
929 /* Upgrade targ to UTF8, and then we reduce it to
930 a problem we have a simple solution for. */
931 SvCUR_set(PL_formtarget,
932 t - SvPVX_const(PL_formtarget));
934 /* Don't need get magic. */
935 sv_utf8_upgrade_nomg(PL_formtarget);
937 SvCUR_set(PL_formtarget,
938 t - SvPVX_const(PL_formtarget));
941 /* Easy. They agree. */
942 assert (item_is_utf8 == targ_is_utf8);
944 SvGROW(PL_formtarget,
945 SvCUR(PL_formtarget) + to_copy + fudge + 1);
946 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
948 Copy(source, t, to_copy, char);
950 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
952 if (SvGMAGICAL(sv)) {
953 /* Mustn't call sv_pos_b2u() as it does a second
954 mg_get(). Is this a bug? Do we need a _flags()
956 itemsize = utf8_length(source, source + itemsize);
958 sv_pos_b2u(sv, &itemsize);
969 #if defined(USE_LONG_DOUBLE)
972 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
976 "%#0*.*f" : "%0*.*f");
981 #if defined(USE_LONG_DOUBLE)
983 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
986 ((arg & 256) ? "%#*.*f" : "%*.*f");
989 /* If the field is marked with ^ and the value is undefined,
991 if ((arg & 512) && !SvOK(sv)) {
999 /* overflow evidence */
1000 if (num_overflow(value, fieldsize, arg)) {
1006 /* Formats aren't yet marked for locales, so assume "yes". */
1008 STORE_NUMERIC_STANDARD_SET_LOCAL();
1009 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
1010 RESTORE_NUMERIC_STANDARD();
1017 while (t-- > linemark && *t == ' ') ;
1025 if (arg) { /* repeat until fields exhausted? */
1038 const char *s = chophere;
1039 const char *send = item + len;
1041 while (isSPACE(*s) && (s < send))
1046 arg = fieldsize - itemsize;
1053 if (strnEQ(s1," ",3)) {
1054 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
1066 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1068 SvUTF8_on(PL_formtarget);
1069 FmLINES(PL_formtarget) += lines;
1071 if (fpc[-1] == FF_BLANK)
1072 RETURNOP(cLISTOP->op_first);
1084 if (PL_stack_base + *PL_markstack_ptr == SP) {
1086 if (GIMME_V == G_SCALAR)
1088 RETURNOP(PL_op->op_next->op_next);
1090 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1091 Perl_pp_pushmark(aTHX); /* push dst */
1092 Perl_pp_pushmark(aTHX); /* push src */
1093 ENTER_with_name("grep"); /* enter outer scope */
1096 if (PL_op->op_private & OPpGREP_LEX)
1097 SAVESPTR(PAD_SVl(PL_op->op_targ));
1100 ENTER_with_name("grep_item"); /* enter inner scope */
1103 src = PL_stack_base[*PL_markstack_ptr];
1105 if (PL_op->op_private & OPpGREP_LEX)
1106 PAD_SVl(PL_op->op_targ) = src;
1111 if (PL_op->op_type == OP_MAPSTART)
1112 Perl_pp_pushmark(aTHX); /* push top */
1113 return ((LOGOP*)PL_op->op_next)->op_other;
1119 const I32 gimme = GIMME_V;
1120 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1126 /* first, move source pointer to the next item in the source list */
1127 ++PL_markstack_ptr[-1];
1129 /* if there are new items, push them into the destination list */
1130 if (items && gimme != G_VOID) {
1131 /* might need to make room back there first */
1132 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1133 /* XXX this implementation is very pessimal because the stack
1134 * is repeatedly extended for every set of items. Is possible
1135 * to do this without any stack extension or copying at all
1136 * by maintaining a separate list over which the map iterates
1137 * (like foreach does). --gsar */
1139 /* everything in the stack after the destination list moves
1140 * towards the end the stack by the amount of room needed */
1141 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1143 /* items to shift up (accounting for the moved source pointer) */
1144 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1146 /* This optimization is by Ben Tilly and it does
1147 * things differently from what Sarathy (gsar)
1148 * is describing. The downside of this optimization is
1149 * that leaves "holes" (uninitialized and hopefully unused areas)
1150 * to the Perl stack, but on the other hand this
1151 * shouldn't be a problem. If Sarathy's idea gets
1152 * implemented, this optimization should become
1153 * irrelevant. --jhi */
1155 shift = count; /* Avoid shifting too often --Ben Tilly */
1159 dst = (SP += shift);
1160 PL_markstack_ptr[-1] += shift;
1161 *PL_markstack_ptr += shift;
1165 /* copy the new items down to the destination list */
1166 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1167 if (gimme == G_ARRAY) {
1168 /* add returned items to the collection (making mortal copies
1169 * if necessary), then clear the current temps stack frame
1170 * *except* for those items. We do this splicing the items
1171 * into the start of the tmps frame (so some items may be on
1172 * the tmps stack twice), then moving PL_tmps_floor above
1173 * them, then freeing the frame. That way, the only tmps that
1174 * accumulate over iterations are the return values for map.
1175 * We have to do to this way so that everything gets correctly
1176 * freed if we die during the map.
1180 /* make space for the slice */
1181 EXTEND_MORTAL(items);
1182 tmpsbase = PL_tmps_floor + 1;
1183 Move(PL_tmps_stack + tmpsbase,
1184 PL_tmps_stack + tmpsbase + items,
1185 PL_tmps_ix - PL_tmps_floor,
1187 PL_tmps_ix += items;
1192 sv = sv_mortalcopy(sv);
1194 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1196 /* clear the stack frame except for the items */
1197 PL_tmps_floor += items;
1199 /* FREETMPS may have cleared the TEMP flag on some of the items */
1202 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1205 /* scalar context: we don't care about which values map returns
1206 * (we use undef here). And so we certainly don't want to do mortal
1207 * copies of meaningless values. */
1208 while (items-- > 0) {
1210 *dst-- = &PL_sv_undef;
1218 LEAVE_with_name("grep_item"); /* exit inner scope */
1221 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1223 (void)POPMARK; /* pop top */
1224 LEAVE_with_name("grep"); /* exit outer scope */
1225 (void)POPMARK; /* pop src */
1226 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1227 (void)POPMARK; /* pop dst */
1228 SP = PL_stack_base + POPMARK; /* pop original mark */
1229 if (gimme == G_SCALAR) {
1230 if (PL_op->op_private & OPpGREP_LEX) {
1231 SV* sv = sv_newmortal();
1232 sv_setiv(sv, items);
1240 else if (gimme == G_ARRAY)
1247 ENTER_with_name("grep_item"); /* enter inner scope */
1250 /* set $_ to the new source item */
1251 src = PL_stack_base[PL_markstack_ptr[-1]];
1253 if (PL_op->op_private & OPpGREP_LEX)
1254 PAD_SVl(PL_op->op_targ) = src;
1258 RETURNOP(cLOGOP->op_other);
1267 if (GIMME == G_ARRAY)
1269 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1270 return cLOGOP->op_other;
1280 if (GIMME == G_ARRAY) {
1281 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1285 SV * const targ = PAD_SV(PL_op->op_targ);
1288 if (PL_op->op_private & OPpFLIP_LINENUM) {
1289 if (GvIO(PL_last_in_gv)) {
1290 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1293 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1295 flip = SvIV(sv) == SvIV(GvSV(gv));
1301 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1302 if (PL_op->op_flags & OPf_SPECIAL) {
1310 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1313 sv_setpvs(TARG, "");
1319 /* This code tries to decide if "$left .. $right" should use the
1320 magical string increment, or if the range is numeric (we make
1321 an exception for .."0" [#18165]). AMS 20021031. */
1323 #define RANGE_IS_NUMERIC(left,right) ( \
1324 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1325 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1326 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1327 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1328 && (!SvOK(right) || looks_like_number(right))))
1334 if (GIMME == G_ARRAY) {
1340 if (RANGE_IS_NUMERIC(left,right)) {
1343 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1344 (SvOK(right) && SvNV(right) > IV_MAX))
1345 DIE(aTHX_ "Range iterator outside integer range");
1356 SV * const sv = sv_2mortal(newSViv(i++));
1361 SV * const final = sv_mortalcopy(right);
1363 const char * const tmps = SvPV_const(final, len);
1365 SV *sv = sv_mortalcopy(left);
1366 SvPV_force_nolen(sv);
1367 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1369 if (strEQ(SvPVX_const(sv),tmps))
1371 sv = sv_2mortal(newSVsv(sv));
1378 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1382 if (PL_op->op_private & OPpFLIP_LINENUM) {
1383 if (GvIO(PL_last_in_gv)) {
1384 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1387 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1388 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1396 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1397 sv_catpvs(targ, "E0");
1407 static const char * const context_name[] = {
1409 NULL, /* CXt_WHEN never actually needs "block" */
1410 NULL, /* CXt_BLOCK never actually needs "block" */
1411 NULL, /* CXt_GIVEN never actually needs "block" */
1412 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1413 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1414 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1415 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1423 S_dopoptolabel(pTHX_ const char *label)
1428 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1430 for (i = cxstack_ix; i >= 0; i--) {
1431 register const PERL_CONTEXT * const cx = &cxstack[i];
1432 switch (CxTYPE(cx)) {
1438 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1439 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1440 if (CxTYPE(cx) == CXt_NULL)
1443 case CXt_LOOP_LAZYIV:
1444 case CXt_LOOP_LAZYSV:
1446 case CXt_LOOP_PLAIN:
1448 const char *cx_label = CxLABEL(cx);
1449 if (!cx_label || strNE(label, cx_label) ) {
1450 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1451 (long)i, cx_label));
1454 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1465 Perl_dowantarray(pTHX)
1468 const I32 gimme = block_gimme();
1469 return (gimme == G_VOID) ? G_SCALAR : gimme;
1473 Perl_block_gimme(pTHX)
1476 const I32 cxix = dopoptosub(cxstack_ix);
1480 switch (cxstack[cxix].blk_gimme) {
1488 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1495 Perl_is_lvalue_sub(pTHX)
1498 const I32 cxix = dopoptosub(cxstack_ix);
1499 assert(cxix >= 0); /* We should only be called from inside subs */
1501 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1502 return CxLVAL(cxstack + cxix);
1508 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1513 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1515 for (i = startingblock; i >= 0; i--) {
1516 register const PERL_CONTEXT * const cx = &cxstk[i];
1517 switch (CxTYPE(cx)) {
1523 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1531 S_dopoptoeval(pTHX_ I32 startingblock)
1535 for (i = startingblock; i >= 0; i--) {
1536 register const PERL_CONTEXT *cx = &cxstack[i];
1537 switch (CxTYPE(cx)) {
1541 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1549 S_dopoptoloop(pTHX_ I32 startingblock)
1553 for (i = startingblock; i >= 0; i--) {
1554 register const PERL_CONTEXT * const cx = &cxstack[i];
1555 switch (CxTYPE(cx)) {
1561 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1562 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1563 if ((CxTYPE(cx)) == CXt_NULL)
1566 case CXt_LOOP_LAZYIV:
1567 case CXt_LOOP_LAZYSV:
1569 case CXt_LOOP_PLAIN:
1570 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1578 S_dopoptogiven(pTHX_ I32 startingblock)
1582 for (i = startingblock; i >= 0; i--) {
1583 register const PERL_CONTEXT *cx = &cxstack[i];
1584 switch (CxTYPE(cx)) {
1588 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1590 case CXt_LOOP_PLAIN:
1591 assert(!CxFOREACHDEF(cx));
1593 case CXt_LOOP_LAZYIV:
1594 case CXt_LOOP_LAZYSV:
1596 if (CxFOREACHDEF(cx)) {
1597 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1606 S_dopoptowhen(pTHX_ I32 startingblock)
1610 for (i = startingblock; i >= 0; i--) {
1611 register const PERL_CONTEXT *cx = &cxstack[i];
1612 switch (CxTYPE(cx)) {
1616 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1624 Perl_dounwind(pTHX_ I32 cxix)
1629 while (cxstack_ix > cxix) {
1631 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1632 DEBUG_CX("UNWIND"); \
1633 /* Note: we don't need to restore the base context info till the end. */
1634 switch (CxTYPE(cx)) {
1637 continue; /* not break */
1645 case CXt_LOOP_LAZYIV:
1646 case CXt_LOOP_LAZYSV:
1648 case CXt_LOOP_PLAIN:
1659 PERL_UNUSED_VAR(optype);
1663 Perl_qerror(pTHX_ SV *err)
1667 PERL_ARGS_ASSERT_QERROR;
1670 if (PL_in_eval & EVAL_KEEPERR) {
1671 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1672 SvPV_nolen_const(err));
1675 sv_catsv(ERRSV, err);
1678 sv_catsv(PL_errors, err);
1680 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1682 ++PL_parser->error_count;
1686 Perl_die_unwind(pTHX_ SV *msv)
1689 SV *exceptsv = sv_mortalcopy(msv);
1690 U8 in_eval = PL_in_eval;
1691 PERL_ARGS_ASSERT_DIE_UNWIND;
1698 * Historically, perl used to set ERRSV ($@) early in the die
1699 * process and rely on it not getting clobbered during unwinding.
1700 * That sucked, because it was liable to get clobbered, so the
1701 * setting of ERRSV used to emit the exception from eval{} has
1702 * been moved to much later, after unwinding (see just before
1703 * JMPENV_JUMP below). However, some modules were relying on the
1704 * early setting, by examining $@ during unwinding to use it as
1705 * a flag indicating whether the current unwinding was caused by
1706 * an exception. It was never a reliable flag for that purpose,
1707 * being totally open to false positives even without actual
1708 * clobberage, but was useful enough for production code to
1709 * semantically rely on it.
1711 * We'd like to have a proper introspective interface that
1712 * explicitly describes the reason for whatever unwinding
1713 * operations are currently in progress, so that those modules
1714 * work reliably and $@ isn't further overloaded. But we don't
1715 * have one yet. In its absence, as a stopgap measure, ERRSV is
1716 * now *additionally* set here, before unwinding, to serve as the
1717 * (unreliable) flag that it used to.
1719 * This behaviour is temporary, and should be removed when a
1720 * proper way to detect exceptional unwinding has been developed.
1721 * As of 2010-12, the authors of modules relying on the hack
1722 * are aware of the issue, because the modules failed on
1723 * perls 5.13.{1..7} which had late setting of $@ without this
1724 * early-setting hack.
1726 if (!(in_eval & EVAL_KEEPERR)) {
1727 SvTEMP_off(exceptsv);
1728 sv_setsv(ERRSV, exceptsv);
1731 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1732 && PL_curstackinfo->si_prev)
1741 register PERL_CONTEXT *cx;
1744 JMPENV *restartjmpenv;
1747 if (cxix < cxstack_ix)
1750 POPBLOCK(cx,PL_curpm);
1751 if (CxTYPE(cx) != CXt_EVAL) {
1753 const char* message = SvPVx_const(exceptsv, msglen);
1754 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1755 PerlIO_write(Perl_error_log, message, msglen);
1759 namesv = cx->blk_eval.old_namesv;
1760 oldcop = cx->blk_oldcop;
1761 restartjmpenv = cx->blk_eval.cur_top_env;
1762 restartop = cx->blk_eval.retop;
1764 if (gimme == G_SCALAR)
1765 *++newsp = &PL_sv_undef;
1766 PL_stack_sp = newsp;
1770 /* LEAVE could clobber PL_curcop (see save_re_context())
1771 * XXX it might be better to find a way to avoid messing with
1772 * PL_curcop in save_re_context() instead, but this is a more
1773 * minimal fix --GSAR */
1776 if (optype == OP_REQUIRE) {
1777 const char* const msg = SvPVx_nolen_const(exceptsv);
1778 (void)hv_store(GvHVn(PL_incgv),
1779 SvPVX_const(namesv), SvCUR(namesv),
1781 /* note that unlike pp_entereval, pp_require isn't
1782 * supposed to trap errors. So now that we've popped the
1783 * EVAL that pp_require pushed, and processed the error
1784 * message, rethrow the error */
1785 Perl_croak(aTHX_ "%sCompilation failed in require",
1786 *msg ? msg : "Unknown error\n");
1788 if (in_eval & EVAL_KEEPERR) {
1789 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1790 SvPV_nolen_const(exceptsv));
1793 sv_setsv(ERRSV, exceptsv);
1795 PL_restartjmpenv = restartjmpenv;
1796 PL_restartop = restartop;
1802 write_to_stderr(exceptsv);
1809 dVAR; dSP; dPOPTOPssrl;
1810 if (SvTRUE(left) != SvTRUE(right))
1817 =for apidoc caller_cx
1819 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1820 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1821 information returned to Perl by C<caller>. Note that XSUBs don't get a
1822 stack frame, so C<caller_cx(0, NULL)> will return information for the
1823 immediately-surrounding Perl code.
1825 This function skips over the automatic calls to C<&DB::sub> made on the
1826 behalf of the debugger. If the stack frame requested was a sub called by
1827 C<DB::sub>, the return value will be the frame for the call to
1828 C<DB::sub>, since that has the correct line number/etc. for the call
1829 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1830 frame for the sub call itself.
1835 const PERL_CONTEXT *
1836 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1838 register I32 cxix = dopoptosub(cxstack_ix);
1839 register const PERL_CONTEXT *cx;
1840 register const PERL_CONTEXT *ccstack = cxstack;
1841 const PERL_SI *top_si = PL_curstackinfo;
1844 /* we may be in a higher stacklevel, so dig down deeper */
1845 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1846 top_si = top_si->si_prev;
1847 ccstack = top_si->si_cxstack;
1848 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1852 /* caller() should not report the automatic calls to &DB::sub */
1853 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1854 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1858 cxix = dopoptosub_at(ccstack, cxix - 1);
1861 cx = &ccstack[cxix];
1862 if (dbcxp) *dbcxp = cx;
1864 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1865 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1866 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1867 field below is defined for any cx. */
1868 /* caller() should not report the automatic calls to &DB::sub */
1869 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1870 cx = &ccstack[dbcxix];
1880 register const PERL_CONTEXT *cx;
1881 const PERL_CONTEXT *dbcx;
1883 const char *stashname;
1889 cx = caller_cx(count, &dbcx);
1891 if (GIMME != G_ARRAY) {
1898 stashname = CopSTASHPV(cx->blk_oldcop);
1899 if (GIMME != G_ARRAY) {
1902 PUSHs(&PL_sv_undef);
1905 sv_setpv(TARG, stashname);
1914 PUSHs(&PL_sv_undef);
1916 mPUSHs(newSVpv(stashname, 0));
1917 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1918 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1921 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1922 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1923 /* So is ccstack[dbcxix]. */
1925 SV * const sv = newSV(0);
1926 gv_efullname3(sv, cvgv, NULL);
1928 PUSHs(boolSV(CxHASARGS(cx)));
1931 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1932 PUSHs(boolSV(CxHASARGS(cx)));
1936 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1939 gimme = (I32)cx->blk_gimme;
1940 if (gimme == G_VOID)
1941 PUSHs(&PL_sv_undef);
1943 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1944 if (CxTYPE(cx) == CXt_EVAL) {
1946 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1947 PUSHs(cx->blk_eval.cur_text);
1951 else if (cx->blk_eval.old_namesv) {
1952 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1955 /* eval BLOCK (try blocks have old_namesv == 0) */
1957 PUSHs(&PL_sv_undef);
1958 PUSHs(&PL_sv_undef);
1962 PUSHs(&PL_sv_undef);
1963 PUSHs(&PL_sv_undef);
1965 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1966 && CopSTASH_eq(PL_curcop, PL_debstash))
1968 AV * const ary = cx->blk_sub.argarray;
1969 const int off = AvARRAY(ary) - AvALLOC(ary);
1972 Perl_init_dbargs(aTHX);
1974 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1975 av_extend(PL_dbargs, AvFILLp(ary) + off);
1976 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1977 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1979 /* XXX only hints propagated via op_private are currently
1980 * visible (others are not easily accessible, since they
1981 * use the global PL_hints) */
1982 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1985 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1987 if (old_warnings == pWARN_NONE ||
1988 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1989 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1990 else if (old_warnings == pWARN_ALL ||
1991 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1992 /* Get the bit mask for $warnings::Bits{all}, because
1993 * it could have been extended by warnings::register */
1995 HV * const bits = get_hv("warnings::Bits", 0);
1996 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1997 mask = newSVsv(*bits_all);
2000 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
2004 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
2008 PUSHs(cx->blk_oldcop->cop_hints_hash ?
2009 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2018 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
2019 sv_reset(tmps, CopSTASH(PL_curcop));
2024 /* like pp_nextstate, but used instead when the debugger is active */
2029 PL_curcop = (COP*)PL_op;
2030 TAINT_NOT; /* Each statement is presumed innocent */
2031 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
2036 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2037 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
2040 register PERL_CONTEXT *cx;
2041 const I32 gimme = G_ARRAY;
2043 GV * const gv = PL_DBgv;
2044 register CV * const cv = GvCV(gv);
2047 DIE(aTHX_ "No DB::DB routine defined");
2049 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2050 /* don't do recursive DB::DB call */
2065 (void)(*CvXSUB(cv))(aTHX_ cv);
2072 PUSHBLOCK(cx, CXt_SUB, SP);
2074 cx->blk_sub.retop = PL_op->op_next;
2077 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
2078 RETURNOP(CvSTART(cv));
2088 register PERL_CONTEXT *cx;
2089 const I32 gimme = GIMME_V;
2090 void *itervar; /* location of the iteration variable */
2091 U8 cxtype = CXt_LOOP_FOR;
2093 ENTER_with_name("loop1");
2096 if (PL_op->op_targ) { /* "my" variable */
2097 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2098 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2099 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2100 SVs_PADSTALE, SVs_PADSTALE);
2102 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2104 itervar = PL_comppad;
2106 itervar = &PAD_SVl(PL_op->op_targ);
2109 else { /* symbol table variable */
2110 GV * const gv = MUTABLE_GV(POPs);
2111 SV** svp = &GvSV(gv);
2112 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2114 itervar = (void *)gv;
2117 if (PL_op->op_private & OPpITER_DEF)
2118 cxtype |= CXp_FOR_DEF;
2120 ENTER_with_name("loop2");
2122 PUSHBLOCK(cx, cxtype, SP);
2123 PUSHLOOP_FOR(cx, itervar, MARK);
2124 if (PL_op->op_flags & OPf_STACKED) {
2125 SV *maybe_ary = POPs;
2126 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2128 SV * const right = maybe_ary;
2131 if (RANGE_IS_NUMERIC(sv,right)) {
2132 cx->cx_type &= ~CXTYPEMASK;
2133 cx->cx_type |= CXt_LOOP_LAZYIV;
2134 /* Make sure that no-one re-orders cop.h and breaks our
2136 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2137 #ifdef NV_PRESERVES_UV
2138 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
2139 (SvNV(sv) > (NV)IV_MAX)))
2141 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
2142 (SvNV(right) < (NV)IV_MIN))))
2144 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
2147 ((SvUV(sv) > (UV)IV_MAX) ||
2148 (SvNV(sv) > (NV)UV_MAX)))))
2150 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
2152 ((SvNV(right) > 0) &&
2153 ((SvUV(right) > (UV)IV_MAX) ||
2154 (SvNV(right) > (NV)UV_MAX))))))
2156 DIE(aTHX_ "Range iterator outside integer range");
2157 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
2158 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
2160 /* for correct -Dstv display */
2161 cx->blk_oldsp = sp - PL_stack_base;
2165 cx->cx_type &= ~CXTYPEMASK;
2166 cx->cx_type |= CXt_LOOP_LAZYSV;
2167 /* Make sure that no-one re-orders cop.h and breaks our
2169 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2170 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2171 cx->blk_loop.state_u.lazysv.end = right;
2172 SvREFCNT_inc(right);
2173 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2174 /* This will do the upgrade to SVt_PV, and warn if the value
2175 is uninitialised. */
2176 (void) SvPV_nolen_const(right);
2177 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2178 to replace !SvOK() with a pointer to "". */
2180 SvREFCNT_dec(right);
2181 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2185 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2186 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2187 SvREFCNT_inc(maybe_ary);
2188 cx->blk_loop.state_u.ary.ix =
2189 (PL_op->op_private & OPpITER_REVERSED) ?
2190 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2194 else { /* iterating over items on the stack */
2195 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2196 if (PL_op->op_private & OPpITER_REVERSED) {
2197 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2200 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2210 register PERL_CONTEXT *cx;
2211 const I32 gimme = GIMME_V;
2213 ENTER_with_name("loop1");
2215 ENTER_with_name("loop2");
2217 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2218 PUSHLOOP_PLAIN(cx, SP);
2226 register PERL_CONTEXT *cx;
2233 assert(CxTYPE_is_LOOP(cx));
2235 newsp = PL_stack_base + cx->blk_loop.resetsp;
2238 if (gimme == G_VOID)
2240 else if (gimme == G_SCALAR) {
2242 *++newsp = sv_mortalcopy(*SP);
2244 *++newsp = &PL_sv_undef;
2248 *++newsp = sv_mortalcopy(*++mark);
2249 TAINT_NOT; /* Each item is independent */
2255 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2256 PL_curpm = newpm; /* ... and pop $1 et al */
2258 LEAVE_with_name("loop2");
2259 LEAVE_with_name("loop1");
2267 register PERL_CONTEXT *cx;
2268 bool popsub2 = FALSE;
2269 bool clear_errsv = FALSE;
2279 const I32 cxix = dopoptosub(cxstack_ix);
2282 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2283 * sort block, which is a CXt_NULL
2286 PL_stack_base[1] = *PL_stack_sp;
2287 PL_stack_sp = PL_stack_base + 1;
2291 DIE(aTHX_ "Can't return outside a subroutine");
2293 if (cxix < cxstack_ix)
2296 if (CxMULTICALL(&cxstack[cxix])) {
2297 gimme = cxstack[cxix].blk_gimme;
2298 if (gimme == G_VOID)
2299 PL_stack_sp = PL_stack_base;
2300 else if (gimme == G_SCALAR) {
2301 PL_stack_base[1] = *PL_stack_sp;
2302 PL_stack_sp = PL_stack_base + 1;
2308 switch (CxTYPE(cx)) {
2311 lval = !!CvLVALUE(cx->blk_sub.cv);
2312 retop = cx->blk_sub.retop;
2313 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2316 if (!(PL_in_eval & EVAL_KEEPERR))
2319 namesv = cx->blk_eval.old_namesv;
2320 retop = cx->blk_eval.retop;
2323 if (optype == OP_REQUIRE &&
2324 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2326 /* Unassume the success we assumed earlier. */
2327 (void)hv_delete(GvHVn(PL_incgv),
2328 SvPVX_const(namesv), SvCUR(namesv),
2330 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2335 retop = cx->blk_sub.retop;
2338 DIE(aTHX_ "panic: return");
2342 if (gimme == G_SCALAR) {
2345 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2347 *++newsp = SvREFCNT_inc(*SP);
2352 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2354 *++newsp = sv_mortalcopy(sv);
2360 (lval || SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2363 *++newsp = sv_mortalcopy(*SP);
2366 *++newsp = &PL_sv_undef;
2368 else if (gimme == G_ARRAY) {
2369 while (++MARK <= SP) {
2370 *++newsp = popsub2 && (lval || SvTEMP(*MARK))
2371 ? *MARK : sv_mortalcopy(*MARK);
2372 TAINT_NOT; /* Each item is independent */
2375 PL_stack_sp = newsp;
2378 /* Stack values are safe: */
2381 POPSUB(cx,sv); /* release CV and @_ ... */
2385 PL_curpm = newpm; /* ... and pop $1 et al */
2398 register PERL_CONTEXT *cx;
2409 if (PL_op->op_flags & OPf_SPECIAL) {
2410 cxix = dopoptoloop(cxstack_ix);
2412 DIE(aTHX_ "Can't \"last\" outside a loop block");
2415 cxix = dopoptolabel(cPVOP->op_pv);
2417 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2419 if (cxix < cxstack_ix)
2423 cxstack_ix++; /* temporarily protect top context */
2425 switch (CxTYPE(cx)) {
2426 case CXt_LOOP_LAZYIV:
2427 case CXt_LOOP_LAZYSV:
2429 case CXt_LOOP_PLAIN:
2431 newsp = PL_stack_base + cx->blk_loop.resetsp;
2432 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2436 nextop = cx->blk_sub.retop;
2440 nextop = cx->blk_eval.retop;
2444 nextop = cx->blk_sub.retop;
2447 DIE(aTHX_ "panic: last");
2451 if (gimme == G_SCALAR) {
2453 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2454 ? *SP : sv_mortalcopy(*SP);
2456 *++newsp = &PL_sv_undef;
2458 else if (gimme == G_ARRAY) {
2459 while (++MARK <= SP) {
2460 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2461 ? *MARK : sv_mortalcopy(*MARK);
2462 TAINT_NOT; /* Each item is independent */
2470 /* Stack values are safe: */
2472 case CXt_LOOP_LAZYIV:
2473 case CXt_LOOP_PLAIN:
2474 case CXt_LOOP_LAZYSV:
2476 POPLOOP(cx); /* release loop vars ... */
2480 POPSUB(cx,sv); /* release CV and @_ ... */
2483 PL_curpm = newpm; /* ... and pop $1 et al */
2486 PERL_UNUSED_VAR(optype);
2487 PERL_UNUSED_VAR(gimme);
2495 register PERL_CONTEXT *cx;
2498 if (PL_op->op_flags & OPf_SPECIAL) {
2499 cxix = dopoptoloop(cxstack_ix);
2501 DIE(aTHX_ "Can't \"next\" outside a loop block");
2504 cxix = dopoptolabel(cPVOP->op_pv);
2506 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2508 if (cxix < cxstack_ix)
2511 /* clear off anything above the scope we're re-entering, but
2512 * save the rest until after a possible continue block */
2513 inner = PL_scopestack_ix;
2515 if (PL_scopestack_ix < inner)
2516 leave_scope(PL_scopestack[PL_scopestack_ix]);
2517 PL_curcop = cx->blk_oldcop;
2518 return (cx)->blk_loop.my_op->op_nextop;
2525 register PERL_CONTEXT *cx;
2529 if (PL_op->op_flags & OPf_SPECIAL) {
2530 cxix = dopoptoloop(cxstack_ix);
2532 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2535 cxix = dopoptolabel(cPVOP->op_pv);
2537 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2539 if (cxix < cxstack_ix)
2542 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2543 if (redo_op->op_type == OP_ENTER) {
2544 /* pop one less context to avoid $x being freed in while (my $x..) */
2546 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2547 redo_op = redo_op->op_next;
2551 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2552 LEAVE_SCOPE(oldsave);
2554 PL_curcop = cx->blk_oldcop;
2559 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2563 static const char too_deep[] = "Target of goto is too deeply nested";
2565 PERL_ARGS_ASSERT_DOFINDLABEL;
2568 Perl_croak(aTHX_ too_deep);
2569 if (o->op_type == OP_LEAVE ||
2570 o->op_type == OP_SCOPE ||
2571 o->op_type == OP_LEAVELOOP ||
2572 o->op_type == OP_LEAVESUB ||
2573 o->op_type == OP_LEAVETRY)
2575 *ops++ = cUNOPo->op_first;
2577 Perl_croak(aTHX_ too_deep);
2580 if (o->op_flags & OPf_KIDS) {
2582 /* First try all the kids at this level, since that's likeliest. */
2583 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2584 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2585 const char *kid_label = CopLABEL(kCOP);
2586 if (kid_label && strEQ(kid_label, label))
2590 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2591 if (kid == PL_lastgotoprobe)
2593 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2596 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2597 ops[-1]->op_type == OP_DBSTATE)
2602 if ((o = dofindlabel(kid, label, ops, oplimit)))
2615 register PERL_CONTEXT *cx;
2616 #define GOTO_DEPTH 64
2617 OP *enterops[GOTO_DEPTH];
2618 const char *label = NULL;
2619 const bool do_dump = (PL_op->op_type == OP_DUMP);
2620 static const char must_have_label[] = "goto must have label";
2622 if (PL_op->op_flags & OPf_STACKED) {
2623 SV * const sv = POPs;
2625 /* This egregious kludge implements goto &subroutine */
2626 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2628 register PERL_CONTEXT *cx;
2629 CV *cv = MUTABLE_CV(SvRV(sv));
2636 if (!CvROOT(cv) && !CvXSUB(cv)) {
2637 const GV * const gv = CvGV(cv);
2641 /* autoloaded stub? */
2642 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2644 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2645 GvNAMELEN(gv), FALSE);
2646 if (autogv && (cv = GvCV(autogv)))
2648 tmpstr = sv_newmortal();
2649 gv_efullname3(tmpstr, gv, NULL);
2650 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2652 DIE(aTHX_ "Goto undefined subroutine");
2655 /* First do some returnish stuff. */
2656 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2658 cxix = dopoptosub(cxstack_ix);
2660 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2661 if (cxix < cxstack_ix)
2665 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2666 if (CxTYPE(cx) == CXt_EVAL) {
2668 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2670 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2672 else if (CxMULTICALL(cx))
2673 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2674 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2675 /* put @_ back onto stack */
2676 AV* av = cx->blk_sub.argarray;
2678 items = AvFILLp(av) + 1;
2679 EXTEND(SP, items+1); /* @_ could have been extended. */
2680 Copy(AvARRAY(av), SP + 1, items, SV*);
2681 SvREFCNT_dec(GvAV(PL_defgv));
2682 GvAV(PL_defgv) = cx->blk_sub.savearray;
2684 /* abandon @_ if it got reified */
2689 av_extend(av, items-1);
2691 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2694 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2695 AV* const av = GvAV(PL_defgv);
2696 items = AvFILLp(av) + 1;
2697 EXTEND(SP, items+1); /* @_ could have been extended. */
2698 Copy(AvARRAY(av), SP + 1, items, SV*);
2702 if (CxTYPE(cx) == CXt_SUB &&
2703 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2704 SvREFCNT_dec(cx->blk_sub.cv);
2705 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2706 LEAVE_SCOPE(oldsave);
2708 /* Now do some callish stuff. */
2710 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2712 OP* const retop = cx->blk_sub.retop;
2713 SV **newsp __attribute__unused__;
2714 I32 gimme __attribute__unused__;
2717 for (index=0; index<items; index++)
2718 sv_2mortal(SP[-index]);
2721 /* XS subs don't have a CxSUB, so pop it */
2722 POPBLOCK(cx, PL_curpm);
2723 /* Push a mark for the start of arglist */
2726 (void)(*CvXSUB(cv))(aTHX_ cv);
2731 AV* const padlist = CvPADLIST(cv);
2732 if (CxTYPE(cx) == CXt_EVAL) {
2733 PL_in_eval = CxOLD_IN_EVAL(cx);
2734 PL_eval_root = cx->blk_eval.old_eval_root;
2735 cx->cx_type = CXt_SUB;
2737 cx->blk_sub.cv = cv;
2738 cx->blk_sub.olddepth = CvDEPTH(cv);
2741 if (CvDEPTH(cv) < 2)
2742 SvREFCNT_inc_simple_void_NN(cv);
2744 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2745 sub_crush_depth(cv);
2746 pad_push(padlist, CvDEPTH(cv));
2749 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2752 AV *const av = MUTABLE_AV(PAD_SVl(0));
2754 cx->blk_sub.savearray = GvAV(PL_defgv);
2755 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2756 CX_CURPAD_SAVE(cx->blk_sub);
2757 cx->blk_sub.argarray = av;
2759 if (items >= AvMAX(av) + 1) {
2760 SV **ary = AvALLOC(av);
2761 if (AvARRAY(av) != ary) {
2762 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2765 if (items >= AvMAX(av) + 1) {
2766 AvMAX(av) = items - 1;
2767 Renew(ary,items+1,SV*);
2773 Copy(mark,AvARRAY(av),items,SV*);
2774 AvFILLp(av) = items - 1;
2775 assert(!AvREAL(av));
2777 /* transfer 'ownership' of refcnts to new @_ */
2787 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2788 Perl_get_db_sub(aTHX_ NULL, cv);
2790 CV * const gotocv = get_cvs("DB::goto", 0);
2792 PUSHMARK( PL_stack_sp );
2793 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2798 RETURNOP(CvSTART(cv));
2802 label = SvPV_nolen_const(sv);
2803 if (!(do_dump || *label))
2804 DIE(aTHX_ must_have_label);
2807 else if (PL_op->op_flags & OPf_SPECIAL) {
2809 DIE(aTHX_ must_have_label);
2812 label = cPVOP->op_pv;
2816 if (label && *label) {
2817 OP *gotoprobe = NULL;
2818 bool leaving_eval = FALSE;
2819 bool in_block = FALSE;
2820 PERL_CONTEXT *last_eval_cx = NULL;
2824 PL_lastgotoprobe = NULL;
2826 for (ix = cxstack_ix; ix >= 0; ix--) {
2828 switch (CxTYPE(cx)) {
2830 leaving_eval = TRUE;
2831 if (!CxTRYBLOCK(cx)) {
2832 gotoprobe = (last_eval_cx ?
2833 last_eval_cx->blk_eval.old_eval_root :
2838 /* else fall through */
2839 case CXt_LOOP_LAZYIV:
2840 case CXt_LOOP_LAZYSV:
2842 case CXt_LOOP_PLAIN:
2845 gotoprobe = cx->blk_oldcop->op_sibling;
2851 gotoprobe = cx->blk_oldcop->op_sibling;
2854 gotoprobe = PL_main_root;
2857 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2858 gotoprobe = CvROOT(cx->blk_sub.cv);
2864 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2867 DIE(aTHX_ "panic: goto");
2868 gotoprobe = PL_main_root;
2872 retop = dofindlabel(gotoprobe, label,
2873 enterops, enterops + GOTO_DEPTH);
2876 if (gotoprobe->op_sibling &&
2877 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
2878 gotoprobe->op_sibling->op_sibling) {
2879 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
2880 label, enterops, enterops + GOTO_DEPTH);
2885 PL_lastgotoprobe = gotoprobe;
2888 DIE(aTHX_ "Can't find label %s", label);
2890 /* if we're leaving an eval, check before we pop any frames
2891 that we're not going to punt, otherwise the error
2894 if (leaving_eval && *enterops && enterops[1]) {
2896 for (i = 1; enterops[i]; i++)
2897 if (enterops[i]->op_type == OP_ENTERITER)
2898 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2901 if (*enterops && enterops[1]) {
2902 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2904 deprecate("\"goto\" to jump into a construct");
2907 /* pop unwanted frames */
2909 if (ix < cxstack_ix) {
2916 oldsave = PL_scopestack[PL_scopestack_ix];
2917 LEAVE_SCOPE(oldsave);
2920 /* push wanted frames */
2922 if (*enterops && enterops[1]) {
2923 OP * const oldop = PL_op;
2924 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2925 for (; enterops[ix]; ix++) {
2926 PL_op = enterops[ix];
2927 /* Eventually we may want to stack the needed arguments
2928 * for each op. For now, we punt on the hard ones. */
2929 if (PL_op->op_type == OP_ENTERITER)
2930 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2931 PL_op->op_ppaddr(aTHX);
2939 if (!retop) retop = PL_main_start;
2941 PL_restartop = retop;
2942 PL_do_undump = TRUE;
2946 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2947 PL_do_undump = FALSE;
2964 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2966 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2969 PL_exit_flags |= PERL_EXIT_EXPECTED;
2971 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2972 if (anum || !(PL_minus_c && PL_madskills))
2977 PUSHs(&PL_sv_undef);
2984 S_save_lines(pTHX_ AV *array, SV *sv)
2986 const char *s = SvPVX_const(sv);
2987 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2990 PERL_ARGS_ASSERT_SAVE_LINES;
2992 while (s && s < send) {
2994 SV * const tmpstr = newSV_type(SVt_PVMG);
2996 t = (const char *)memchr(s, '\n', send - s);
3002 sv_setpvn(tmpstr, s, t - s);
3003 av_store(array, line++, tmpstr);
3011 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3013 0 is used as continue inside eval,
3015 3 is used for a die caught by an inner eval - continue inner loop
3017 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3018 establish a local jmpenv to handle exception traps.
3023 S_docatch(pTHX_ OP *o)
3027 OP * const oldop = PL_op;
3031 assert(CATCH_GET == TRUE);
3038 assert(cxstack_ix >= 0);
3039 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3040 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3045 /* die caught by an inner eval - continue inner loop */
3046 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3047 PL_restartjmpenv = NULL;
3048 PL_op = PL_restartop;
3064 /* James Bond: Do you expect me to talk?
3065 Auric Goldfinger: No, Mr. Bond. I expect you to die.
3067 This code is an ugly hack, doesn't work with lexicals in subroutines that are
3068 called more than once, and is only used by regcomp.c, for (?{}) blocks.
3070 Currently it is not used outside the core code. Best if it stays that way.
3072 Hence it's now deprecated, and will be removed.
3075 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
3076 /* sv Text to convert to OP tree. */
3077 /* startop op_free() this to undo. */
3078 /* code Short string id of the caller. */
3080 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3081 return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3084 /* Don't use this. It will go away without warning once the regexp engine is
3085 refactored not to use it. */
3087 Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3090 dVAR; dSP; /* Make POPBLOCK work. */
3096 char tbuf[TYPE_DIGITS(long) + 12 + 10];
3097 char *tmpbuf = tbuf;
3100 CV* runcv = NULL; /* initialise to avoid compiler warnings */
3104 PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
3106 ENTER_with_name("eval");
3107 lex_start(sv, NULL, LEX_START_SAME_FILTER);
3109 /* switch to eval mode */
3111 if (IN_PERL_COMPILETIME) {
3112 SAVECOPSTASH_FREE(&PL_compiling);
3113 CopSTASH_set(&PL_compiling, PL_curstash);
3115 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3116 SV * const sv = sv_newmortal();
3117 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3118 code, (unsigned long)++PL_evalseq,
3119 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3124 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3125 (unsigned long)++PL_evalseq);
3126 SAVECOPFILE_FREE(&PL_compiling);
3127 CopFILE_set(&PL_compiling, tmpbuf+2);
3128 SAVECOPLINE(&PL_compiling);
3129 CopLINE_set(&PL_compiling, 1);
3130 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3131 deleting the eval's FILEGV from the stash before gv_check() runs
3132 (i.e. before run-time proper). To work around the coredump that
3133 ensues, we always turn GvMULTI_on for any globals that were
3134 introduced within evals. See force_ident(). GSAR 96-10-12 */
3135 safestr = savepvn(tmpbuf, len);
3136 SAVEDELETE(PL_defstash, safestr, len);
3138 #ifdef OP_IN_REGISTER
3144 /* we get here either during compilation, or via pp_regcomp at runtime */
3145 runtime = IN_PERL_RUNTIME;
3148 runcv = find_runcv(NULL);
3150 /* At run time, we have to fetch the hints from PL_curcop. */
3151 PL_hints = PL_curcop->cop_hints;
3152 if (PL_hints & HINT_LOCALIZE_HH) {
3153 /* SAVEHINTS created a new HV in PL_hintgv, which we
3155 SvREFCNT_dec(GvHV(PL_hintgv));
3157 refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3158 hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3160 SAVECOMPILEWARNINGS();
3161 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3162 cophh_free(CopHINTHASH_get(&PL_compiling));
3163 /* XXX Does this need to avoid copying a label? */
3164 PL_compiling.cop_hints_hash
3165 = cophh_copy(PL_curcop->cop_hints_hash);
3169 PL_op->op_type = OP_ENTEREVAL;
3170 PL_op->op_flags = 0; /* Avoid uninit warning. */
3171 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3173 need_catch = CATCH_GET;
3177 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
3179 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
3180 CATCH_SET(need_catch);
3181 POPBLOCK(cx,PL_curpm);
3184 (*startop)->op_type = OP_NULL;
3185 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3186 /* XXX DAPM do this properly one year */
3187 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3188 LEAVE_with_name("eval");
3189 if (IN_PERL_COMPILETIME)
3190 CopHINTS_set(&PL_compiling, PL_hints);
3191 #ifdef OP_IN_REGISTER
3194 PERL_UNUSED_VAR(newsp);
3195 PERL_UNUSED_VAR(optype);
3197 return PL_eval_start;
3202 =for apidoc find_runcv
3204 Locate the CV corresponding to the currently executing sub or eval.
3205 If db_seqp is non_null, skip CVs that are in the DB package and populate
3206 *db_seqp with the cop sequence number at the point that the DB:: code was
3207 entered. (allows debuggers to eval in the scope of the breakpoint rather
3208 than in the scope of the debugger itself).
3214 Perl_find_runcv(pTHX_ U32 *db_seqp)
3220 *db_seqp = PL_curcop->cop_seq;
3221 for (si = PL_curstackinfo; si; si = si->si_prev) {
3223 for (ix = si->si_cxix; ix >= 0; ix--) {
3224 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3225 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3226 CV * const cv = cx->blk_sub.cv;
3227 /* skip DB:: code */
3228 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3229 *db_seqp = cx->blk_oldcop->cop_seq;
3234 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3242 /* Run yyparse() in a setjmp wrapper. Returns:
3243 * 0: yyparse() successful
3244 * 1: yyparse() failed
3248 S_try_yyparse(pTHX_ int gramtype)
3253 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3257 ret = yyparse(gramtype) ? 1 : 0;
3271 /* Compile a require/do, an eval '', or a /(?{...})/.
3272 * In the last case, startop is non-null, and contains the address of
3273 * a pointer that should be set to the just-compiled code.
3274 * outside is the lexically enclosing CV (if any) that invoked us.
3275 * Returns a bool indicating whether the compile was successful; if so,
3276 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3277 * pushes undef (also croaks if startop != NULL).
3281 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3284 OP * const saveop = PL_op;
3285 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3288 PL_in_eval = (in_require
3289 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3294 SAVESPTR(PL_compcv);
3295 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3296 CvEVAL_on(PL_compcv);
3297 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3298 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3300 CvOUTSIDE_SEQ(PL_compcv) = seq;
3301 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3303 /* set up a scratch pad */
3305 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3306 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3310 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3312 /* make sure we compile in the right package */
3314 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3315 SAVESPTR(PL_curstash);
3316 PL_curstash = CopSTASH(PL_curcop);
3318 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3319 SAVESPTR(PL_beginav);
3320 PL_beginav = newAV();
3321 SAVEFREESV(PL_beginav);
3322 SAVESPTR(PL_unitcheckav);
3323 PL_unitcheckav = newAV();
3324 SAVEFREESV(PL_unitcheckav);
3327 SAVEBOOL(PL_madskills);
3331 /* try to compile it */
3333 PL_eval_root = NULL;
3334 PL_curcop = &PL_compiling;
3335 CopARYBASE_set(PL_curcop, 0);
3336 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3337 PL_in_eval |= EVAL_KEEPERR;
3341 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3343 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3344 * so honour CATCH_GET and trap it here if necessary */
3346 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3348 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3349 SV **newsp; /* Used by POPBLOCK. */
3350 PERL_CONTEXT *cx = NULL;
3351 I32 optype; /* Used by POPEVAL. */
3355 PERL_UNUSED_VAR(newsp);
3356 PERL_UNUSED_VAR(optype);
3358 /* note that if yystatus == 3, then the EVAL CX block has already
3359 * been popped, and various vars restored */
3361 if (yystatus != 3) {
3363 op_free(PL_eval_root);
3364 PL_eval_root = NULL;
3366 SP = PL_stack_base + POPMARK; /* pop original mark */
3368 POPBLOCK(cx,PL_curpm);
3370 namesv = cx->blk_eval.old_namesv;
3374 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3376 msg = SvPVx_nolen_const(ERRSV);
3379 /* If cx is still NULL, it means that we didn't go in the
3380 * POPEVAL branch. */
3381 cx = &cxstack[cxstack_ix];
3382 assert(CxTYPE(cx) == CXt_EVAL);
3383 namesv = cx->blk_eval.old_namesv;
3385 (void)hv_store(GvHVn(PL_incgv),
3386 SvPVX_const(namesv), SvCUR(namesv),
3388 Perl_croak(aTHX_ "%sCompilation failed in require",
3389 *msg ? msg : "Unknown error\n");
3392 if (yystatus != 3) {
3393 POPBLOCK(cx,PL_curpm);
3396 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3397 (*msg ? msg : "Unknown error\n"));
3401 sv_setpvs(ERRSV, "Compilation error");
3404 PUSHs(&PL_sv_undef);
3408 CopLINE_set(&PL_compiling, 0);
3410 *startop = PL_eval_root;
3412 SAVEFREEOP(PL_eval_root);
3414 /* Set the context for this new optree.
3415 * Propagate the context from the eval(). */
3416 if ((gimme & G_WANT) == G_VOID)
3417 scalarvoid(PL_eval_root);
3418 else if ((gimme & G_WANT) == G_ARRAY)
3421 scalar(PL_eval_root);
3423 DEBUG_x(dump_eval());
3425 /* Register with debugger: */
3426 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3427 CV * const cv = get_cvs("DB::postponed", 0);
3431 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3433 call_sv(MUTABLE_SV(cv), G_DISCARD);
3437 if (PL_unitcheckav) {
3438 OP *es = PL_eval_start;
3439 call_list(PL_scopestack_ix, PL_unitcheckav);
3443 /* compiled okay, so do it */
3445 CvDEPTH(PL_compcv) = 1;
3446 SP = PL_stack_base + POPMARK; /* pop original mark */
3447 PL_op = saveop; /* The caller may need it. */
3448 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3455 S_check_type_and_open(pTHX_ SV *name)
3458 const char *p = SvPV_nolen_const(name);
3459 const int st_rc = PerlLIO_stat(p, &st);
3461 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3463 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3467 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3468 return PerlIO_openn(aTHX_ NULL, PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3470 return PerlIO_open(p, PERL_SCRIPT_MODE);
3474 #ifndef PERL_DISABLE_PMC
3476 S_doopen_pm(pTHX_ SV *name)
3479 const char *p = SvPV_const(name, namelen);
3481 PERL_ARGS_ASSERT_DOOPEN_PM;
3483 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3484 SV *const pmcsv = sv_newmortal();
3487 SvSetSV_nosteal(pmcsv,name);
3488 sv_catpvn(pmcsv, "c", 1);
3490 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3491 return check_type_and_open(pmcsv);
3493 return check_type_and_open(name);
3496 # define doopen_pm(name) check_type_and_open(name)
3497 #endif /* !PERL_DISABLE_PMC */
3502 register PERL_CONTEXT *cx;
3509 int vms_unixname = 0;
3511 const char *tryname = NULL;
3513 const I32 gimme = GIMME_V;
3514 int filter_has_file = 0;
3515 PerlIO *tryrsfp = NULL;
3516 SV *filter_cache = NULL;
3517 SV *filter_state = NULL;
3518 SV *filter_sub = NULL;
3524 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3525 sv = sv_2mortal(new_version(sv));
3526 if (!sv_derived_from(PL_patchlevel, "version"))
3527 upg_version(PL_patchlevel, TRUE);
3528 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3529 if ( vcmp(sv,PL_patchlevel) <= 0 )
3530 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3531 SVfARG(sv_2mortal(vnormal(sv))),
3532 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3536 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3539 SV * const req = SvRV(sv);
3540 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3542 /* get the left hand term */
3543 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3545 first = SvIV(*av_fetch(lav,0,0));
3546 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3547 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3548 || av_len(lav) > 1 /* FP with > 3 digits */
3549 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3551 DIE(aTHX_ "Perl %"SVf" required--this is only "
3553 SVfARG(sv_2mortal(vnormal(req))),
3554 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3557 else { /* probably 'use 5.10' or 'use 5.8' */
3562 second = SvIV(*av_fetch(lav,1,0));
3564 second /= second >= 600 ? 100 : 10;
3565 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3566 (int)first, (int)second);
3567 upg_version(hintsv, TRUE);
3569 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3570 "--this is only %"SVf", stopped",
3571 SVfARG(sv_2mortal(vnormal(req))),
3572 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3573 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3581 name = SvPV_const(sv, len);
3582 if (!(name && len > 0 && *name))
3583 DIE(aTHX_ "Null filename used");
3584 TAINT_PROPER("require");
3588 /* The key in the %ENV hash is in the syntax of file passed as the argument
3589 * usually this is in UNIX format, but sometimes in VMS format, which
3590 * can result in a module being pulled in more than once.
3591 * To prevent this, the key must be stored in UNIX format if the VMS
3592 * name can be translated to UNIX.
3594 if ((unixname = tounixspec(name, NULL)) != NULL) {
3595 unixlen = strlen(unixname);
3601 /* if not VMS or VMS name can not be translated to UNIX, pass it
3604 unixname = (char *) name;
3607 if (PL_op->op_type == OP_REQUIRE) {
3608 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3609 unixname, unixlen, 0);
3611 if (*svp != &PL_sv_undef)
3614 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3615 "Compilation failed in require", unixname);
3619 /* prepare to compile file */
3621 if (path_is_absolute(name)) {
3622 /* At this point, name is SvPVX(sv) */
3624 tryrsfp = doopen_pm(sv);
3627 AV * const ar = GvAVn(PL_incgv);
3633 namesv = newSV_type(SVt_PV);
3634 for (i = 0; i <= AvFILL(ar); i++) {
3635 SV * const dirsv = *av_fetch(ar, i, TRUE);
3637 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3644 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3645 && !sv_isobject(loader))
3647 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3650 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3651 PTR2UV(SvRV(dirsv)), name);
3652 tryname = SvPVX_const(namesv);
3655 ENTER_with_name("call_INC");
3663 if (sv_isobject(loader))
3664 count = call_method("INC", G_ARRAY);
3666 count = call_sv(loader, G_ARRAY);
3676 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3677 && !isGV_with_GP(SvRV(arg))) {
3678 filter_cache = SvRV(arg);
3679 SvREFCNT_inc_simple_void_NN(filter_cache);
3686 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3690 if (isGV_with_GP(arg)) {
3691 IO * const io = GvIO((const GV *)arg);
3696 tryrsfp = IoIFP(io);
3697 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3698 PerlIO_close(IoOFP(io));
3709 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3711 SvREFCNT_inc_simple_void_NN(filter_sub);
3714 filter_state = SP[i];
3715 SvREFCNT_inc_simple_void(filter_state);
3719 if (!tryrsfp && (filter_cache || filter_sub)) {
3720 tryrsfp = PerlIO_open(BIT_BUCKET,
3728 LEAVE_with_name("call_INC");
3730 /* Adjust file name if the hook has set an %INC entry.
3731 This needs to happen after the FREETMPS above. */
3732 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3734 tryname = SvPV_nolen_const(*svp);
3741 filter_has_file = 0;
3743 SvREFCNT_dec(filter_cache);
3744 filter_cache = NULL;
3747 SvREFCNT_dec(filter_state);
3748 filter_state = NULL;
3751 SvREFCNT_dec(filter_sub);
3756 if (!path_is_absolute(name)
3762 dir = SvPV_const(dirsv, dirlen);
3770 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3772 sv_setpv(namesv, unixdir);
3773 sv_catpv(namesv, unixname);
3775 # ifdef __SYMBIAN32__
3776 if (PL_origfilename[0] &&
3777 PL_origfilename[1] == ':' &&
3778 !(dir[0] && dir[1] == ':'))
3779 Perl_sv_setpvf(aTHX_ namesv,
3784 Perl_sv_setpvf(aTHX_ namesv,
3788 /* The equivalent of
3789 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3790 but without the need to parse the format string, or
3791 call strlen on either pointer, and with the correct
3792 allocation up front. */
3794 char *tmp = SvGROW(namesv, dirlen + len + 2);
3796 memcpy(tmp, dir, dirlen);
3799 /* name came from an SV, so it will have a '\0' at the
3800 end that we can copy as part of this memcpy(). */
3801 memcpy(tmp, name, len + 1);
3803 SvCUR_set(namesv, dirlen + len + 1);
3808 TAINT_PROPER("require");
3809 tryname = SvPVX_const(namesv);
3810 tryrsfp = doopen_pm(namesv);
3812 if (tryname[0] == '.' && tryname[1] == '/') {
3814 while (*++tryname == '/');
3818 else if (errno == EMFILE)
3819 /* no point in trying other paths if out of handles */
3828 if (PL_op->op_type == OP_REQUIRE) {
3829 if(errno == EMFILE) {
3830 /* diag_listed_as: Can't locate %s */
3831 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
3833 if (namesv) { /* did we lookup @INC? */
3834 AV * const ar = GvAVn(PL_incgv);
3836 SV *const inc = newSVpvs_flags("", SVs_TEMP);
3837 for (i = 0; i <= AvFILL(ar); i++) {
3838 sv_catpvs(inc, " ");
3839 sv_catsv(inc, *av_fetch(ar, i, TRUE));
3842 /* diag_listed_as: Can't locate %s */
3844 "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
3846 (memEQ(name + len - 2, ".h", 3)
3847 ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
3848 (memEQ(name + len - 3, ".ph", 4)
3849 ? " (did you run h2ph?)" : ""),
3854 DIE(aTHX_ "Can't locate %s", name);
3860 SETERRNO(0, SS_NORMAL);
3862 /* Assume success here to prevent recursive requirement. */
3863 /* name is never assigned to again, so len is still strlen(name) */
3864 /* Check whether a hook in @INC has already filled %INC */
3866 (void)hv_store(GvHVn(PL_incgv),
3867 unixname, unixlen, newSVpv(tryname,0),0);
3869 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3871 (void)hv_store(GvHVn(PL_incgv),
3872 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3875 ENTER_with_name("eval");
3877 SAVECOPFILE_FREE(&PL_compiling);
3878 CopFILE_set(&PL_compiling, tryname);
3879 lex_start(NULL, tryrsfp, 0);
3883 hv_clear(GvHV(PL_hintgv));
3885 SAVECOMPILEWARNINGS();
3886 if (PL_dowarn & G_WARN_ALL_ON)
3887 PL_compiling.cop_warnings = pWARN_ALL ;
3888 else if (PL_dowarn & G_WARN_ALL_OFF)
3889 PL_compiling.cop_warnings = pWARN_NONE ;
3891 PL_compiling.cop_warnings = pWARN_STD ;
3893 if (filter_sub || filter_cache) {
3894 /* We can use the SvPV of the filter PVIO itself as our cache, rather
3895 than hanging another SV from it. In turn, filter_add() optionally
3896 takes the SV to use as the filter (or creates a new SV if passed
3897 NULL), so simply pass in whatever value filter_cache has. */
3898 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3899 IoLINES(datasv) = filter_has_file;
3900 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3901 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3904 /* switch to eval mode */
3905 PUSHBLOCK(cx, CXt_EVAL, SP);
3907 cx->blk_eval.retop = PL_op->op_next;
3909 SAVECOPLINE(&PL_compiling);
3910 CopLINE_set(&PL_compiling, 0);
3914 /* Store and reset encoding. */
3915 encoding = PL_encoding;
3918 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3919 op = DOCATCH(PL_eval_start);
3921 op = PL_op->op_next;
3923 /* Restore encoding. */
3924 PL_encoding = encoding;
3929 /* This is a op added to hold the hints hash for
3930 pp_entereval. The hash can be modified by the code
3931 being eval'ed, so we return a copy instead. */
3937 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
3945 register PERL_CONTEXT *cx;
3947 const I32 gimme = GIMME_V;
3948 const U32 was = PL_breakable_sub_gen;
3949 char tbuf[TYPE_DIGITS(long) + 12];
3950 bool saved_delete = FALSE;
3951 char *tmpbuf = tbuf;
3955 HV *saved_hh = NULL;
3957 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3958 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3962 /* make sure we've got a plain PV (no overload etc) before testing
3963 * for taint. Making a copy here is probably overkill, but better
3964 * safe than sorry */
3966 const char * const p = SvPV_const(sv, len);
3968 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
3971 TAINT_IF(SvTAINTED(sv));
3972 TAINT_PROPER("eval");
3974 ENTER_with_name("eval");
3975 lex_start(sv, NULL, LEX_START_SAME_FILTER);
3978 /* switch to eval mode */
3980 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3981 SV * const temp_sv = sv_newmortal();
3982 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3983 (unsigned long)++PL_evalseq,
3984 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3985 tmpbuf = SvPVX(temp_sv);
3986 len = SvCUR(temp_sv);
3989 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3990 SAVECOPFILE_FREE(&PL_compiling);
3991 CopFILE_set(&PL_compiling, tmpbuf+2);
3992 SAVECOPLINE(&PL_compiling);
3993 CopLINE_set(&PL_compiling, 1);
3994 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3995 deleting the eval's FILEGV from the stash before gv_check() runs
3996 (i.e. before run-time proper). To work around the coredump that
3997 ensues, we always turn GvMULTI_on for any globals that were
3998 introduced within evals. See force_ident(). GSAR 96-10-12 */
4000 PL_hints = PL_op->op_targ;
4002 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
4003 SvREFCNT_dec(GvHV(PL_hintgv));
4004 GvHV(PL_hintgv) = saved_hh;
4006 SAVECOMPILEWARNINGS();
4007 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4008 cophh_free(CopHINTHASH_get(&PL_compiling));
4009 if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
4010 /* The label, if present, is the first entry on the chain. So rather
4011 than writing a blank label in front of it (which involves an
4012 allocation), just use the next entry in the chain. */
4013 PL_compiling.cop_hints_hash
4014 = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
4015 /* Check the assumption that this removed the label. */
4016 assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
4019 PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
4020 /* special case: an eval '' executed within the DB package gets lexically
4021 * placed in the first non-DB CV rather than the current CV - this
4022 * allows the debugger to execute code, find lexicals etc, in the
4023 * scope of the code being debugged. Passing &seq gets find_runcv
4024 * to do the dirty work for us */
4025 runcv = find_runcv(&seq);
4027 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4029 cx->blk_eval.retop = PL_op->op_next;
4031 /* prepare to compile string */
4033 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4034 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4036 char *const safestr = savepvn(tmpbuf, len);
4037 SAVEDELETE(PL_defstash, safestr, len);
4038 saved_delete = TRUE;
4043 if (doeval(gimme, NULL, runcv, seq)) {
4044 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4045 ? (PERLDB_LINE || PERLDB_SAVESRC)
4046 : PERLDB_SAVESRC_NOSUBS) {
4047 /* Retain the filegv we created. */
4048 } else if (!saved_delete) {
4049 char *const safestr = savepvn(tmpbuf, len);
4050 SAVEDELETE(PL_defstash, safestr, len);
4052 return DOCATCH(PL_eval_start);
4054 /* We have already left the scope set up earlier thanks to the LEAVE
4056 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4057 ? (PERLDB_LINE || PERLDB_SAVESRC)
4058 : PERLDB_SAVESRC_INVALID) {
4059 /* Retain the filegv we created. */
4060 } else if (!saved_delete) {
4061 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4063 return PL_op->op_next;
4074 register PERL_CONTEXT *cx;
4076 const U8 save_flags = PL_op -> op_flags;
4083 namesv = cx->blk_eval.old_namesv;
4084 retop = cx->blk_eval.retop;
4087 if (gimme == G_VOID)
4089 else if (gimme == G_SCALAR) {
4092 if (SvFLAGS(TOPs) & SVs_TEMP)
4095 *MARK = sv_mortalcopy(TOPs);
4099 *MARK = &PL_sv_undef;
4104 /* in case LEAVE wipes old return values */
4105 for (mark = newsp + 1; mark <= SP; mark++) {
4106 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
4107 *mark = sv_mortalcopy(*mark);
4108 TAINT_NOT; /* Each item is independent */
4112 PL_curpm = newpm; /* Don't pop $1 et al till now */
4115 assert(CvDEPTH(PL_compcv) == 1);
4117 CvDEPTH(PL_compcv) = 0;
4119 if (optype == OP_REQUIRE &&
4120 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4122 /* Unassume the success we assumed earlier. */
4123 (void)hv_delete(GvHVn(PL_incgv),
4124 SvPVX_const(namesv), SvCUR(namesv),
4126 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4128 /* die_unwind() did LEAVE, or we won't be here */
4131 LEAVE_with_name("eval");
4132 if (!(save_flags & OPf_SPECIAL)) {
4140 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4141 close to the related Perl_create_eval_scope. */
4143 Perl_delete_eval_scope(pTHX)
4148 register PERL_CONTEXT *cx;
4154 LEAVE_with_name("eval_scope");
4155 PERL_UNUSED_VAR(newsp);
4156 PERL_UNUSED_VAR(gimme);
4157 PERL_UNUSED_VAR(optype);
4160 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4161 also needed by Perl_fold_constants. */
4163 Perl_create_eval_scope(pTHX_ U32 flags)
4166 const I32 gimme = GIMME_V;
4168 ENTER_with_name("eval_scope");
4171 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4174 PL_in_eval = EVAL_INEVAL;
4175 if (flags & G_KEEPERR)
4176 PL_in_eval |= EVAL_KEEPERR;
4179 if (flags & G_FAKINGEVAL) {
4180 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4188 PERL_CONTEXT * const cx = create_eval_scope(0);
4189 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4190 return DOCATCH(PL_op->op_next);
4199 register PERL_CONTEXT *cx;
4205 PERL_UNUSED_VAR(optype);
4208 if (gimme == G_VOID)
4210 else if (gimme == G_SCALAR) {
4214 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4217 *MARK = sv_mortalcopy(TOPs);
4221 *MARK = &PL_sv_undef;
4226 /* in case LEAVE wipes old return values */
4228 for (mark = newsp + 1; mark <= SP; mark++) {
4229 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4230 *mark = sv_mortalcopy(*mark);
4231 TAINT_NOT; /* Each item is independent */
4235 PL_curpm = newpm; /* Don't pop $1 et al till now */
4237 LEAVE_with_name("eval_scope");
4245 register PERL_CONTEXT *cx;
4246 const I32 gimme = GIMME_V;
4248 ENTER_with_name("given");
4251 sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
4253 PUSHBLOCK(cx, CXt_GIVEN, SP);
4262 register PERL_CONTEXT *cx;
4266 PERL_UNUSED_CONTEXT;
4269 assert(CxTYPE(cx) == CXt_GIVEN);
4272 if (gimme == G_VOID)
4274 else if (gimme == G_SCALAR) {
4278 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4281 *MARK = sv_mortalcopy(TOPs);
4285 *MARK = &PL_sv_undef;
4290 /* in case LEAVE wipes old return values */
4292 for (mark = newsp + 1; mark <= SP; mark++) {
4293 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4294 *mark = sv_mortalcopy(*mark);
4295 TAINT_NOT; /* Each item is independent */
4299 PL_curpm = newpm; /* Don't pop $1 et al till now */
4301 LEAVE_with_name("given");
4305 /* Helper routines used by pp_smartmatch */
4307 S_make_matcher(pTHX_ REGEXP *re)
4310 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4312 PERL_ARGS_ASSERT_MAKE_MATCHER;
4314 PM_SETRE(matcher, ReREFCNT_inc(re));
4316 SAVEFREEOP((OP *) matcher);
4317 ENTER_with_name("matcher"); SAVETMPS;
4323 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4328 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4330 PL_op = (OP *) matcher;
4333 (void) Perl_pp_match(aTHX);
4335 return (SvTRUEx(POPs));
4339 S_destroy_matcher(pTHX_ PMOP *matcher)
4343 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4344 PERL_UNUSED_ARG(matcher);
4347 LEAVE_with_name("matcher");
4350 /* Do a smart match */
4353 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4354 return do_smartmatch(NULL, NULL);
4357 /* This version of do_smartmatch() implements the
4358 * table of smart matches that is found in perlsyn.
4361 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4366 bool object_on_left = FALSE;
4367 SV *e = TOPs; /* e is for 'expression' */
4368 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4370 /* Take care only to invoke mg_get() once for each argument.
4371 * Currently we do this by copying the SV if it's magical. */
4374 d = sv_mortalcopy(d);
4381 e = sv_mortalcopy(e);
4383 /* First of all, handle overload magic of the rightmost argument */
4386 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4387 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4389 tmpsv = amagic_call(d, e, smart_amg, 0);
4396 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4399 SP -= 2; /* Pop the values */
4404 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4411 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4412 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4413 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4415 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4416 object_on_left = TRUE;
4419 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4421 if (object_on_left) {
4422 goto sm_any_sub; /* Treat objects like scalars */
4424 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4425 /* Test sub truth for each key */
4427 bool andedresults = TRUE;
4428 HV *hv = (HV*) SvRV(d);
4429 I32 numkeys = hv_iterinit(hv);
4430 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4433 while ( (he = hv_iternext(hv)) ) {
4434 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4435 ENTER_with_name("smartmatch_hash_key_test");
4438 PUSHs(hv_iterkeysv(he));
4440 c = call_sv(e, G_SCALAR);
4443 andedresults = FALSE;
4445 andedresults = SvTRUEx(POPs) && andedresults;
4447 LEAVE_with_name("smartmatch_hash_key_test");
4454 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4455 /* Test sub truth for each element */
4457 bool andedresults = TRUE;
4458 AV *av = (AV*) SvRV(d);
4459 const I32 len = av_len(av);
4460 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4463 for (i = 0; i <= len; ++i) {
4464 SV * const * const svp = av_fetch(av, i, FALSE);
4465 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4466 ENTER_with_name("smartmatch_array_elem_test");
4472 c = call_sv(e, G_SCALAR);
4475 andedresults = FALSE;
4477 andedresults = SvTRUEx(POPs) && andedresults;
4479 LEAVE_with_name("smartmatch_array_elem_test");
4488 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4489 ENTER_with_name("smartmatch_coderef");
4494 c = call_sv(e, G_SCALAR);
4498 else if (SvTEMP(TOPs))
4499 SvREFCNT_inc_void(TOPs);
4501 LEAVE_with_name("smartmatch_coderef");
4506 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4507 if (object_on_left) {
4508 goto sm_any_hash; /* Treat objects like scalars */
4510 else if (!SvOK(d)) {