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))
45 const PERL_CONTEXT *cx;
48 if (PL_op->op_private & OPpOFFBYONE) {
49 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
52 cxix = dopoptosub(cxstack_ix);
58 switch (cx->blk_gimme) {
77 PMOP *pm = (PMOP*)cLOGOP->op_other;
82 const regexp_engine *eng;
83 bool is_bare_re= FALSE;
85 if (PL_op->op_flags & OPf_STACKED) {
95 /* prevent recompiling under /o and ithreads. */
96 #if defined(USE_ITHREADS)
97 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
104 assert (re != (REGEXP*) &PL_sv_undef);
105 eng = re ? RX_ENGINE(re) : current_re_engine();
107 new_re = (eng->op_comp
109 : &Perl_re_op_compile
110 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
112 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
114 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
116 if (pm->op_pmflags & PMf_HAS_CV)
117 ReANY(new_re)->qr_anoncv
118 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
122 /* The match's LHS's get-magic might need to access this op's regexp
123 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
124 get-magic now before we replace the regexp. Hopefully this hack can
125 be replaced with the approach described at
126 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
128 if (pm->op_type == OP_MATCH) {
130 const bool was_tainted = TAINT_get;
131 if (pm->op_flags & OPf_STACKED)
133 else if (pm->op_targ)
134 lhs = PAD_SV(pm->op_targ);
137 /* Restore the previous value of PL_tainted (which may have been
138 modified by get-magic), to avoid incorrectly setting the
139 RXf_TAINTED flag with RX_TAINT_on further down. */
140 TAINT_set(was_tainted);
141 #ifdef NO_TAINT_SUPPORT
142 PERL_UNUSED_VAR(was_tainted);
145 tmp = reg_temp_copy(NULL, new_re);
146 ReREFCNT_dec(new_re);
152 PM_SETRE(pm, new_re);
156 assert(TAINTING_get || !TAINT_get);
158 SvTAINTED_on((SV*)new_re);
162 /* handle the empty pattern */
163 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) {
164 if (PL_curpm == PL_reg_curpm) {
165 if (PL_curpm_under) {
166 if (PL_curpm_under == PL_reg_curpm) {
167 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
177 #if !defined(USE_ITHREADS)
178 /* can't change the optree at runtime either */
179 /* PMf_KEEP is handled differently under threads to avoid these problems */
180 if (pm->op_pmflags & PMf_KEEP) {
181 cLOGOP->op_first->op_next = PL_op->op_next;
193 PERL_CONTEXT *cx = CX_CUR();
194 PMOP * const pm = (PMOP*) cLOGOP->op_other;
195 SV * const dstr = cx->sb_dstr;
198 char *orig = cx->sb_orig;
199 REGEXP * const rx = cx->sb_rx;
201 REGEXP *old = PM_GETRE(pm);
208 PM_SETRE(pm,ReREFCNT_inc(rx));
211 rxres_restore(&cx->sb_rxres, rx);
213 if (cx->sb_iters++) {
214 const SSize_t saviters = cx->sb_iters;
215 if (cx->sb_iters > cx->sb_maxiters)
216 DIE(aTHX_ "Substitution loop");
218 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
220 /* See "how taint works" above pp_subst() */
222 cx->sb_rxtainted |= SUBST_TAINT_REPL;
223 sv_catsv_nomg(dstr, POPs);
224 if (CxONCE(cx) || s < orig ||
225 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
226 (s == m), cx->sb_targ, NULL,
227 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
229 SV *targ = cx->sb_targ;
231 assert(cx->sb_strend >= s);
232 if(cx->sb_strend > s) {
233 if (DO_UTF8(dstr) && !SvUTF8(targ))
234 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
236 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
238 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
239 cx->sb_rxtainted |= SUBST_TAINT_PAT;
241 if (pm->op_pmflags & PMf_NONDESTRUCT) {
243 /* From here on down we're using the copy, and leaving the
244 original untouched. */
248 SV_CHECK_THINKFIRST_COW_DROP(targ);
249 if (isGV(targ)) Perl_croak_no_modify();
251 SvPV_set(targ, SvPVX(dstr));
252 SvCUR_set(targ, SvCUR(dstr));
253 SvLEN_set(targ, SvLEN(dstr));
256 SvPV_set(dstr, NULL);
259 mPUSHi(saviters - 1);
261 (void)SvPOK_only_UTF8(targ);
264 /* update the taint state of various various variables in
265 * preparation for final exit.
266 * See "how taint works" above pp_subst() */
268 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
269 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
270 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
272 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
274 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
275 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
277 SvTAINTED_on(TOPs); /* taint return value */
278 /* needed for mg_set below */
280 cBOOL(cx->sb_rxtainted &
281 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
285 /* PL_tainted must be correctly set for this mg_set */
294 RETURNOP(pm->op_next);
295 NOT_REACHED; /* NOTREACHED */
297 cx->sb_iters = saviters;
299 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
302 assert(!RX_SUBOFFSET(rx));
303 cx->sb_orig = orig = RX_SUBBEG(rx);
305 cx->sb_strend = s + (cx->sb_strend - m);
307 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
309 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
310 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
312 sv_catpvn_nomg(dstr, s, m-s);
314 cx->sb_s = RX_OFFS(rx)[0].end + orig;
315 { /* Update the pos() information. */
317 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
320 /* the string being matched against may no longer be a string,
321 * e.g. $_=0; s/.../$_++/ge */
324 SvPV_force_nomg_nolen(sv);
326 if (!(mg = mg_find_mglob(sv))) {
327 mg = sv_magicext_mglob(sv);
329 MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
332 (void)ReREFCNT_inc(rx);
333 /* update the taint state of various various variables in preparation
334 * for calling the code block.
335 * See "how taint works" above pp_subst() */
337 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
338 cx->sb_rxtainted |= SUBST_TAINT_PAT;
340 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
341 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
342 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
344 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
346 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
347 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
348 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
349 ? cx->sb_dstr : cx->sb_targ);
352 rxres_save(&cx->sb_rxres, rx);
354 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
358 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
363 PERL_ARGS_ASSERT_RXRES_SAVE;
366 if (!p || p[1] < RX_NPARENS(rx)) {
368 i = 7 + (RX_NPARENS(rx)+1) * 2;
370 i = 6 + (RX_NPARENS(rx)+1) * 2;
379 /* what (if anything) to free on croak */
380 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
381 RX_MATCH_COPIED_off(rx);
382 *p++ = RX_NPARENS(rx);
385 *p++ = PTR2UV(RX_SAVED_COPY(rx));
386 RX_SAVED_COPY(rx) = NULL;
389 *p++ = PTR2UV(RX_SUBBEG(rx));
390 *p++ = (UV)RX_SUBLEN(rx);
391 *p++ = (UV)RX_SUBOFFSET(rx);
392 *p++ = (UV)RX_SUBCOFFSET(rx);
393 for (i = 0; i <= RX_NPARENS(rx); ++i) {
394 *p++ = (UV)RX_OFFS(rx)[i].start;
395 *p++ = (UV)RX_OFFS(rx)[i].end;
400 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
405 PERL_ARGS_ASSERT_RXRES_RESTORE;
408 RX_MATCH_COPY_FREE(rx);
409 RX_MATCH_COPIED_set(rx, *p);
411 RX_NPARENS(rx) = *p++;
414 if (RX_SAVED_COPY(rx))
415 SvREFCNT_dec (RX_SAVED_COPY(rx));
416 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
420 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
421 RX_SUBLEN(rx) = (I32)(*p++);
422 RX_SUBOFFSET(rx) = (I32)*p++;
423 RX_SUBCOFFSET(rx) = (I32)*p++;
424 for (i = 0; i <= RX_NPARENS(rx); ++i) {
425 RX_OFFS(rx)[i].start = (I32)(*p++);
426 RX_OFFS(rx)[i].end = (I32)(*p++);
431 S_rxres_free(pTHX_ void **rsp)
433 UV * const p = (UV*)*rsp;
435 PERL_ARGS_ASSERT_RXRES_FREE;
439 void *tmp = INT2PTR(char*,*p);
442 U32 i = 9 + p[1] * 2;
444 U32 i = 8 + p[1] * 2;
449 SvREFCNT_dec (INT2PTR(SV*,p[2]));
452 PoisonFree(p, i, sizeof(UV));
461 #define FORM_NUM_BLANK (1<<30)
462 #define FORM_NUM_POINT (1<<29)
466 dSP; dMARK; dORIGMARK;
467 SV * const tmpForm = *++MARK;
468 SV *formsv; /* contains text of original format */
469 U32 *fpc; /* format ops program counter */
470 char *t; /* current append position in target string */
471 const char *f; /* current position in format string */
473 SV *sv = NULL; /* current item */
474 const char *item = NULL;/* string value of current item */
475 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
476 I32 itembytes = 0; /* as itemsize, but length in bytes */
477 I32 fieldsize = 0; /* width of current field */
478 I32 lines = 0; /* number of lines that have been output */
479 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
480 const char *chophere = NULL; /* where to chop current item */
481 STRLEN linemark = 0; /* pos of start of line in output */
483 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
484 STRLEN len; /* length of current sv */
485 STRLEN linemax; /* estimate of output size in bytes */
486 bool item_is_utf8 = FALSE;
487 bool targ_is_utf8 = FALSE;
490 U8 *source; /* source of bytes to append */
491 STRLEN to_copy; /* how may bytes to append */
492 char trans; /* what chars to translate */
493 bool copied_form = FALSE; /* have we duplicated the form? */
495 mg = doparseform(tmpForm);
497 fpc = (U32*)mg->mg_ptr;
498 /* the actual string the format was compiled from.
499 * with overload etc, this may not match tmpForm */
503 SvPV_force(PL_formtarget, len);
504 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
505 SvTAINTED_on(PL_formtarget);
506 if (DO_UTF8(PL_formtarget))
508 /* this is an initial estimate of how much output buffer space
509 * to allocate. It may be exceeded later */
510 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
511 t = SvGROW(PL_formtarget, len + linemax + 1);
512 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
514 f = SvPV_const(formsv, len);
518 const char *name = "???";
521 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
522 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
523 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
524 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
525 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
527 case FF_CHECKNL: name = "CHECKNL"; break;
528 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
529 case FF_SPACE: name = "SPACE"; break;
530 case FF_HALFSPACE: name = "HALFSPACE"; break;
531 case FF_ITEM: name = "ITEM"; break;
532 case FF_CHOP: name = "CHOP"; break;
533 case FF_LINEGLOB: name = "LINEGLOB"; break;
534 case FF_NEWLINE: name = "NEWLINE"; break;
535 case FF_MORE: name = "MORE"; break;
536 case FF_LINEMARK: name = "LINEMARK"; break;
537 case FF_END: name = "END"; break;
538 case FF_0DECIMAL: name = "0DECIMAL"; break;
539 case FF_LINESNGL: name = "LINESNGL"; break;
542 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
544 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
547 case FF_LINEMARK: /* start (or end) of a line */
548 linemark = t - SvPVX(PL_formtarget);
553 case FF_LITERAL: /* append <arg> literal chars */
558 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
561 case FF_SKIP: /* skip <arg> chars in format */
565 case FF_FETCH: /* get next item and set field size to <arg> */
574 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
577 SvTAINTED_on(PL_formtarget);
580 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
582 const char *s = item = SvPV_const(sv, len);
583 const char *send = s + len;
586 item_is_utf8 = DO_UTF8(sv);
598 if (itemsize == fieldsize)
601 itembytes = s - item;
606 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
608 const char *s = item = SvPV_const(sv, len);
609 const char *send = s + len;
613 item_is_utf8 = DO_UTF8(sv);
615 /* look for a legal split position */
623 /* provisional split point */
627 /* we delay testing fieldsize until after we've
628 * processed the possible split char directly
629 * following the last field char; so if fieldsize=3
630 * and item="a b cdef", we consume "a b", not "a".
631 * Ditto further down.
633 if (size == fieldsize)
637 if (strchr(PL_chopset, *s)) {
638 /* provisional split point */
639 /* for a non-space split char, we include
640 * the split char; hence the '+1' */
644 if (size == fieldsize)
656 if (!chophere || s == send) {
660 itembytes = chophere - item;
665 case FF_SPACE: /* append padding space (diff of field, item size) */
666 arg = fieldsize - itemsize;
674 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
675 arg = fieldsize - itemsize;
684 case FF_ITEM: /* append a text item, while blanking ctrl chars */
690 case FF_CHOP: /* (for ^*) chop the current item */
691 if (sv != &PL_sv_no) {
692 const char *s = chophere;
694 ((sv == tmpForm || SvSMAGICAL(sv))
695 || (SvGMAGICAL(tmpForm) && !sv_only_taint_gmagic(tmpForm))) ) {
696 /* sv and tmpForm are either the same SV, or magic might allow modification
697 of tmpForm when sv is modified, so copy */
698 SV *newformsv = sv_mortalcopy(formsv);
701 f = SvPV_nolen(newformsv) + (f - SvPV_nolen(formsv));
702 Newx(new_compiled, mg->mg_len / sizeof(U32), U32);
703 memcpy(new_compiled, mg->mg_ptr, mg->mg_len);
704 SAVEFREEPV(new_compiled);
705 fpc = new_compiled + (fpc - (U32*)mg->mg_ptr);
717 /* tied, overloaded or similar strangeness.
718 * Do it the hard way */
719 sv_setpvn(sv, s, len - (s-item));
724 case FF_LINESNGL: /* process ^* */
728 case FF_LINEGLOB: /* process @* */
730 const bool oneline = fpc[-1] == FF_LINESNGL;
731 const char *s = item = SvPV_const(sv, len);
732 const char *const send = s + len;
734 item_is_utf8 = DO_UTF8(sv);
745 to_copy = s - item - 1;
759 /* append to_copy bytes from source to PL_formstring.
760 * item_is_utf8 implies source is utf8.
761 * if trans, translate certain characters during the copy */
766 SvCUR_set(PL_formtarget,
767 t - SvPVX_const(PL_formtarget));
769 if (targ_is_utf8 && !item_is_utf8) {
770 source = tmp = bytes_to_utf8(source, &to_copy);
773 if (item_is_utf8 && !targ_is_utf8) {
775 /* Upgrade targ to UTF8, and then we reduce it to
776 a problem we have a simple solution for.
777 Don't need get magic. */
778 sv_utf8_upgrade_nomg(PL_formtarget);
780 /* re-calculate linemark */
781 s = (U8*)SvPVX(PL_formtarget);
782 /* the bytes we initially allocated to append the
783 * whole line may have been gobbled up during the
784 * upgrade, so allocate a whole new line's worth
789 linemark = s - (U8*)SvPVX(PL_formtarget);
791 /* Easy. They agree. */
792 assert (item_is_utf8 == targ_is_utf8);
795 /* @* and ^* are the only things that can exceed
796 * the linemax, so grow by the output size, plus
797 * a whole new form's worth in case of any further
799 grow = linemax + to_copy;
801 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
802 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
804 Copy(source, t, to_copy, char);
806 /* blank out ~ or control chars, depending on trans.
807 * works on bytes not chars, so relies on not
808 * matching utf8 continuation bytes */
810 U8 *send = s + to_copy;
813 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
820 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
826 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
829 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
832 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
835 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
837 /* If the field is marked with ^ and the value is undefined,
839 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
847 /* overflow evidence */
848 if (num_overflow(value, fieldsize, arg)) {
854 /* Formats aren't yet marked for locales, so assume "yes". */
856 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
858 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
859 STORE_LC_NUMERIC_SET_TO_NEEDED();
860 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
863 const char* qfmt = quadmath_format_single(fmt);
866 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
867 len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
869 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
874 /* we generate fmt ourselves so it is safe */
875 GCC_DIAG_IGNORE(-Wformat-nonliteral);
876 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
879 PERL_MY_SNPRINTF_POST_GUARD(len, max);
880 RESTORE_LC_NUMERIC();
885 case FF_NEWLINE: /* delete trailing spaces, then append \n */
887 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
892 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
895 if (arg) { /* repeat until fields exhausted? */
901 t = SvPVX(PL_formtarget) + linemark;
906 case FF_MORE: /* replace long end of string with '...' */
908 const char *s = chophere;
909 const char *send = item + len;
911 while (isSPACE(*s) && (s < send))
916 arg = fieldsize - itemsize;
923 if (strnEQ(s1," ",3)) {
924 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
934 case FF_END: /* tidy up, then return */
936 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
938 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
940 SvUTF8_on(PL_formtarget);
941 FmLINES(PL_formtarget) += lines;
943 if (fpc[-1] == FF_BLANK)
944 RETURNOP(cLISTOP->op_first);
951 /* also used for: pp_mapstart() */
957 if (PL_stack_base + TOPMARK == SP) {
959 if (GIMME_V == G_SCALAR)
961 RETURNOP(PL_op->op_next->op_next);
963 PL_stack_sp = PL_stack_base + TOPMARK + 1;
964 Perl_pp_pushmark(aTHX); /* push dst */
965 Perl_pp_pushmark(aTHX); /* push src */
966 ENTER_with_name("grep"); /* enter outer scope */
970 ENTER_with_name("grep_item"); /* enter inner scope */
973 src = PL_stack_base[TOPMARK];
975 src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
982 if (PL_op->op_type == OP_MAPSTART)
983 Perl_pp_pushmark(aTHX); /* push top */
984 return ((LOGOP*)PL_op->op_next)->op_other;
990 const U8 gimme = GIMME_V;
991 I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
997 /* first, move source pointer to the next item in the source list */
998 ++PL_markstack_ptr[-1];
1000 /* if there are new items, push them into the destination list */
1001 if (items && gimme != G_VOID) {
1002 /* might need to make room back there first */
1003 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1004 /* XXX this implementation is very pessimal because the stack
1005 * is repeatedly extended for every set of items. Is possible
1006 * to do this without any stack extension or copying at all
1007 * by maintaining a separate list over which the map iterates
1008 * (like foreach does). --gsar */
1010 /* everything in the stack after the destination list moves
1011 * towards the end the stack by the amount of room needed */
1012 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1014 /* items to shift up (accounting for the moved source pointer) */
1015 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1017 /* This optimization is by Ben Tilly and it does
1018 * things differently from what Sarathy (gsar)
1019 * is describing. The downside of this optimization is
1020 * that leaves "holes" (uninitialized and hopefully unused areas)
1021 * to the Perl stack, but on the other hand this
1022 * shouldn't be a problem. If Sarathy's idea gets
1023 * implemented, this optimization should become
1024 * irrelevant. --jhi */
1026 shift = count; /* Avoid shifting too often --Ben Tilly */
1030 dst = (SP += shift);
1031 PL_markstack_ptr[-1] += shift;
1032 *PL_markstack_ptr += shift;
1036 /* copy the new items down to the destination list */
1037 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1038 if (gimme == G_ARRAY) {
1039 /* add returned items to the collection (making mortal copies
1040 * if necessary), then clear the current temps stack frame
1041 * *except* for those items. We do this splicing the items
1042 * into the start of the tmps frame (so some items may be on
1043 * the tmps stack twice), then moving PL_tmps_floor above
1044 * them, then freeing the frame. That way, the only tmps that
1045 * accumulate over iterations are the return values for map.
1046 * We have to do to this way so that everything gets correctly
1047 * freed if we die during the map.
1051 /* make space for the slice */
1052 EXTEND_MORTAL(items);
1053 tmpsbase = PL_tmps_floor + 1;
1054 Move(PL_tmps_stack + tmpsbase,
1055 PL_tmps_stack + tmpsbase + items,
1056 PL_tmps_ix - PL_tmps_floor,
1058 PL_tmps_ix += items;
1063 sv = sv_mortalcopy(sv);
1065 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1067 /* clear the stack frame except for the items */
1068 PL_tmps_floor += items;
1070 /* FREETMPS may have cleared the TEMP flag on some of the items */
1073 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1076 /* scalar context: we don't care about which values map returns
1077 * (we use undef here). And so we certainly don't want to do mortal
1078 * copies of meaningless values. */
1079 while (items-- > 0) {
1081 *dst-- = &PL_sv_undef;
1089 LEAVE_with_name("grep_item"); /* exit inner scope */
1092 if (PL_markstack_ptr[-1] > TOPMARK) {
1094 (void)POPMARK; /* pop top */
1095 LEAVE_with_name("grep"); /* exit outer scope */
1096 (void)POPMARK; /* pop src */
1097 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1098 (void)POPMARK; /* pop dst */
1099 SP = PL_stack_base + POPMARK; /* pop original mark */
1100 if (gimme == G_SCALAR) {
1104 else if (gimme == G_ARRAY)
1111 ENTER_with_name("grep_item"); /* enter inner scope */
1114 /* set $_ to the new source item */
1115 src = PL_stack_base[PL_markstack_ptr[-1]];
1116 if (SvPADTMP(src)) {
1117 src = sv_mortalcopy(src);
1122 RETURNOP(cLOGOP->op_other);
1130 if (GIMME_V == G_ARRAY)
1132 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1133 return cLOGOP->op_other;
1142 if (GIMME_V == G_ARRAY) {
1143 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1147 SV * const targ = PAD_SV(PL_op->op_targ);
1150 if (PL_op->op_private & OPpFLIP_LINENUM) {
1151 if (GvIO(PL_last_in_gv)) {
1152 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1155 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1157 flip = SvIV(sv) == SvIV(GvSV(gv));
1163 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1164 if (PL_op->op_flags & OPf_SPECIAL) {
1172 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1181 /* This code tries to decide if "$left .. $right" should use the
1182 magical string increment, or if the range is numeric (we make
1183 an exception for .."0" [#18165]). AMS 20021031. */
1185 #define RANGE_IS_NUMERIC(left,right) ( \
1186 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1187 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1188 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1189 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1190 && (!SvOK(right) || looks_like_number(right))))
1196 if (GIMME_V == G_ARRAY) {
1202 if (RANGE_IS_NUMERIC(left,right)) {
1204 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1205 (SvOK(right) && (SvIOK(right)
1206 ? SvIsUV(right) && SvUV(right) > IV_MAX
1207 : SvNV_nomg(right) > IV_MAX)))
1208 DIE(aTHX_ "Range iterator outside integer range");
1209 i = SvIV_nomg(left);
1210 j = SvIV_nomg(right);
1212 /* Dance carefully around signed max. */
1213 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1216 /* The wraparound of signed integers is undefined
1217 * behavior, but here we aim for count >=1, and
1218 * negative count is just wrong. */
1220 #if IVSIZE > Size_t_size
1227 Perl_croak(aTHX_ "Out of memory during list extend");
1234 SV * const sv = sv_2mortal(newSViv(i));
1236 if (n) /* avoid incrementing above IV_MAX */
1242 const char * const lpv = SvPV_nomg_const(left, llen);
1243 const char * const tmps = SvPV_nomg_const(right, len);
1245 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1246 if (DO_UTF8(right) && IN_UNI_8_BIT)
1247 len = sv_len_utf8_nomg(right);
1248 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1250 if (strEQ(SvPVX_const(sv),tmps))
1252 sv = sv_2mortal(newSVsv(sv));
1259 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1263 if (PL_op->op_private & OPpFLIP_LINENUM) {
1264 if (GvIO(PL_last_in_gv)) {
1265 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1268 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1269 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1277 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1278 sv_catpvs(targ, "E0");
1288 static const char * const context_name[] = {
1290 NULL, /* CXt_WHEN never actually needs "block" */
1291 NULL, /* CXt_BLOCK never actually needs "block" */
1292 NULL, /* CXt_GIVEN never actually needs "block" */
1293 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1294 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1295 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1296 NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1297 NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1305 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1309 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1311 for (i = cxstack_ix; i >= 0; i--) {
1312 const PERL_CONTEXT * const cx = &cxstack[i];
1313 switch (CxTYPE(cx)) {
1319 /* diag_listed_as: Exiting subroutine via %s */
1320 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1321 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1322 if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1325 case CXt_LOOP_PLAIN:
1326 case CXt_LOOP_LAZYIV:
1327 case CXt_LOOP_LAZYSV:
1331 STRLEN cx_label_len = 0;
1332 U32 cx_label_flags = 0;
1333 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1335 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1338 (const U8*)cx_label, cx_label_len,
1339 (const U8*)label, len) == 0)
1341 (const U8*)label, len,
1342 (const U8*)cx_label, cx_label_len) == 0)
1343 : (len == cx_label_len && ((cx_label == label)
1344 || memEQ(cx_label, label, len))) )) {
1345 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1346 (long)i, cx_label));
1349 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1360 Perl_dowantarray(pTHX)
1362 const U8 gimme = block_gimme();
1363 return (gimme == G_VOID) ? G_SCALAR : gimme;
1367 Perl_block_gimme(pTHX)
1369 const I32 cxix = dopoptosub(cxstack_ix);
1374 gimme = (cxstack[cxix].blk_gimme & G_WANT);
1376 Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1382 Perl_is_lvalue_sub(pTHX)
1384 const I32 cxix = dopoptosub(cxstack_ix);
1385 assert(cxix >= 0); /* We should only be called from inside subs */
1387 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1388 return CxLVAL(cxstack + cxix);
1393 /* only used by cx_pushsub() */
1395 Perl_was_lvalue_sub(pTHX)
1397 const I32 cxix = dopoptosub(cxstack_ix-1);
1398 assert(cxix >= 0); /* We should only be called from inside subs */
1400 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1401 return CxLVAL(cxstack + cxix);
1407 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1411 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1413 PERL_UNUSED_CONTEXT;
1416 for (i = startingblock; i >= 0; i--) {
1417 const PERL_CONTEXT * const cx = &cxstk[i];
1418 switch (CxTYPE(cx)) {
1422 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1423 * twice; the first for the normal foo() call, and the second
1424 * for a faked up re-entry into the sub to execute the
1425 * code block. Hide this faked entry from the world. */
1426 if (cx->cx_type & CXp_SUB_RE_FAKE)
1431 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1439 S_dopoptoeval(pTHX_ I32 startingblock)
1442 for (i = startingblock; i >= 0; i--) {
1443 const PERL_CONTEXT *cx = &cxstack[i];
1444 switch (CxTYPE(cx)) {
1448 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1456 S_dopoptoloop(pTHX_ I32 startingblock)
1459 for (i = startingblock; i >= 0; i--) {
1460 const PERL_CONTEXT * const cx = &cxstack[i];
1461 switch (CxTYPE(cx)) {
1467 /* diag_listed_as: Exiting subroutine via %s */
1468 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1469 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1470 if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1473 case CXt_LOOP_PLAIN:
1474 case CXt_LOOP_LAZYIV:
1475 case CXt_LOOP_LAZYSV:
1478 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1485 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1488 S_dopoptogivenfor(pTHX_ I32 startingblock)
1491 for (i = startingblock; i >= 0; i--) {
1492 const PERL_CONTEXT *cx = &cxstack[i];
1493 switch (CxTYPE(cx)) {
1497 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1499 case CXt_LOOP_PLAIN:
1500 assert(!(cx->cx_type & CXp_FOR_DEF));
1502 case CXt_LOOP_LAZYIV:
1503 case CXt_LOOP_LAZYSV:
1506 if (cx->cx_type & CXp_FOR_DEF) {
1507 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1516 S_dopoptowhen(pTHX_ I32 startingblock)
1519 for (i = startingblock; i >= 0; i--) {
1520 const PERL_CONTEXT *cx = &cxstack[i];
1521 switch (CxTYPE(cx)) {
1525 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1532 /* dounwind(): pop all contexts above (but not including) cxix.
1533 * Note that it clears the savestack frame associated with each popped
1534 * context entry, but doesn't free any temps.
1535 * It does a cx_popblock() of the last frame that it pops, and leaves
1536 * cxstack_ix equal to cxix.
1540 Perl_dounwind(pTHX_ I32 cxix)
1542 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1545 while (cxstack_ix > cxix) {
1546 PERL_CONTEXT *cx = CX_CUR();
1548 CX_DEBUG(cx, "UNWIND");
1549 /* Note: we don't need to restore the base context info till the end. */
1553 switch (CxTYPE(cx)) {
1556 /* CXt_SUBST is not a block context type, so skip the
1557 * cx_popblock(cx) below */
1558 if (cxstack_ix == cxix + 1) {
1569 case CXt_LOOP_PLAIN:
1570 case CXt_LOOP_LAZYIV:
1571 case CXt_LOOP_LAZYSV:
1584 /* these two don't have a POPFOO() */
1590 if (cxstack_ix == cxix + 1) {
1599 Perl_qerror(pTHX_ SV *err)
1601 PERL_ARGS_ASSERT_QERROR;
1604 if (PL_in_eval & EVAL_KEEPERR) {
1605 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1609 sv_catsv(ERRSV, err);
1612 sv_catsv(PL_errors, err);
1614 Perl_warn(aTHX_ "%" SVf, SVfARG(err));
1616 ++PL_parser->error_count;
1621 /* pop a CXt_EVAL context and in addition, if it was a require then
1623 * 0: do nothing extra;
1624 * 1: undef $INC{$name}; croak "$name did not return a true value";
1625 * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1629 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1631 SV *namesv = NULL; /* init to avoid dumb compiler warning */
1635 do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1637 /* keep namesv alive after cx_popeval() */
1638 namesv = cx->blk_eval.old_namesv;
1639 cx->blk_eval.old_namesv = NULL;
1648 HV *inc_hv = GvHVn(PL_incgv);
1649 I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv);
1650 const char *key = SvPVX_const(namesv);
1653 (void)hv_delete(inc_hv, key, klen, G_DISCARD);
1654 fmt = "%" SVf " did not return a true value";
1658 (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0);
1659 fmt = "%" SVf "Compilation failed in require";
1661 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1664 Perl_croak(aTHX_ fmt, SVfARG(errsv));
1669 /* die_unwind(): this is the final destination for the various croak()
1670 * functions. If we're in an eval, unwind the context and other stacks
1671 * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1672 * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1673 * to is a require the exception will be rethrown, as requires don't
1674 * actually trap exceptions.
1678 Perl_die_unwind(pTHX_ SV *msv)
1681 U8 in_eval = PL_in_eval;
1682 PERL_ARGS_ASSERT_DIE_UNWIND;
1687 exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1690 * Historically, perl used to set ERRSV ($@) early in the die
1691 * process and rely on it not getting clobbered during unwinding.
1692 * That sucked, because it was liable to get clobbered, so the
1693 * setting of ERRSV used to emit the exception from eval{} has
1694 * been moved to much later, after unwinding (see just before
1695 * JMPENV_JUMP below). However, some modules were relying on the
1696 * early setting, by examining $@ during unwinding to use it as
1697 * a flag indicating whether the current unwinding was caused by
1698 * an exception. It was never a reliable flag for that purpose,
1699 * being totally open to false positives even without actual
1700 * clobberage, but was useful enough for production code to
1701 * semantically rely on it.
1703 * We'd like to have a proper introspective interface that
1704 * explicitly describes the reason for whatever unwinding
1705 * operations are currently in progress, so that those modules
1706 * work reliably and $@ isn't further overloaded. But we don't
1707 * have one yet. In its absence, as a stopgap measure, ERRSV is
1708 * now *additionally* set here, before unwinding, to serve as the
1709 * (unreliable) flag that it used to.
1711 * This behaviour is temporary, and should be removed when a
1712 * proper way to detect exceptional unwinding has been developed.
1713 * As of 2010-12, the authors of modules relying on the hack
1714 * are aware of the issue, because the modules failed on
1715 * perls 5.13.{1..7} which had late setting of $@ without this
1716 * early-setting hack.
1718 if (!(in_eval & EVAL_KEEPERR))
1719 sv_setsv_flags(ERRSV, exceptsv,
1720 (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
1722 if (in_eval & EVAL_KEEPERR) {
1723 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1727 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1728 && PL_curstackinfo->si_prev)
1738 JMPENV *restartjmpenv;
1741 if (cxix < cxstack_ix)
1745 assert(CxTYPE(cx) == CXt_EVAL);
1747 /* return false to the caller of eval */
1748 oldsp = PL_stack_base + cx->blk_oldsp;
1749 gimme = cx->blk_gimme;
1750 if (gimme == G_SCALAR)
1751 *++oldsp = &PL_sv_undef;
1752 PL_stack_sp = oldsp;
1754 restartjmpenv = cx->blk_eval.cur_top_env;
1755 restartop = cx->blk_eval.retop;
1756 /* Note that unlike pp_entereval, pp_require isn't supposed to
1757 * trap errors. So if we're a require, after we pop the
1758 * CXt_EVAL that pp_require pushed, rethrow the error with
1759 * croak(exceptsv). This is all handled by the call below when
1762 S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
1764 if (!(in_eval & EVAL_KEEPERR))
1765 sv_setsv(ERRSV, exceptsv);
1766 PL_restartjmpenv = restartjmpenv;
1767 PL_restartop = restartop;
1769 NOT_REACHED; /* NOTREACHED */
1773 write_to_stderr(exceptsv);
1775 NOT_REACHED; /* NOTREACHED */
1781 if (SvTRUE(left) != SvTRUE(right))
1789 =head1 CV Manipulation Functions
1791 =for apidoc caller_cx
1793 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1794 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1795 information returned to Perl by C<caller>. Note that XSUBs don't get a
1796 stack frame, so C<caller_cx(0, NULL)> will return information for the
1797 immediately-surrounding Perl code.
1799 This function skips over the automatic calls to C<&DB::sub> made on the
1800 behalf of the debugger. If the stack frame requested was a sub called by
1801 C<DB::sub>, the return value will be the frame for the call to
1802 C<DB::sub>, since that has the correct line number/etc. for the call
1803 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1804 frame for the sub call itself.
1809 const PERL_CONTEXT *
1810 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1812 I32 cxix = dopoptosub(cxstack_ix);
1813 const PERL_CONTEXT *cx;
1814 const PERL_CONTEXT *ccstack = cxstack;
1815 const PERL_SI *top_si = PL_curstackinfo;
1818 /* we may be in a higher stacklevel, so dig down deeper */
1819 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1820 top_si = top_si->si_prev;
1821 ccstack = top_si->si_cxstack;
1822 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1826 /* caller() should not report the automatic calls to &DB::sub */
1827 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1828 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1832 cxix = dopoptosub_at(ccstack, cxix - 1);
1835 cx = &ccstack[cxix];
1836 if (dbcxp) *dbcxp = cx;
1838 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1839 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1840 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1841 field below is defined for any cx. */
1842 /* caller() should not report the automatic calls to &DB::sub */
1843 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1844 cx = &ccstack[dbcxix];
1853 const PERL_CONTEXT *cx;
1854 const PERL_CONTEXT *dbcx;
1856 const HEK *stash_hek;
1858 bool has_arg = MAXARG && TOPs;
1867 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1869 if (gimme != G_ARRAY) {
1876 CX_DEBUG(cx, "CALLER");
1877 assert(CopSTASH(cx->blk_oldcop));
1878 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1879 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1881 if (gimme != G_ARRAY) {
1884 PUSHs(&PL_sv_undef);
1887 sv_sethek(TARG, stash_hek);
1896 PUSHs(&PL_sv_undef);
1899 sv_sethek(TARG, stash_hek);
1902 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1903 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1904 cx->blk_sub.retop, TRUE);
1906 lcop = cx->blk_oldcop;
1907 mPUSHu(CopLINE(lcop));
1910 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1911 /* So is ccstack[dbcxix]. */
1912 if (CvHASGV(dbcx->blk_sub.cv)) {
1913 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1914 PUSHs(boolSV(CxHASARGS(cx)));
1917 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1918 PUSHs(boolSV(CxHASARGS(cx)));
1922 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1925 gimme = cx->blk_gimme;
1926 if (gimme == G_VOID)
1927 PUSHs(&PL_sv_undef);
1929 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1930 if (CxTYPE(cx) == CXt_EVAL) {
1932 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1933 SV *cur_text = cx->blk_eval.cur_text;
1934 if (SvCUR(cur_text) >= 2) {
1935 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1936 SvUTF8(cur_text)|SVs_TEMP));
1939 /* I think this is will always be "", but be sure */
1940 PUSHs(sv_2mortal(newSVsv(cur_text)));
1946 else if (cx->blk_eval.old_namesv) {
1947 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1950 /* eval BLOCK (try blocks have old_namesv == 0) */
1952 PUSHs(&PL_sv_undef);
1953 PUSHs(&PL_sv_undef);
1957 PUSHs(&PL_sv_undef);
1958 PUSHs(&PL_sv_undef);
1960 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1961 && CopSTASH_eq(PL_curcop, PL_debstash))
1963 /* slot 0 of the pad contains the original @_ */
1964 AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
1965 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1966 cx->blk_sub.olddepth+1]))[0]);
1967 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1969 Perl_init_dbargs(aTHX);
1971 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1972 av_extend(PL_dbargs, AvFILLp(ary) + off);
1973 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1974 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1976 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1979 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1981 if (old_warnings == pWARN_NONE)
1982 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1983 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1984 mask = &PL_sv_undef ;
1985 else if (old_warnings == pWARN_ALL ||
1986 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1987 /* Get the bit mask for $warnings::Bits{all}, because
1988 * it could have been extended by warnings::register */
1990 HV * const bits = get_hv("warnings::Bits", 0);
1991 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1992 mask = newSVsv(*bits_all);
1995 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1999 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
2003 PUSHs(cx->blk_oldcop->cop_hints_hash ?
2004 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2014 if (MAXARG < 1 || (!TOPs && !POPs))
2015 tmps = NULL, len = 0;
2017 tmps = SvPVx_const(POPs, len);
2018 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
2023 /* like pp_nextstate, but used instead when the debugger is active */
2027 PL_curcop = (COP*)PL_op;
2028 TAINT_NOT; /* Each statement is presumed innocent */
2029 PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
2034 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2035 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2039 const U8 gimme = G_ARRAY;
2040 GV * const gv = PL_DBgv;
2043 if (gv && isGV_with_GP(gv))
2046 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
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 */
2060 (void)(*CvXSUB(cv))(aTHX_ cv);
2066 cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
2067 cx_pushsub(cx, cv, PL_op->op_next, 0);
2068 /* OP_DBSTATE's op_private holds hint bits rather than
2069 * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2070 * any CxLVAL() flags that have now been mis-calculated */
2077 if (CvDEPTH(cv) >= 2)
2078 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2079 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2080 RETURNOP(CvSTART(cv));
2092 (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2104 assert(CxTYPE(cx) == CXt_BLOCK);
2106 if (PL_op->op_flags & OPf_SPECIAL)
2107 /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */
2108 cx->blk_oldpm = PL_curpm;
2110 oldsp = PL_stack_base + cx->blk_oldsp;
2111 gimme = cx->blk_gimme;
2113 if (gimme == G_VOID)
2114 PL_stack_sp = oldsp;
2116 leave_adjust_stacks(oldsp, oldsp, gimme,
2117 PL_op->op_private & OPpLVALUE ? 3 : 1);
2127 S_outside_integer(pTHX_ SV *sv)
2130 const NV nv = SvNV_nomg(sv);
2131 if (Perl_isinfnan(nv))
2133 #ifdef NV_PRESERVES_UV
2134 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2137 if (nv <= (NV)IV_MIN)
2140 ((nv > (NV)UV_MAX ||
2141 SvUV_nomg(sv) > (UV)IV_MAX)))
2152 const U8 gimme = GIMME_V;
2153 void *itervarp; /* GV or pad slot of the iteration variable */
2154 SV *itersave; /* the old var in the iterator var slot */
2157 if (PL_op->op_targ) { /* "my" variable */
2158 itervarp = &PAD_SVl(PL_op->op_targ);
2159 itersave = *(SV**)itervarp;
2161 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2162 /* the SV currently in the pad slot is never live during
2163 * iteration (the slot is always aliased to one of the items)
2164 * so it's always stale */
2165 SvPADSTALE_on(itersave);
2167 SvREFCNT_inc_simple_void_NN(itersave);
2168 cxflags = CXp_FOR_PAD;
2171 SV * const sv = POPs;
2172 itervarp = (void *)sv;
2173 if (LIKELY(isGV(sv))) { /* symbol table variable */
2174 itersave = GvSV(sv);
2175 SvREFCNT_inc_simple_void(itersave);
2176 cxflags = CXp_FOR_GV;
2177 if (PL_op->op_private & OPpITER_DEF)
2178 cxflags |= CXp_FOR_DEF;
2180 else { /* LV ref: for \$foo (...) */
2181 assert(SvTYPE(sv) == SVt_PVMG);
2182 assert(SvMAGIC(sv));
2183 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2185 cxflags = CXp_FOR_LVREF;
2188 /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2189 assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2191 /* Note that this context is initially set as CXt_NULL. Further on
2192 * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2193 * there mustn't be anything in the blk_loop substruct that requires
2194 * freeing or undoing, in case we die in the meantime. And vice-versa.
2196 cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2197 cx_pushloop_for(cx, itervarp, itersave);
2199 if (PL_op->op_flags & OPf_STACKED) {
2200 /* OPf_STACKED implies either a single array: for(@), with a
2201 * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2203 SV *maybe_ary = POPs;
2204 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2207 SV * const right = maybe_ary;
2208 if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2209 DIE(aTHX_ "Assigned value is not a reference");
2212 if (RANGE_IS_NUMERIC(sv,right)) {
2213 cx->cx_type |= CXt_LOOP_LAZYIV;
2214 if (S_outside_integer(aTHX_ sv) ||
2215 S_outside_integer(aTHX_ right))
2216 DIE(aTHX_ "Range iterator outside integer range");
2217 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2218 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2221 cx->cx_type |= CXt_LOOP_LAZYSV;
2222 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2223 cx->blk_loop.state_u.lazysv.end = right;
2224 SvREFCNT_inc_simple_void_NN(right);
2225 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2226 /* This will do the upgrade to SVt_PV, and warn if the value
2227 is uninitialised. */
2228 (void) SvPV_nolen_const(right);
2229 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2230 to replace !SvOK() with a pointer to "". */
2232 SvREFCNT_dec(right);
2233 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2237 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2238 /* for (@array) {} */
2239 cx->cx_type |= CXt_LOOP_ARY;
2240 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2241 SvREFCNT_inc_simple_void_NN(maybe_ary);
2242 cx->blk_loop.state_u.ary.ix =
2243 (PL_op->op_private & OPpITER_REVERSED) ?
2244 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2247 /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
2249 else { /* iterating over items on the stack */
2250 cx->cx_type |= CXt_LOOP_LIST;
2251 cx->blk_oldsp = SP - PL_stack_base;
2252 cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2253 cx->blk_loop.state_u.stack.ix =
2254 (PL_op->op_private & OPpITER_REVERSED)
2256 : cx->blk_loop.state_u.stack.basesp;
2257 /* pre-extend stack so pp_iter doesn't have to check every time
2258 * it pushes yes/no */
2268 const U8 gimme = GIMME_V;
2270 cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2271 cx_pushloop_plain(cx);
2284 assert(CxTYPE_is_LOOP(cx));
2285 oldsp = PL_stack_base + cx->blk_oldsp;
2286 base = CxTYPE(cx) == CXt_LOOP_LIST
2287 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2289 gimme = cx->blk_gimme;
2291 if (gimme == G_VOID)
2294 leave_adjust_stacks(oldsp, base, gimme,
2295 PL_op->op_private & OPpLVALUE ? 3 : 1);
2298 cx_poploop(cx); /* Stack values are safe: release loop vars ... */
2306 /* This duplicates most of pp_leavesub, but with additional code to handle
2307 * return args in lvalue context. It was forked from pp_leavesub to
2308 * avoid slowing down that function any further.
2310 * Any changes made to this function may need to be copied to pp_leavesub
2313 * also tail-called by pp_return
2324 assert(CxTYPE(cx) == CXt_SUB);
2326 if (CxMULTICALL(cx)) {
2327 /* entry zero of a stack is always PL_sv_undef, which
2328 * simplifies converting a '()' return into undef in scalar context */
2329 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2333 gimme = cx->blk_gimme;
2334 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2336 if (gimme == G_VOID)
2337 PL_stack_sp = oldsp;
2339 U8 lval = CxLVAL(cx);
2340 bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2341 const char *what = NULL;
2343 if (gimme == G_SCALAR) {
2345 /* check for bad return arg */
2346 if (oldsp < PL_stack_sp) {
2347 SV *sv = *PL_stack_sp;
2348 if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2350 SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2351 : "a readonly value" : "a temporary";
2356 /* sub:lvalue{} will take us here. */
2361 "Can't return %s from lvalue subroutine", what);
2365 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2367 if (lval & OPpDEREF) {
2368 /* lval_sub()->{...} and similar */
2372 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2378 assert(gimme == G_ARRAY);
2379 assert (!(lval & OPpDEREF));
2382 /* scan for bad return args */
2384 for (p = PL_stack_sp; p > oldsp; p--) {
2386 /* the PL_sv_undef exception is to allow things like
2387 * this to work, where PL_sv_undef acts as 'skip'
2388 * placeholder on the LHS of list assigns:
2389 * sub foo :lvalue { undef }
2390 * ($a, undef, foo(), $b) = 1..4;
2392 if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2394 /* Might be flattened array after $#array = */
2395 what = SvREADONLY(sv)
2396 ? "a readonly value" : "a temporary";
2402 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2407 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
2409 retop = cx->blk_sub.retop;
2420 const I32 cxix = dopoptosub(cxstack_ix);
2422 assert(cxstack_ix >= 0);
2423 if (cxix < cxstack_ix) {
2425 if (!( PL_curstackinfo->si_type == PERLSI_SORT
2426 || ( PL_curstackinfo->si_type == PERLSI_MULTICALL
2427 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2430 DIE(aTHX_ "Can't return outside a subroutine");
2432 * a sort block, which is a CXt_NULL not a CXt_SUB;
2433 * or a /(?{...})/ block.
2434 * Handle specially. */
2435 assert(CxTYPE(&cxstack[0]) == CXt_NULL
2436 || ( CxTYPE(&cxstack[0]) == CXt_SUB
2437 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2438 if (cxstack_ix > 0) {
2439 /* See comment below about context popping. Since we know
2440 * we're scalar and not lvalue, we can preserve the return
2441 * value in a simpler fashion than there. */
2443 assert(cxstack[0].blk_gimme == G_SCALAR);
2444 if ( (sp != PL_stack_base)
2445 && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2447 *SP = sv_mortalcopy(sv);
2450 /* caller responsible for popping cxstack[0] */
2454 /* There are contexts that need popping. Doing this may free the
2455 * return value(s), so preserve them first: e.g. popping the plain
2456 * loop here would free $x:
2457 * sub f { { my $x = 1; return $x } }
2458 * We may also need to shift the args down; for example,
2459 * for (1,2) { return 3,4 }
2460 * leaves 1,2,3,4 on the stack. Both these actions will be done by
2461 * leave_adjust_stacks(), along with freeing any temps. Note that
2462 * whoever we tail-call (e.g. pp_leaveeval) will also call
2463 * leave_adjust_stacks(); however, the second call is likely to
2464 * just see a bunch of SvTEMPs with a ref count of 1, and so just
2465 * pass them through, rather than copying them again. So this
2466 * isn't as inefficient as it sounds.
2468 cx = &cxstack[cxix];
2470 if (cx->blk_gimme != G_VOID)
2471 leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2473 CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2477 cx = &cxstack[cxix]; /* CX stack may have been realloced */
2480 /* Like in the branch above, we need to handle any extra junk on
2481 * the stack. But because we're not also popping extra contexts, we
2482 * don't have to worry about prematurely freeing args. So we just
2483 * need to do the bare minimum to handle junk, and leave the main
2484 * arg processing in the function we tail call, e.g. pp_leavesub.
2485 * In list context we have to splice out the junk; in scalar
2486 * context we can leave as-is (pp_leavesub will later return the
2487 * top stack element). But for an empty arg list, e.g.
2488 * for (1,2) { return }
2489 * we need to set sp = oldsp so that pp_leavesub knows to push
2490 * &PL_sv_undef onto the stack.
2493 cx = &cxstack[cxix];
2494 oldsp = PL_stack_base + cx->blk_oldsp;
2495 if (oldsp != MARK) {
2496 SSize_t nargs = SP - MARK;
2498 if (cx->blk_gimme == G_ARRAY) {
2499 /* shift return args to base of call stack frame */
2500 Move(MARK + 1, oldsp + 1, nargs, SV*);
2501 PL_stack_sp = oldsp + nargs;
2505 PL_stack_sp = oldsp;
2509 /* fall through to a normal exit */
2510 switch (CxTYPE(cx)) {
2512 return CxTRYBLOCK(cx)
2513 ? Perl_pp_leavetry(aTHX)
2514 : Perl_pp_leaveeval(aTHX);
2516 return CvLVALUE(cx->blk_sub.cv)
2517 ? Perl_pp_leavesublv(aTHX)
2518 : Perl_pp_leavesub(aTHX);
2520 return Perl_pp_leavewrite(aTHX);
2522 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2526 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2528 static PERL_CONTEXT *
2532 if (PL_op->op_flags & OPf_SPECIAL) {
2533 cxix = dopoptoloop(cxstack_ix);
2535 /* diag_listed_as: Can't "last" outside a loop block */
2536 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2542 const char * const label =
2543 PL_op->op_flags & OPf_STACKED
2544 ? SvPV(TOPs,label_len)
2545 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2546 const U32 label_flags =
2547 PL_op->op_flags & OPf_STACKED
2549 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2551 cxix = dopoptolabel(label, label_len, label_flags);
2553 /* diag_listed_as: Label not found for "last %s" */
2554 Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"",
2556 SVfARG(PL_op->op_flags & OPf_STACKED
2557 && !SvGMAGICAL(TOPp1s)
2559 : newSVpvn_flags(label,
2561 label_flags | SVs_TEMP)));
2563 if (cxix < cxstack_ix)
2565 return &cxstack[cxix];
2574 cx = S_unwind_loop(aTHX);
2576 assert(CxTYPE_is_LOOP(cx));
2577 PL_stack_sp = PL_stack_base
2578 + (CxTYPE(cx) == CXt_LOOP_LIST
2579 ? cx->blk_loop.state_u.stack.basesp
2585 /* Stack values are safe: */
2587 cx_poploop(cx); /* release loop vars ... */
2589 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2599 /* if not a bare 'next' in the main scope, search for it */
2601 if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
2602 cx = S_unwind_loop(aTHX);
2605 PL_curcop = cx->blk_oldcop;
2607 return (cx)->blk_loop.my_op->op_nextop;
2612 PERL_CONTEXT *cx = S_unwind_loop(aTHX);
2613 OP* redo_op = cx->blk_loop.my_op->op_redoop;
2615 if (redo_op->op_type == OP_ENTER) {
2616 /* pop one less context to avoid $x being freed in while (my $x..) */
2619 assert(CxTYPE(cx) == CXt_BLOCK);
2620 redo_op = redo_op->op_next;
2626 PL_curcop = cx->blk_oldcop;
2632 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2635 static const char* const too_deep = "Target of goto is too deeply nested";
2637 PERL_ARGS_ASSERT_DOFINDLABEL;
2640 Perl_croak(aTHX_ "%s", too_deep);
2641 if (o->op_type == OP_LEAVE ||
2642 o->op_type == OP_SCOPE ||
2643 o->op_type == OP_LEAVELOOP ||
2644 o->op_type == OP_LEAVESUB ||
2645 o->op_type == OP_LEAVETRY)
2647 *ops++ = cUNOPo->op_first;
2649 Perl_croak(aTHX_ "%s", too_deep);
2652 if (o->op_flags & OPf_KIDS) {
2654 /* First try all the kids at this level, since that's likeliest. */
2655 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2656 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2657 STRLEN kid_label_len;
2658 U32 kid_label_flags;
2659 const char *kid_label = CopLABEL_len_flags(kCOP,
2660 &kid_label_len, &kid_label_flags);
2662 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2665 (const U8*)kid_label, kid_label_len,
2666 (const U8*)label, len) == 0)
2668 (const U8*)label, len,
2669 (const U8*)kid_label, kid_label_len) == 0)
2670 : ( len == kid_label_len && ((kid_label == label)
2671 || memEQ(kid_label, label, len)))))
2675 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2676 if (kid == PL_lastgotoprobe)
2678 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2681 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2682 ops[-1]->op_type == OP_DBSTATE)
2687 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2696 /* also used for: pp_dump() */
2704 #define GOTO_DEPTH 64
2705 OP *enterops[GOTO_DEPTH];
2706 const char *label = NULL;
2707 STRLEN label_len = 0;
2708 U32 label_flags = 0;
2709 const bool do_dump = (PL_op->op_type == OP_DUMP);
2710 static const char* const must_have_label = "goto must have label";
2712 if (PL_op->op_flags & OPf_STACKED) {
2713 /* goto EXPR or goto &foo */
2715 SV * const sv = POPs;
2718 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2719 /* This egregious kludge implements goto &subroutine */
2722 CV *cv = MUTABLE_CV(SvRV(sv));
2723 AV *arg = GvAV(PL_defgv);
2725 while (!CvROOT(cv) && !CvXSUB(cv)) {
2726 const GV * const gv = CvGV(cv);
2730 /* autoloaded stub? */
2731 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2733 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2735 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2736 if (autogv && (cv = GvCV(autogv)))
2738 tmpstr = sv_newmortal();
2739 gv_efullname3(tmpstr, gv, NULL);
2740 DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
2742 DIE(aTHX_ "Goto undefined subroutine");
2745 cxix = dopoptosub(cxstack_ix);
2747 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2749 cx = &cxstack[cxix];
2750 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2751 if (CxTYPE(cx) == CXt_EVAL) {
2753 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2754 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2756 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2757 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2759 else if (CxMULTICALL(cx))
2760 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2762 /* First do some returnish stuff. */
2764 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2766 if (cxix < cxstack_ix) {
2773 /* protect @_ during save stack unwind. */
2775 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
2777 assert(PL_scopestack_ix == cx->blk_oldscopesp);
2780 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2781 /* this is part of cx_popsub_args() */
2782 AV* av = MUTABLE_AV(PAD_SVl(0));
2783 assert(AvARRAY(MUTABLE_AV(
2784 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2785 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2787 /* we are going to donate the current @_ from the old sub
2788 * to the new sub. This first part of the donation puts a
2789 * new empty AV in the pad[0] slot of the old sub,
2790 * unless pad[0] and @_ differ (e.g. if the old sub did
2791 * local *_ = []); in which case clear the old pad[0]
2792 * array in the usual way */
2793 if (av == arg || AvREAL(av))
2794 clear_defarray(av, av == arg);
2795 else CLEAR_ARGARRAY(av);
2798 /* don't restore PL_comppad here. It won't be needed if the
2799 * sub we're going to is non-XS, but restoring it early then
2800 * croaking (e.g. the "Goto undefined subroutine" below)
2801 * means the CX block gets processed again in dounwind,
2802 * but this time with the wrong PL_comppad */
2804 /* A destructor called during LEAVE_SCOPE could have undefined
2805 * our precious cv. See bug #99850. */
2806 if (!CvROOT(cv) && !CvXSUB(cv)) {
2807 const GV * const gv = CvGV(cv);
2809 SV * const tmpstr = sv_newmortal();
2810 gv_efullname3(tmpstr, gv, NULL);
2811 DIE(aTHX_ "Goto undefined subroutine &%" SVf,
2814 DIE(aTHX_ "Goto undefined subroutine");
2817 if (CxTYPE(cx) == CXt_SUB) {
2818 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2819 SvREFCNT_dec_NN(cx->blk_sub.cv);
2822 /* Now do some callish stuff. */
2824 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2825 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2830 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2832 /* put GvAV(defgv) back onto stack */
2834 EXTEND(SP, items+1); /* @_ could have been extended. */
2839 bool r = cBOOL(AvREAL(arg));
2840 for (index=0; index<items; index++)
2844 SV ** const svp = av_fetch(arg, index, 0);
2845 sv = svp ? *svp : NULL;
2847 else sv = AvARRAY(arg)[index];
2849 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2850 : sv_2mortal(newSVavdefelem(arg, index, 1));
2854 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2855 /* Restore old @_ */
2856 CX_POP_SAVEARRAY(cx);
2859 retop = cx->blk_sub.retop;
2860 PL_comppad = cx->blk_sub.prevcomppad;
2861 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2863 /* XS subs don't have a CXt_SUB, so pop it;
2864 * this is a cx_popblock(), less all the stuff we already did
2865 * for cx_topblock() earlier */
2866 PL_curcop = cx->blk_oldcop;
2869 /* Push a mark for the start of arglist */
2872 (void)(*CvXSUB(cv))(aTHX_ cv);
2877 PADLIST * const padlist = CvPADLIST(cv);
2879 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2881 /* partial unrolled cx_pushsub(): */
2883 cx->blk_sub.cv = cv;
2884 cx->blk_sub.olddepth = CvDEPTH(cv);
2887 SvREFCNT_inc_simple_void_NN(cv);
2888 if (CvDEPTH(cv) > 1) {
2889 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2890 sub_crush_depth(cv);
2891 pad_push(padlist, CvDEPTH(cv));
2893 PL_curcop = cx->blk_oldcop;
2894 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2897 /* second half of donating @_ from the old sub to the
2898 * new sub: abandon the original pad[0] AV in the
2899 * new sub, and replace it with the donated @_.
2900 * pad[0] takes ownership of the extra refcount
2901 * we gave arg earlier */
2903 SvREFCNT_dec(PAD_SVl(0));
2904 PAD_SVl(0) = (SV *)arg;
2905 SvREFCNT_inc_simple_void_NN(arg);
2908 /* GvAV(PL_defgv) might have been modified on scope
2909 exit, so point it at arg again. */
2910 if (arg != GvAV(PL_defgv)) {
2911 AV * const av = GvAV(PL_defgv);
2912 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2917 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2918 Perl_get_db_sub(aTHX_ NULL, cv);
2920 CV * const gotocv = get_cvs("DB::goto", 0);
2922 PUSHMARK( PL_stack_sp );
2923 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2928 retop = CvSTART(cv);
2929 goto putback_return;
2934 label = SvPV_nomg_const(sv, label_len);
2935 label_flags = SvUTF8(sv);
2938 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2939 /* goto LABEL or dump LABEL */
2940 label = cPVOP->op_pv;
2941 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2942 label_len = strlen(label);
2944 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2949 OP *gotoprobe = NULL;
2950 bool leaving_eval = FALSE;
2951 bool in_block = FALSE;
2952 bool pseudo_block = FALSE;
2953 PERL_CONTEXT *last_eval_cx = NULL;
2957 PL_lastgotoprobe = NULL;
2959 for (ix = cxstack_ix; ix >= 0; ix--) {
2961 switch (CxTYPE(cx)) {
2963 leaving_eval = TRUE;
2964 if (!CxTRYBLOCK(cx)) {
2965 gotoprobe = (last_eval_cx ?
2966 last_eval_cx->blk_eval.old_eval_root :
2971 /* else fall through */
2972 case CXt_LOOP_PLAIN:
2973 case CXt_LOOP_LAZYIV:
2974 case CXt_LOOP_LAZYSV:
2979 gotoprobe = OpSIBLING(cx->blk_oldcop);
2985 gotoprobe = OpSIBLING(cx->blk_oldcop);
2988 gotoprobe = PL_main_root;
2991 gotoprobe = CvROOT(cx->blk_sub.cv);
2992 pseudo_block = cBOOL(CxMULTICALL(cx));
2996 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2999 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3000 CxTYPE(cx), (long) ix);
3001 gotoprobe = PL_main_root;
3007 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3008 enterops, enterops + GOTO_DEPTH);
3011 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3012 sibl1->op_type == OP_UNSTACK &&
3013 (sibl2 = OpSIBLING(sibl1)))
3015 retop = dofindlabel(sibl2,
3016 label, label_len, label_flags, enterops,
3017 enterops + GOTO_DEPTH);
3023 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3024 PL_lastgotoprobe = gotoprobe;
3027 DIE(aTHX_ "Can't find label %" UTF8f,
3028 UTF8fARG(label_flags, label_len, label));
3030 /* if we're leaving an eval, check before we pop any frames
3031 that we're not going to punt, otherwise the error
3034 if (leaving_eval && *enterops && enterops[1]) {
3036 for (i = 1; enterops[i]; i++)
3037 if (enterops[i]->op_type == OP_ENTERITER)
3038 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3041 if (*enterops && enterops[1]) {
3042 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3044 deprecate("\"goto\" to jump into a construct");
3047 /* pop unwanted frames */
3049 if (ix < cxstack_ix) {
3051 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3057 /* push wanted frames */
3059 if (*enterops && enterops[1]) {
3060 OP * const oldop = PL_op;
3061 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3062 for (; enterops[ix]; ix++) {
3063 PL_op = enterops[ix];
3064 /* Eventually we may want to stack the needed arguments
3065 * for each op. For now, we punt on the hard ones. */
3066 if (PL_op->op_type == OP_ENTERITER)
3067 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3068 PL_op->op_ppaddr(aTHX);
3076 if (!retop) retop = PL_main_start;
3078 PL_restartop = retop;
3079 PL_do_undump = TRUE;
3083 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3084 PL_do_undump = FALSE;
3102 anum = 0; (void)POPs;
3108 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3111 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3114 PL_exit_flags |= PERL_EXIT_EXPECTED;
3116 PUSHs(&PL_sv_undef);
3123 S_save_lines(pTHX_ AV *array, SV *sv)
3125 const char *s = SvPVX_const(sv);
3126 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3129 PERL_ARGS_ASSERT_SAVE_LINES;
3131 while (s && s < send) {
3133 SV * const tmpstr = newSV_type(SVt_PVMG);
3135 t = (const char *)memchr(s, '\n', send - s);
3141 sv_setpvn(tmpstr, s, t - s);
3142 av_store(array, line++, tmpstr);
3150 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3152 0 is used as continue inside eval,
3154 3 is used for a die caught by an inner eval - continue inner loop
3156 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3157 establish a local jmpenv to handle exception traps.
3162 S_docatch(pTHX_ OP *o)
3165 OP * const oldop = PL_op;
3169 assert(CATCH_GET == TRUE);
3176 assert(cxstack_ix >= 0);
3177 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3178 CX_CUR()->blk_eval.cur_top_env = PL_top_env;
3183 /* die caught by an inner eval - continue inner loop */
3184 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3185 PL_restartjmpenv = NULL;
3186 PL_op = PL_restartop;
3195 NOT_REACHED; /* NOTREACHED */
3204 =for apidoc find_runcv
3206 Locate the CV corresponding to the currently executing sub or eval.
3207 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3208 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3209 entered. (This allows debuggers to eval in the scope of the breakpoint
3210 rather than in the scope of the debugger itself.)
3216 Perl_find_runcv(pTHX_ U32 *db_seqp)
3218 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3221 /* If this becomes part of the API, it might need a better name. */
3223 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3230 PL_curcop == &PL_compiling
3232 : PL_curcop->cop_seq;
3234 for (si = PL_curstackinfo; si; si = si->si_prev) {
3236 for (ix = si->si_cxix; ix >= 0; ix--) {
3237 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3239 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3240 cv = cx->blk_sub.cv;
3241 /* skip DB:: code */
3242 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3243 *db_seqp = cx->blk_oldcop->cop_seq;
3246 if (cx->cx_type & CXp_SUB_RE)
3249 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3250 cv = cx->blk_eval.cv;
3253 case FIND_RUNCV_padid_eq:
3255 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3258 case FIND_RUNCV_level_eq:
3259 if (level++ != arg) continue;
3267 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3271 /* Run yyparse() in a setjmp wrapper. Returns:
3272 * 0: yyparse() successful
3273 * 1: yyparse() failed
3277 S_try_yyparse(pTHX_ int gramtype)
3282 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3286 ret = yyparse(gramtype) ? 1 : 0;
3293 NOT_REACHED; /* NOTREACHED */
3300 /* Compile a require/do or an eval ''.
3302 * outside is the lexically enclosing CV (if any) that invoked us.
3303 * seq is the current COP scope value.
3304 * hh is the saved hints hash, if any.
3306 * Returns a bool indicating whether the compile was successful; if so,
3307 * PL_eval_start contains the first op of the compiled code; otherwise,
3310 * This function is called from two places: pp_require and pp_entereval.
3311 * These can be distinguished by whether PL_op is entereval.
3315 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3318 OP * const saveop = PL_op;
3319 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3320 COP * const oldcurcop = PL_curcop;
3321 bool in_require = (saveop->op_type == OP_REQUIRE);
3325 PL_in_eval = (in_require
3326 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3328 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3329 ? EVAL_RE_REPARSING : 0)));
3333 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3335 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3336 CX_CUR()->blk_eval.cv = evalcv;
3337 CX_CUR()->blk_gimme = gimme;
3339 CvOUTSIDE_SEQ(evalcv) = seq;
3340 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3342 /* set up a scratch pad */
3344 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3345 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3348 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3350 /* make sure we compile in the right package */
3352 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3353 SAVEGENERICSV(PL_curstash);
3354 PL_curstash = (HV *)CopSTASH(PL_curcop);
3355 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3356 else SvREFCNT_inc_simple_void(PL_curstash);
3358 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3359 SAVESPTR(PL_beginav);
3360 PL_beginav = newAV();
3361 SAVEFREESV(PL_beginav);
3362 SAVESPTR(PL_unitcheckav);
3363 PL_unitcheckav = newAV();
3364 SAVEFREESV(PL_unitcheckav);
3367 ENTER_with_name("evalcomp");
3368 SAVESPTR(PL_compcv);
3371 /* try to compile it */
3373 PL_eval_root = NULL;
3374 PL_curcop = &PL_compiling;
3375 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3376 PL_in_eval |= EVAL_KEEPERR;
3383 hv_clear(GvHV(PL_hintgv));
3386 PL_hints = saveop->op_private & OPpEVAL_COPHH
3387 ? oldcurcop->cop_hints : (U32)saveop->op_targ;
3389 /* making 'use re eval' not be in scope when compiling the
3390 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3391 * infinite recursion when S_has_runtime_code() gives a false
3392 * positive: the second time round, HINT_RE_EVAL isn't set so we
3393 * don't bother calling S_has_runtime_code() */
3394 if (PL_in_eval & EVAL_RE_REPARSING)
3395 PL_hints &= ~HINT_RE_EVAL;
3398 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3399 SvREFCNT_dec(GvHV(PL_hintgv));
3400 GvHV(PL_hintgv) = hh;
3403 SAVECOMPILEWARNINGS();
3405 if (PL_dowarn & G_WARN_ALL_ON)
3406 PL_compiling.cop_warnings = pWARN_ALL ;
3407 else if (PL_dowarn & G_WARN_ALL_OFF)
3408 PL_compiling.cop_warnings = pWARN_NONE ;
3410 PL_compiling.cop_warnings = pWARN_STD ;
3413 PL_compiling.cop_warnings =
3414 DUP_WARNINGS(oldcurcop->cop_warnings);
3415 cophh_free(CopHINTHASH_get(&PL_compiling));
3416 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3417 /* The label, if present, is the first entry on the chain. So rather
3418 than writing a blank label in front of it (which involves an
3419 allocation), just use the next entry in the chain. */
3420 PL_compiling.cop_hints_hash
3421 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3422 /* Check the assumption that this removed the label. */
3423 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3426 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3429 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3431 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3432 * so honour CATCH_GET and trap it here if necessary */
3435 /* compile the code */
3436 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3438 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3443 /* note that if yystatus == 3, then the require/eval died during
3444 * compilation, so the EVAL CX block has already been popped, and
3445 * various vars restored */
3446 if (yystatus != 3) {
3448 op_free(PL_eval_root);
3449 PL_eval_root = NULL;
3451 SP = PL_stack_base + POPMARK; /* pop original mark */
3453 assert(CxTYPE(cx) == CXt_EVAL);
3454 /* pop the CXt_EVAL, and if was a require, croak */
3455 S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
3458 /* die_unwind() re-croaks when in require, having popped the
3459 * require EVAL context. So we should never catch a require
3461 assert(!in_require);
3464 if (!*(SvPV_nolen_const(errsv)))
3465 sv_setpvs(errsv, "Compilation error");
3467 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3472 /* Compilation successful. Now clean up */
3474 LEAVE_with_name("evalcomp");
3476 CopLINE_set(&PL_compiling, 0);
3477 SAVEFREEOP(PL_eval_root);
3478 cv_forget_slab(evalcv);
3480 DEBUG_x(dump_eval());
3482 /* Register with debugger: */
3483 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3484 CV * const cv = get_cvs("DB::postponed", 0);
3488 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3490 call_sv(MUTABLE_SV(cv), G_DISCARD);
3494 if (PL_unitcheckav) {
3495 OP *es = PL_eval_start;
3496 call_list(PL_scopestack_ix, PL_unitcheckav);
3500 CvDEPTH(evalcv) = 1;
3501 SP = PL_stack_base + POPMARK; /* pop original mark */
3502 PL_op = saveop; /* The caller may need it. */
3503 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3509 /* Return NULL if the file doesn't exist or isn't a file;
3510 * else return PerlIO_openn().
3514 S_check_type_and_open(pTHX_ SV *name)
3519 const char *p = SvPV_const(name, len);
3522 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3524 /* checking here captures a reasonable error message when
3525 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3526 * user gets a confusing message about looking for the .pmc file
3527 * rather than for the .pm file so do the check in S_doopen_pm when
3528 * PMC is on instead of here. S_doopen_pm calls this func.
3529 * This check prevents a \0 in @INC causing problems.
3531 #ifdef PERL_DISABLE_PMC
3532 if (!IS_SAFE_PATHNAME(p, len, "require"))
3536 /* on Win32 stat is expensive (it does an open() and close() twice and
3537 a couple other IO calls), the open will fail with a dir on its own with
3538 errno EACCES, so only do a stat to separate a dir from a real EACCES
3539 caused by user perms */
3541 /* we use the value of errno later to see how stat() or open() failed.
3542 * We don't want it set if the stat succeeded but we still failed,
3543 * such as if the name exists, but is a directory */
3546 st_rc = PerlLIO_stat(p, &st);
3548 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3553 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3555 /* EACCES stops the INC search early in pp_require to implement
3556 feature RT #113422 */
3557 if(!retio && errno == EACCES) { /* exists but probably a directory */
3559 st_rc = PerlLIO_stat(p, &st);
3561 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3572 /* doopen_pm(): return the equivalent of PerlIO_openn() on the given name,
3573 * but first check for bad names (\0) and non-files.
3574 * Also if the filename ends in .pm and unless PERL_DISABLE_PMC,
3575 * try loading Foo.pmc first.
3577 #ifndef PERL_DISABLE_PMC
3579 S_doopen_pm(pTHX_ SV *name)
3582 const char *p = SvPV_const(name, namelen);
3584 PERL_ARGS_ASSERT_DOOPEN_PM;
3586 /* check the name before trying for the .pmc name to avoid the
3587 * warning referring to the .pmc which the user probably doesn't
3588 * know or care about
3590 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3593 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3594 SV *const pmcsv = sv_newmortal();
3597 SvSetSV_nosteal(pmcsv,name);
3598 sv_catpvs(pmcsv, "c");
3600 pmcio = check_type_and_open(pmcsv);
3604 return check_type_and_open(name);
3607 # define doopen_pm(name) check_type_and_open(name)
3608 #endif /* !PERL_DISABLE_PMC */
3610 /* require doesn't search in @INC for absolute names, or when the name is
3611 explicitly relative the current directory: i.e. ./, ../ */
3612 PERL_STATIC_INLINE bool
3613 S_path_is_searchable(const char *name)
3615 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3617 if (PERL_FILE_IS_ABSOLUTE(name)
3619 || (*name == '.' && ((name[1] == '/' ||
3620 (name[1] == '.' && name[2] == '/'))
3621 || (name[1] == '\\' ||
3622 ( name[1] == '.' && name[2] == '\\')))
3625 || (*name == '.' && (name[1] == '/' ||
3626 (name[1] == '.' && name[2] == '/')))
3637 /* implement 'require 5.010001' */
3640 S_require_version(pTHX_ SV *sv)
3644 sv = sv_2mortal(new_version(sv));
3645 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3646 upg_version(PL_patchlevel, TRUE);
3647 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3648 if ( vcmp(sv,PL_patchlevel) <= 0 )
3649 DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
3650 SVfARG(sv_2mortal(vnormal(sv))),
3651 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3655 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3658 SV * const req = SvRV(sv);
3659 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3661 /* get the left hand term */
3662 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3664 first = SvIV(*av_fetch(lav,0,0));
3665 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3666 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3667 || av_tindex(lav) > 1 /* FP with > 3 digits */
3668 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3670 DIE(aTHX_ "Perl %" SVf " required--this is only "
3671 "%" SVf ", stopped",
3672 SVfARG(sv_2mortal(vnormal(req))),
3673 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3676 else { /* probably 'use 5.10' or 'use 5.8' */
3680 if (av_tindex(lav)>=1)
3681 second = SvIV(*av_fetch(lav,1,0));
3683 second /= second >= 600 ? 100 : 10;
3684 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3685 (int)first, (int)second);
3686 upg_version(hintsv, TRUE);
3688 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)"
3689 "--this is only %" SVf ", stopped",
3690 SVfARG(sv_2mortal(vnormal(req))),
3691 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3692 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3701 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
3702 * The first form will have already been converted at compile time to
3703 * the second form */
3706 S_require_file(pTHX_ SV *sv)
3716 int vms_unixname = 0;
3719 /* tryname is the actual pathname (with @INC prefix) which was loaded.
3720 * It's stored as a value in %INC, and used for error messages */
3721 const char *tryname = NULL;
3722 SV *namesv = NULL; /* SV equivalent of tryname */
3723 const U8 gimme = GIMME_V;
3724 int filter_has_file = 0;
3725 PerlIO *tryrsfp = NULL;
3726 SV *filter_cache = NULL;
3727 SV *filter_state = NULL;
3728 SV *filter_sub = NULL;
3732 bool path_searchable;
3733 I32 old_savestack_ix;
3734 const bool op_is_require = PL_op->op_type == OP_REQUIRE;
3735 const char *const op_name = op_is_require ? "require" : "do";
3737 assert(op_is_require || PL_op->op_type == OP_DOFILE);
3740 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3741 name = SvPV_nomg_const(sv, len);
3742 if (!(name && len > 0 && *name))
3743 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3745 if (!IS_SAFE_PATHNAME(name, len, op_name)) {
3746 if (!op_is_require) {
3750 DIE(aTHX_ "Can't locate %s: %s",
3751 pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
3752 NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3755 TAINT_PROPER(op_name);
3757 path_searchable = path_is_searchable(name);
3760 /* The key in the %ENV hash is in the syntax of file passed as the argument
3761 * usually this is in UNIX format, but sometimes in VMS format, which
3762 * can result in a module being pulled in more than once.
3763 * To prevent this, the key must be stored in UNIX format if the VMS
3764 * name can be translated to UNIX.
3768 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3770 unixlen = strlen(unixname);
3776 /* if not VMS or VMS name can not be translated to UNIX, pass it
3779 unixname = (char *) name;
3782 if (op_is_require) {
3783 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3784 unixname, unixlen, 0);
3786 if (*svp != &PL_sv_undef)
3789 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3790 "Compilation failed in require", unixname);
3793 /*XXX OPf_KIDS should always be true? -dapm 4/2017 */
3794 if (PL_op->op_flags & OPf_KIDS) {
3795 SVOP * const kid = (SVOP*)cUNOP->op_first;
3797 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3798 /* Make sure that a bareword module name (e.g. ::Foo::Bar)
3799 * doesn't map to a naughty pathname like /Foo/Bar.pm.
3800 * Note that the parser will normally detect such errors
3801 * at compile time before we reach here, but
3802 * Perl_load_module() can fake up an identical optree
3803 * without going near the parser, and being able to put
3804 * anything as the bareword. So we include a duplicate set
3805 * of checks here at runtime.
3807 const STRLEN package_len = len - 3;
3808 const char slashdot[2] = {'/', '.'};
3810 const char backslashdot[2] = {'\\', '.'};
3813 /* Disallow *purported* barewords that map to absolute
3814 filenames, filenames relative to the current or parent
3815 directory, or (*nix) hidden filenames. Also sanity check
3816 that the generated filename ends .pm */
3817 if (!path_searchable || len < 3 || name[0] == '.'
3818 || !memEQ(name + package_len, ".pm", 3))
3819 DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv);
3820 if (memchr(name, 0, package_len)) {
3821 /* diag_listed_as: Bareword in require contains "%s" */
3822 DIE(aTHX_ "Bareword in require contains \"\\0\"");
3824 if (ninstr(name, name + package_len, slashdot,
3825 slashdot + sizeof(slashdot))) {
3826 /* diag_listed_as: Bareword in require contains "%s" */
3827 DIE(aTHX_ "Bareword in require contains \"/.\"");
3830 if (ninstr(name, name + package_len, backslashdot,
3831 backslashdot + sizeof(backslashdot))) {
3832 /* diag_listed_as: Bareword in require contains "%s" */
3833 DIE(aTHX_ "Bareword in require contains \"\\.\"");
3840 PERL_DTRACE_PROBE_FILE_LOADING(unixname);
3842 /* Try to locate and open a file, possibly using @INC */
3844 /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load
3845 * the file directly rather than via @INC ... */
3846 if (!path_searchable) {
3847 /* At this point, name is SvPVX(sv) */
3849 tryrsfp = doopen_pm(sv);
3852 /* ... but if we fail, still search @INC for code references;
3853 * these are applied even on on-searchable paths (except
3854 * if we got EACESS).
3856 * For searchable paths, just search @INC normally
3858 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3859 AV * const ar = GvAVn(PL_incgv);
3866 namesv = newSV_type(SVt_PV);
3867 for (i = 0; i <= AvFILL(ar); i++) {
3868 SV * const dirsv = *av_fetch(ar, i, TRUE);
3876 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3877 && !SvOBJECT(SvRV(loader)))
3879 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3883 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
3884 PTR2UV(SvRV(dirsv)), name);
3885 tryname = SvPVX_const(namesv);
3888 if (SvPADTMP(nsv)) {
3889 nsv = sv_newmortal();
3890 SvSetSV_nosteal(nsv,sv);
3893 ENTER_with_name("call_INC");
3901 if (SvGMAGICAL(loader)) {
3902 SV *l = sv_newmortal();
3903 sv_setsv_nomg(l, loader);
3906 if (sv_isobject(loader))
3907 count = call_method("INC", G_ARRAY);
3909 count = call_sv(loader, G_ARRAY);
3919 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3920 && !isGV_with_GP(SvRV(arg))) {
3921 filter_cache = SvRV(arg);
3928 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3932 if (isGV_with_GP(arg)) {
3933 IO * const io = GvIO((const GV *)arg);
3938 tryrsfp = IoIFP(io);
3939 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3940 PerlIO_close(IoOFP(io));
3951 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3953 SvREFCNT_inc_simple_void_NN(filter_sub);
3956 filter_state = SP[i];
3957 SvREFCNT_inc_simple_void(filter_state);
3961 if (!tryrsfp && (filter_cache || filter_sub)) {
3962 tryrsfp = PerlIO_open(BIT_BUCKET,
3968 /* FREETMPS may free our filter_cache */
3969 SvREFCNT_inc_simple_void(filter_cache);
3973 LEAVE_with_name("call_INC");
3975 /* Now re-mortalize it. */
3976 sv_2mortal(filter_cache);
3978 /* Adjust file name if the hook has set an %INC entry.
3979 This needs to happen after the FREETMPS above. */
3980 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3982 tryname = SvPV_nolen_const(*svp);
3989 filter_has_file = 0;
3990 filter_cache = NULL;
3992 SvREFCNT_dec_NN(filter_state);
3993 filter_state = NULL;
3996 SvREFCNT_dec_NN(filter_sub);
4000 else if (path_searchable) {
4001 /* match against a plain @INC element (non-searchable
4002 * paths are only matched against refs in @INC) */
4007 dir = SvPV_nomg_const(dirsv, dirlen);
4013 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
4017 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4020 sv_setpv(namesv, unixdir);
4021 sv_catpv(namesv, unixname);
4023 # ifdef __SYMBIAN32__
4024 if (PL_origfilename[0] &&
4025 PL_origfilename[1] == ':' &&
4026 !(dir[0] && dir[1] == ':'))
4027 Perl_sv_setpvf(aTHX_ namesv,
4032 Perl_sv_setpvf(aTHX_ namesv,
4036 /* The equivalent of
4037 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4038 but without the need to parse the format string, or
4039 call strlen on either pointer, and with the correct
4040 allocation up front. */
4042 char *tmp = SvGROW(namesv, dirlen + len + 2);
4044 memcpy(tmp, dir, dirlen);
4047 /* Avoid '<dir>//<file>' */
4048 if (!dirlen || *(tmp-1) != '/') {
4051 /* So SvCUR_set reports the correct length below */
4055 /* name came from an SV, so it will have a '\0' at the
4056 end that we can copy as part of this memcpy(). */
4057 memcpy(tmp, name, len + 1);
4059 SvCUR_set(namesv, dirlen + len + 1);
4064 TAINT_PROPER(op_name);
4065 tryname = SvPVX_const(namesv);
4066 tryrsfp = doopen_pm(namesv);
4068 if (tryname[0] == '.' && tryname[1] == '/') {
4070 while (*++tryname == '/') {}
4074 else if (errno == EMFILE || errno == EACCES) {
4075 /* no point in trying other paths if out of handles;
4076 * on the other hand, if we couldn't open one of the
4077 * files, then going on with the search could lead to
4078 * unexpected results; see perl #113422
4087 /* at this point we've ether opened a file (tryrsfp) or set errno */
4089 saved_errno = errno; /* sv_2mortal can realloc things */
4092 /* we failed; croak if require() or return undef if do() */
4093 if (op_is_require) {
4094 if(saved_errno == EMFILE || saved_errno == EACCES) {
4095 /* diag_listed_as: Can't locate %s */
4096 DIE(aTHX_ "Can't locate %s: %s: %s",
4097 name, tryname, Strerror(saved_errno));
4099 if (path_searchable) { /* did we lookup @INC? */
4100 AV * const ar = GvAVn(PL_incgv);
4102 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4103 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4104 const char *e = name + len - 3; /* possible .pm */
4105 for (i = 0; i <= AvFILL(ar); i++) {
4106 sv_catpvs(inc, " ");
4107 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4109 if (e > name && _memEQs(e, ".pm")) {
4111 bool utf8 = cBOOL(SvUTF8(sv));
4113 /* if the filename, when converted from "Foo/Bar.pm"
4114 * form back to Foo::Bar form, makes a valid
4115 * package name (i.e. parseable by C<require
4116 * Foo::Bar>), then emit a hint.
4118 * this loop is modelled after the one in
4122 if (utf8 && isIDFIRST_utf8_safe(c, e)) {
4124 while (c < e && isIDCONT_utf8_safe(
4125 (const U8*) c, (const U8*) e))
4128 else if (isWORDCHAR_A(*c)) {
4129 while (c < e && isWORDCHAR_A(*c))
4138 if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
4139 sv_catpv(msg, " (you may need to install the ");
4140 for (c = name; c < e; c++) {
4142 sv_catpvs(msg, "::");
4145 sv_catpvn(msg, c, 1);
4148 sv_catpv(msg, " module)");
4151 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4152 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4154 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4155 sv_catpv(msg, " (did you run h2ph?)");
4158 /* diag_listed_as: Can't locate %s */
4160 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4164 DIE(aTHX_ "Can't locate %s", name);
4167 #ifdef DEFAULT_INC_EXCLUDES_DOT
4171 /* the complication is to match the logic from doopen_pm() so
4172 * we don't treat do "sda1" as a previously successful "do".
4174 bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED)
4175 && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode)
4176 && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL;
4182 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4183 "do \"%s\" failed, '.' is no longer in @INC; "
4184 "did you mean do \"./%s\"?",
4193 SETERRNO(0, SS_NORMAL);
4195 /* Update %INC. Assume success here to prevent recursive requirement. */
4196 /* name is never assigned to again, so len is still strlen(name) */
4197 /* Check whether a hook in @INC has already filled %INC */
4199 (void)hv_store(GvHVn(PL_incgv),
4200 unixname, unixlen, newSVpv(tryname,0),0);
4202 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4204 (void)hv_store(GvHVn(PL_incgv),
4205 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4208 /* Now parse the file */
4210 old_savestack_ix = PL_savestack_ix;
4211 SAVECOPFILE_FREE(&PL_compiling);
4212 CopFILE_set(&PL_compiling, tryname);
4213 lex_start(NULL, tryrsfp, 0);
4215 if (filter_sub || filter_cache) {
4216 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4217 than hanging another SV from it. In turn, filter_add() optionally
4218 takes the SV to use as the filter (or creates a new SV if passed
4219 NULL), so simply pass in whatever value filter_cache has. */
4220 SV * const fc = filter_cache ? newSV(0) : NULL;
4222 if (fc) sv_copypv(fc, filter_cache);
4223 datasv = filter_add(S_run_user_filter, fc);
4224 IoLINES(datasv) = filter_has_file;
4225 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4226 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4229 /* switch to eval mode */
4230 cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4231 cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4233 SAVECOPLINE(&PL_compiling);
4234 CopLINE_set(&PL_compiling, 0);
4238 if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4239 op = DOCATCH(PL_eval_start);
4241 op = PL_op->op_next;
4243 PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4249 /* also used for: pp_dofile() */
4257 return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4258 ? S_require_version(aTHX_ sv)
4259 : S_require_file(aTHX_ sv);
4263 /* This is a op added to hold the hints hash for
4264 pp_entereval. The hash can be modified by the code
4265 being eval'ed, so we return a copy instead. */
4270 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4280 const U8 gimme = GIMME_V;
4281 const U32 was = PL_breakable_sub_gen;
4282 char tbuf[TYPE_DIGITS(long) + 12];
4283 bool saved_delete = FALSE;
4284 char *tmpbuf = tbuf;
4287 U32 seq, lex_flags = 0;
4288 HV *saved_hh = NULL;
4289 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4290 I32 old_savestack_ix;
4292 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4293 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4295 else if (PL_hints & HINT_LOCALIZE_HH || (
4296 PL_op->op_private & OPpEVAL_COPHH
4297 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4299 saved_hh = cop_hints_2hv(PL_curcop, 0);
4300 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4304 /* make sure we've got a plain PV (no overload etc) before testing
4305 * for taint. Making a copy here is probably overkill, but better
4306 * safe than sorry */
4308 const char * const p = SvPV_const(sv, len);
4310 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4311 lex_flags |= LEX_START_COPIED;
4313 if (bytes && SvUTF8(sv))
4314 SvPVbyte_force(sv, len);
4316 else if (bytes && SvUTF8(sv)) {
4317 /* Don't modify someone else's scalar */
4320 (void)sv_2mortal(sv);
4321 SvPVbyte_force(sv,len);
4322 lex_flags |= LEX_START_COPIED;
4325 TAINT_IF(SvTAINTED(sv));
4326 TAINT_PROPER("eval");
4328 old_savestack_ix = PL_savestack_ix;
4330 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4331 ? LEX_IGNORE_UTF8_HINTS
4332 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4336 /* switch to eval mode */
4338 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4339 SV * const temp_sv = sv_newmortal();
4340 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]",
4341 (unsigned long)++PL_evalseq,
4342 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4343 tmpbuf = SvPVX(temp_sv);
4344 len = SvCUR(temp_sv);
4347 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4348 SAVECOPFILE_FREE(&PL_compiling);
4349 CopFILE_set(&PL_compiling, tmpbuf+2);
4350 SAVECOPLINE(&PL_compiling);
4351 CopLINE_set(&PL_compiling, 1);
4352 /* special case: an eval '' executed within the DB package gets lexically
4353 * placed in the first non-DB CV rather than the current CV - this
4354 * allows the debugger to execute code, find lexicals etc, in the
4355 * scope of the code being debugged. Passing &seq gets find_runcv
4356 * to do the dirty work for us */
4357 runcv = find_runcv(&seq);
4359 cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
4360 cx_pusheval(cx, PL_op->op_next, NULL);
4362 /* prepare to compile string */
4364 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4365 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4367 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4368 deleting the eval's FILEGV from the stash before gv_check() runs
4369 (i.e. before run-time proper). To work around the coredump that
4370 ensues, we always turn GvMULTI_on for any globals that were
4371 introduced within evals. See force_ident(). GSAR 96-10-12 */
4372 char *const safestr = savepvn(tmpbuf, len);
4373 SAVEDELETE(PL_defstash, safestr, len);
4374 saved_delete = TRUE;
4379 if (doeval_compile(gimme, runcv, seq, saved_hh)) {
4380 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4381 ? PERLDB_LINE_OR_SAVESRC
4382 : PERLDB_SAVESRC_NOSUBS) {
4383 /* Retain the filegv we created. */
4384 } else if (!saved_delete) {
4385 char *const safestr = savepvn(tmpbuf, len);
4386 SAVEDELETE(PL_defstash, safestr, len);
4388 return DOCATCH(PL_eval_start);
4390 /* We have already left the scope set up earlier thanks to the LEAVE
4391 in doeval_compile(). */
4392 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4393 ? PERLDB_LINE_OR_SAVESRC
4394 : PERLDB_SAVESRC_INVALID) {
4395 /* Retain the filegv we created. */
4396 } else if (!saved_delete) {
4397 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4399 return PL_op->op_next;
4404 /* also tail-called by pp_return */
4419 assert(CxTYPE(cx) == CXt_EVAL);
4421 oldsp = PL_stack_base + cx->blk_oldsp;
4422 gimme = cx->blk_gimme;
4424 /* did require return a false value? */
4425 failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE
4426 && !(gimme == G_SCALAR
4427 ? SvTRUE(*PL_stack_sp)
4428 : PL_stack_sp > oldsp);
4430 if (gimme == G_VOID)
4431 PL_stack_sp = oldsp;
4433 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4435 /* the cx_popeval does a leavescope, which frees the optree associated
4436 * with eval, which if it frees the nextstate associated with
4437 * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
4438 * regex when running under 'use re Debug' because it needs PL_curcop
4439 * to get the current hints. So restore it early.
4441 PL_curcop = cx->blk_oldcop;
4443 /* grab this value before cx_popeval restores the old PL_in_eval */
4444 keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4445 retop = cx->blk_eval.retop;
4446 evalcv = cx->blk_eval.cv;
4448 assert(CvDEPTH(evalcv) == 1);
4450 CvDEPTH(evalcv) = 0;
4452 /* pop the CXt_EVAL, and if a require failed, croak */
4453 S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
4461 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4462 close to the related Perl_create_eval_scope. */
4464 Perl_delete_eval_scope(pTHX)
4475 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4476 also needed by Perl_fold_constants. */
4478 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
4481 const U8 gimme = GIMME_V;
4483 cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
4484 PL_stack_sp, PL_savestack_ix);
4485 cx_pusheval(cx, retop, NULL);
4487 PL_in_eval = EVAL_INEVAL;
4488 if (flags & G_KEEPERR)
4489 PL_in_eval |= EVAL_KEEPERR;
4492 if (flags & G_FAKINGEVAL) {
4493 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4499 create_eval_scope(cLOGOP->op_other->op_next, 0);
4500 return DOCATCH(PL_op->op_next);
4504 /* also tail-called by pp_return */
4516 assert(CxTYPE(cx) == CXt_EVAL);
4517 oldsp = PL_stack_base + cx->blk_oldsp;
4518 gimme = cx->blk_gimme;
4520 if (gimme == G_VOID)
4521 PL_stack_sp = oldsp;
4523 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4527 retop = cx->blk_eval.retop;
4538 const U8 gimme = GIMME_V;
4542 assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4543 GvSV(PL_defgv) = SvREFCNT_inc(newsv);
4545 cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
4546 cx_pushgiven(cx, origsv);
4556 PERL_UNUSED_CONTEXT;
4559 assert(CxTYPE(cx) == CXt_GIVEN);
4560 oldsp = PL_stack_base + cx->blk_oldsp;
4561 gimme = cx->blk_gimme;
4563 if (gimme == G_VOID)
4564 PL_stack_sp = oldsp;
4566 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4576 /* Helper routines used by pp_smartmatch */
4578 S_make_matcher(pTHX_ REGEXP *re)
4580 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4582 PERL_ARGS_ASSERT_MAKE_MATCHER;
4584 PM_SETRE(matcher, ReREFCNT_inc(re));
4586 SAVEFREEOP((OP *) matcher);
4587 ENTER_with_name("matcher"); SAVETMPS;
4593 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4598 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4600 PL_op = (OP *) matcher;
4603 (void) Perl_pp_match(aTHX);
4605 result = SvTRUEx(POPs);
4612 S_destroy_matcher(pTHX_ PMOP *matcher)
4614 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4615 PERL_UNUSED_ARG(matcher);
4618 LEAVE_with_name("matcher");
4621 /* Do a smart match */
4624 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4625 return do_smartmatch(NULL, NULL, 0);
4628 /* This version of do_smartmatch() implements the
4629 * table of smart matches that is found in perlsyn.
4632 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4636 bool object_on_left = FALSE;
4637 SV *e = TOPs; /* e is for 'expression' */
4638 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4640 /* Take care only to invoke mg_get() once for each argument.
4641 * Currently we do this by copying the SV if it's magical. */
4643 if (!copied && SvGMAGICAL(d))
4644 d = sv_mortalcopy(d);
4651 e = sv_mortalcopy(e);
4653 /* First of all, handle overload magic of the rightmost argument */
4656 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4657 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4659 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4666 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4669 SP -= 2; /* Pop the values */
4674 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4681 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4682 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4683 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4685 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4686 object_on_left = TRUE;
4689 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4691 if (object_on_left) {
4692 goto sm_any_sub; /* Treat objects like scalars */
4694 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4695 /* Test sub truth for each key */
4697 bool andedresults = TRUE;
4698 HV *hv = (HV*) SvRV(d);
4699 I32 numkeys = hv_iterinit(hv);
4700 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4703 while ( (he = hv_iternext(hv)) ) {
4704 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4705 ENTER_with_name("smartmatch_hash_key_test");
4708 PUSHs(hv_iterkeysv(he));
4710 c = call_sv(e, G_SCALAR);
4713 andedresults = FALSE;
4715 andedresults = SvTRUEx(POPs) && andedresults;
4717 LEAVE_with_name("smartmatch_hash_key_test");
4724 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4725 /* Test sub truth for each element */
4727 bool andedresults = TRUE;
4728 AV *av = (AV*) SvRV(d);
4729 const I32 len = av_tindex(av);
4730 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4733 for (i = 0; i <= len; ++i) {
4734 SV * const * const svp = av_fetch(av, i, FALSE);
4735 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4736 ENTER_with_name("smartmatch_array_elem_test");
4742 c = call_sv(e, G_SCALAR);
4745 andedresults = FALSE;
4747 andedresults = SvTRUEx(POPs) && andedresults;
4749 LEAVE_with_name("smartmatch_array_elem_test");
4758 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4759 ENTER_with_name("smartmatch_coderef");
4764 c = call_sv(e, G_SCALAR);
4768 else if (SvTEMP(TOPs))
4769 SvREFCNT_inc_void(TOPs);
4771 LEAVE_with_name("smartmatch_coderef");
4776 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4777 if (object_on_left) {
4778 goto sm_any_hash; /* Treat objects like scalars */
4780 else if (!SvOK(d)) {
4781 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4784 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4785 /* Check that the key-sets are identical */
4787 HV *other_hv = MUTABLE_HV(SvRV(d));
4790 U32 this_key_count = 0,
4791 other_key_count = 0;
4792 HV *hv = MUTABLE_HV(SvRV(e));
4794 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4795 /* Tied hashes don't know how many keys they have. */
4796 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4797 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4801 HV * const temp = other_hv;
4807 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4811 /* The hashes have the same number of keys, so it suffices
4812 to check that one is a subset of the other. */
4813 (void) hv_iterinit(hv);
4814 while ( (he = hv_iternext(hv)) ) {
4815 SV *key = hv_iterkeysv(he);
4817 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4820 if(!hv_exists_ent(other_hv, key, 0)) {
4821 (void) hv_iterinit(hv); /* reset iterator */
4827 (void) hv_iterinit(other_hv);
4828 while ( hv_iternext(other_hv) )
4832 other_key_count = HvUSEDKEYS(other_hv);
4834 if (this_key_count != other_key_count)
4839 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4840 AV * const other_av = MUTABLE_AV(SvRV(d));
4841 const SSize_t other_len = av_tindex(other_av) + 1;
4843 HV *hv = MUTABLE_HV(SvRV(e));
4845 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4846 for (i = 0; i < other_len; ++i) {
4847 SV ** const svp = av_fetch(other_av, i, FALSE);
4848 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4849 if (svp) { /* ??? When can this not happen? */
4850 if (hv_exists_ent(hv, *svp, 0))
4856 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4857 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4860 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4862 HV *hv = MUTABLE_HV(SvRV(e));
4864 (void) hv_iterinit(hv);
4865 while ( (he = hv_iternext(hv)) ) {
4866 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4868 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4870 (void) hv_iterinit(hv);
4871 destroy_matcher(matcher);
4876 destroy_matcher(matcher);
4882 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4883 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4890 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4891 if (object_on_left) {
4892 goto sm_any_array; /* Treat objects like scalars */
4894 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4895 AV * const other_av = MUTABLE_AV(SvRV(e));
4896 const SSize_t other_len = av_tindex(other_av) + 1;
4899 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4900 for (i = 0; i < other_len; ++i) {
4901 SV ** const svp = av_fetch(other_av, i, FALSE);
4903 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4904 if (svp) { /* ??? When can this not happen? */
4905 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4911 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4912 AV *other_av = MUTABLE_AV(SvRV(d));
4913 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4914 if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4918 const SSize_t other_len = av_tindex(other_av);
4920 if (NULL == seen_this) {
4921 seen_this = newHV();
4922 (void) sv_2mortal(MUTABLE_SV(seen_this));
4924 if (NULL == seen_other) {
4925 seen_other = newHV();
4926 (void) sv_2mortal(MUTABLE_SV(seen_other));
4928 for(i = 0; i <= other_len; ++i) {
4929 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4930 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4932 if (!this_elem || !other_elem) {
4933 if ((this_elem && SvOK(*this_elem))
4934 || (other_elem && SvOK(*other_elem)))
4937 else if (hv_exists_ent(seen_this,
4938 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4939 hv_exists_ent(seen_other,
4940 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4942 if (*this_elem != *other_elem)
4946 (void)hv_store_ent(seen_this,
4947 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4949 (void)hv_store_ent(seen_other,
4950 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4956 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4957 (void) do_smartmatch(seen_this, seen_other, 0);
4959 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4968 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4969 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4972 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4973 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4976 for(i = 0; i <= this_len; ++i) {
4977 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4978 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4980 if (svp && matcher_matches_sv(matcher, *svp)) {
4982 destroy_matcher(matcher);
4987 destroy_matcher(matcher);
4991 else if (!SvOK(d)) {
4992 /* undef ~~ array */
4993 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4996 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4997 for (i = 0; i <= this_len; ++i) {
4998 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4999 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
5000 if (!svp || !SvOK(*svp))
5009 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5011 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
5012 for (i = 0; i <= this_len; ++i) {
5013 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5020 /* infinite recursion isn't supposed to happen here */
5021 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
5022 (void) do_smartmatch(NULL, NULL, 1);
5024 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
5033 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
5034 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5035 SV *t = d; d = e; e = t;
5036 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
5039 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5040 SV *t = d; d = e; e = t;
5041 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
5042 goto sm_regex_array;
5045 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
5048 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
5050 result = matcher_matches_sv(matcher, d);
5052 PUSHs(result ? &PL_sv_yes : &PL_sv_no);
5053 destroy_matcher(matcher);
5058 /* See if there is overload magic on left */
5059 else if (object_on_left && SvAMAGIC(d)) {
5061 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
5062 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
5065 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
5073 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
5076 else if (!SvOK(d)) {
5077 /* undef ~~ scalar ; we already know that the scalar is SvOK */
5078 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
5083 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
5084 DEBUG_M(if (SvNIOK(e))
5085 Perl_deb(aTHX_ " applying rule Any-Num\n");
5087 Perl_deb(aTHX_ " applying rule Num-numish\n");
5089 /* numeric comparison */
5092 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
5093 (void) Perl_pp_i_eq(aTHX);
5095 (void) Perl_pp_eq(aTHX);
5103 /* As a last resort, use string comparison */
5104 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
5107 return Perl_pp_seq(aTHX);
5114 const U8 gimme = GIMME_V;
5116 /* This is essentially an optimization: if the match
5117 fails, we don't want to push a context and then
5118 pop it again right away, so we skip straight
5119 to the op that follows the leavewhen.
5120 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5122 if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs))
5123 RETURNOP(cLOGOP->op_other->op_next);
5125 cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
5139 assert(CxTYPE(cx) == CXt_WHEN);
5140 gimme = cx->blk_gimme;
5142 cxix = dopoptogivenfor(cxstack_ix);
5144 /* diag_listed_as: Can't "when" outside a topicalizer */
5145 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5146 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5148 oldsp = PL_stack_base + cx->blk_oldsp;
5149 if (gimme == G_VOID)
5150 PL_stack_sp = oldsp;
5152 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5154 /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
5155 assert(cxix < cxstack_ix);
5158 cx = &cxstack[cxix];
5160 if (CxFOREACH(cx)) {
5161 /* emulate pp_next. Note that any stack(s) cleanup will be
5162 * done by the pp_unstack which op_nextop should point to */
5165 PL_curcop = cx->blk_oldcop;
5166 return cx->blk_loop.my_op->op_nextop;
5170 assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
5171 return cx->blk_givwhen.leave_op;
5181 cxix = dopoptowhen(cxstack_ix);
5183 DIE(aTHX_ "Can't \"continue\" outside a when block");
5185 if (cxix < cxstack_ix)
5189 assert(CxTYPE(cx) == CXt_WHEN);
5190 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5194 nextop = cx->blk_givwhen.leave_op->op_next;
5205 cxix = dopoptogivenfor(cxstack_ix);
5207 DIE(aTHX_ "Can't \"break\" outside a given block");
5209 cx = &cxstack[cxix];
5211 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5213 if (cxix < cxstack_ix)
5216 /* Restore the sp at the time we entered the given block */
5218 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5220 return cx->blk_givwhen.leave_op;
5224 S_doparseform(pTHX_ SV *sv)
5227 char *s = SvPV(sv, len);
5229 char *base = NULL; /* start of current field */
5230 I32 skipspaces = 0; /* number of contiguous spaces seen */
5231 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5232 bool repeat = FALSE; /* ~~ seen on this line */
5233 bool postspace = FALSE; /* a text field may need right padding */
5236 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5238 bool ischop; /* it's a ^ rather than a @ */
5239 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5240 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5244 PERL_ARGS_ASSERT_DOPARSEFORM;
5247 Perl_croak(aTHX_ "Null picture in formline");
5249 if (SvTYPE(sv) >= SVt_PVMG) {
5250 /* This might, of course, still return NULL. */
5251 mg = mg_find(sv, PERL_MAGIC_fm);
5253 sv_upgrade(sv, SVt_PVMG);
5257 /* still the same as previously-compiled string? */
5258 SV *old = mg->mg_obj;
5259 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5260 && len == SvCUR(old)
5261 && strnEQ(SvPVX(old), s, len)
5263 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5267 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5268 Safefree(mg->mg_ptr);
5274 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5275 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5278 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5279 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5283 /* estimate the buffer size needed */
5284 for (base = s; s <= send; s++) {
5285 if (*s == '\n' || *s == '@' || *s == '^')
5291 Newx(fops, maxops, U32);
5296 *fpc++ = FF_LINEMARK;
5297 noblank = repeat = FALSE;
5315 case ' ': case '\t':
5322 } /* else FALL THROUGH */
5330 *fpc++ = FF_LITERAL;
5338 *fpc++ = (U32)skipspaces;
5342 *fpc++ = FF_NEWLINE;
5346 arg = fpc - linepc + 1;
5353 *fpc++ = FF_LINEMARK;
5354 noblank = repeat = FALSE;
5363 ischop = s[-1] == '^';
5369 arg = (s - base) - 1;
5371 *fpc++ = FF_LITERAL;
5377 if (*s == '*') { /* @* or ^* */
5379 *fpc++ = 2; /* skip the @* or ^* */
5381 *fpc++ = FF_LINESNGL;
5384 *fpc++ = FF_LINEGLOB;
5386 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5387 arg = ischop ? FORM_NUM_BLANK : 0;
5392 const char * const f = ++s;
5395 arg |= FORM_NUM_POINT + (s - f);
5397 *fpc++ = s - base; /* fieldsize for FETCH */
5398 *fpc++ = FF_DECIMAL;
5400 unchopnum |= ! ischop;
5402 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5403 arg = ischop ? FORM_NUM_BLANK : 0;
5405 s++; /* skip the '0' first */
5409 const char * const f = ++s;
5412 arg |= FORM_NUM_POINT + (s - f);
5414 *fpc++ = s - base; /* fieldsize for FETCH */
5415 *fpc++ = FF_0DECIMAL;
5417 unchopnum |= ! ischop;
5419 else { /* text field */
5421 bool ismore = FALSE;
5424 while (*++s == '>') ;
5425 prespace = FF_SPACE;
5427 else if (*s == '|') {
5428 while (*++s == '|') ;
5429 prespace = FF_HALFSPACE;
5434 while (*++s == '<') ;
5437 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5441 *fpc++ = s - base; /* fieldsize for FETCH */
5443 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5446 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5460 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5463 mg->mg_ptr = (char *) fops;
5464 mg->mg_len = arg * sizeof(U32);
5465 mg->mg_obj = sv_copy;
5466 mg->mg_flags |= MGf_REFCOUNTED;
5468 if (unchopnum && repeat)
5469 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5476 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5478 /* Can value be printed in fldsize chars, using %*.*f ? */
5482 int intsize = fldsize - (value < 0 ? 1 : 0);
5484 if (frcsize & FORM_NUM_POINT)
5486 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5489 while (intsize--) pwr *= 10.0;
5490 while (frcsize--) eps /= 10.0;
5493 if (value + eps >= pwr)
5496 if (value - eps <= -pwr)
5503 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5505 SV * const datasv = FILTER_DATA(idx);
5506 const int filter_has_file = IoLINES(datasv);
5507 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5508 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5513 char *prune_from = NULL;
5514 bool read_from_cache = FALSE;
5518 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5520 assert(maxlen >= 0);
5523 /* I was having segfault trouble under Linux 2.2.5 after a
5524 parse error occurred. (Had to hack around it with a test
5525 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5526 not sure where the trouble is yet. XXX */
5529 SV *const cache = datasv;
5532 const char *cache_p = SvPV(cache, cache_len);
5536 /* Running in block mode and we have some cached data already.
5538 if (cache_len >= umaxlen) {
5539 /* In fact, so much data we don't even need to call
5544 const char *const first_nl =
5545 (const char *)memchr(cache_p, '\n', cache_len);
5547 take = first_nl + 1 - cache_p;
5551 sv_catpvn(buf_sv, cache_p, take);
5552 sv_chop(cache, cache_p + take);
5553 /* Definitely not EOF */
5557 sv_catsv(buf_sv, cache);
5559 umaxlen -= cache_len;
5562 read_from_cache = TRUE;
5566 /* Filter API says that the filter appends to the contents of the buffer.
5567 Usually the buffer is "", so the details don't matter. But if it's not,
5568 then clearly what it contains is already filtered by this filter, so we
5569 don't want to pass it in a second time.
5570 I'm going to use a mortal in case the upstream filter croaks. */
5571 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5572 ? sv_newmortal() : buf_sv;
5573 SvUPGRADE(upstream, SVt_PV);
5575 if (filter_has_file) {
5576 status = FILTER_READ(idx+1, upstream, 0);
5579 if (filter_sub && status >= 0) {
5583 ENTER_with_name("call_filter_sub");
5588 DEFSV_set(upstream);
5592 PUSHs(filter_state);
5595 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5605 SV * const errsv = ERRSV;
5606 if (SvTRUE_NN(errsv))
5607 err = newSVsv(errsv);
5613 LEAVE_with_name("call_filter_sub");
5616 if (SvGMAGICAL(upstream)) {
5618 if (upstream == buf_sv) mg_free(buf_sv);
5620 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5621 if(!err && SvOK(upstream)) {
5622 got_p = SvPV_nomg(upstream, got_len);
5624 if (got_len > umaxlen) {
5625 prune_from = got_p + umaxlen;
5628 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5629 if (first_nl && first_nl + 1 < got_p + got_len) {
5630 /* There's a second line here... */
5631 prune_from = first_nl + 1;
5635 if (!err && prune_from) {
5636 /* Oh. Too long. Stuff some in our cache. */
5637 STRLEN cached_len = got_p + got_len - prune_from;
5638 SV *const cache = datasv;
5641 /* Cache should be empty. */
5642 assert(!SvCUR(cache));
5645 sv_setpvn(cache, prune_from, cached_len);
5646 /* If you ask for block mode, you may well split UTF-8 characters.
5647 "If it breaks, you get to keep both parts"
5648 (Your code is broken if you don't put them back together again
5649 before something notices.) */
5650 if (SvUTF8(upstream)) {
5653 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5655 /* Cannot just use sv_setpvn, as that could free the buffer
5656 before we have a chance to assign it. */
5657 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5658 got_len - cached_len);
5660 /* Can't yet be EOF */
5665 /* If they are at EOF but buf_sv has something in it, then they may never
5666 have touched the SV upstream, so it may be undefined. If we naively
5667 concatenate it then we get a warning about use of uninitialised value.
5669 if (!err && upstream != buf_sv &&
5671 sv_catsv_nomg(buf_sv, upstream);
5673 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5676 IoLINES(datasv) = 0;
5678 SvREFCNT_dec(filter_state);
5679 IoTOP_GV(datasv) = NULL;
5682 SvREFCNT_dec(filter_sub);
5683 IoBOTTOM_GV(datasv) = NULL;
5685 filter_del(S_run_user_filter);
5691 if (status == 0 && read_from_cache) {
5692 /* If we read some data from the cache (and by getting here it implies
5693 that we emptied the cache) then we aren't yet at EOF, and mustn't
5694 report that to our caller. */
5701 * ex: set ts=8 sts=4 sw=4 et: