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();
108 In the below logic: these are basically the same - check if this regcomp is part of a split.
110 (PL_op->op_pmflags & PMf_split )
111 (PL_op->op_next->op_type == OP_PUSHRE)
113 We could add a new mask for this and copy the PMf_split, if we did
114 some bit definition fiddling first.
116 For now we leave this
119 new_re = (eng->op_comp
121 : &Perl_re_op_compile
122 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
124 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
126 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
128 if (pm->op_pmflags & PMf_HAS_CV)
129 ReANY(new_re)->qr_anoncv
130 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
134 /* The match's LHS's get-magic might need to access this op's regexp
135 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
136 get-magic now before we replace the regexp. Hopefully this hack can
137 be replaced with the approach described at
138 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
140 if (pm->op_type == OP_MATCH) {
142 const bool was_tainted = TAINT_get;
143 if (pm->op_flags & OPf_STACKED)
145 else if (pm->op_targ)
146 lhs = PAD_SV(pm->op_targ);
149 /* Restore the previous value of PL_tainted (which may have been
150 modified by get-magic), to avoid incorrectly setting the
151 RXf_TAINTED flag with RX_TAINT_on further down. */
152 TAINT_set(was_tainted);
153 #ifdef NO_TAINT_SUPPORT
154 PERL_UNUSED_VAR(was_tainted);
157 tmp = reg_temp_copy(NULL, new_re);
158 ReREFCNT_dec(new_re);
164 PM_SETRE(pm, new_re);
168 assert(TAINTING_get || !TAINT_get);
170 SvTAINTED_on((SV*)new_re);
174 #if !defined(USE_ITHREADS)
175 /* can't change the optree at runtime either */
176 /* PMf_KEEP is handled differently under threads to avoid these problems */
177 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
179 if (pm->op_pmflags & PMf_KEEP) {
180 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
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 */
494 mg = doparseform(tmpForm);
496 fpc = (U32*)mg->mg_ptr;
497 /* the actual string the format was compiled from.
498 * with overload etc, this may not match tmpForm */
502 SvPV_force(PL_formtarget, len);
503 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
504 SvTAINTED_on(PL_formtarget);
505 if (DO_UTF8(PL_formtarget))
507 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
508 t = SvGROW(PL_formtarget, len + linemax + 1);
509 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
511 f = SvPV_const(formsv, len);
515 const char *name = "???";
518 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
519 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
520 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
521 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
522 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
524 case FF_CHECKNL: name = "CHECKNL"; break;
525 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
526 case FF_SPACE: name = "SPACE"; break;
527 case FF_HALFSPACE: name = "HALFSPACE"; break;
528 case FF_ITEM: name = "ITEM"; break;
529 case FF_CHOP: name = "CHOP"; break;
530 case FF_LINEGLOB: name = "LINEGLOB"; break;
531 case FF_NEWLINE: name = "NEWLINE"; break;
532 case FF_MORE: name = "MORE"; break;
533 case FF_LINEMARK: name = "LINEMARK"; break;
534 case FF_END: name = "END"; break;
535 case FF_0DECIMAL: name = "0DECIMAL"; break;
536 case FF_LINESNGL: name = "LINESNGL"; break;
539 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
541 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
544 case FF_LINEMARK: /* start (or end) of a line */
545 linemark = t - SvPVX(PL_formtarget);
550 case FF_LITERAL: /* append <arg> literal chars */
555 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
558 case FF_SKIP: /* skip <arg> chars in format */
562 case FF_FETCH: /* get next item and set field size to <arg> */
571 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
574 SvTAINTED_on(PL_formtarget);
577 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
579 const char *s = item = SvPV_const(sv, len);
580 const char *send = s + len;
583 item_is_utf8 = DO_UTF8(sv);
595 if (itemsize == fieldsize)
598 itembytes = s - item;
603 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
605 const char *s = item = SvPV_const(sv, len);
606 const char *send = s + len;
610 item_is_utf8 = DO_UTF8(sv);
612 /* look for a legal split position */
620 /* provisional split point */
624 /* we delay testing fieldsize until after we've
625 * processed the possible split char directly
626 * following the last field char; so if fieldsize=3
627 * and item="a b cdef", we consume "a b", not "a".
628 * Ditto further down.
630 if (size == fieldsize)
634 if (strchr(PL_chopset, *s)) {
635 /* provisional split point */
636 /* for a non-space split char, we include
637 * the split char; hence the '+1' */
641 if (size == fieldsize)
653 if (!chophere || s == send) {
657 itembytes = chophere - item;
662 case FF_SPACE: /* append padding space (diff of field, item size) */
663 arg = fieldsize - itemsize;
671 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
672 arg = fieldsize - itemsize;
681 case FF_ITEM: /* append a text item, while blanking ctrl chars */
687 case FF_CHOP: /* (for ^*) chop the current item */
688 if (sv != &PL_sv_no) {
689 const char *s = chophere;
697 /* tied, overloaded or similar strangeness.
698 * Do it the hard way */
699 sv_setpvn(sv, s, len - (s-item));
704 case FF_LINESNGL: /* process ^* */
708 case FF_LINEGLOB: /* process @* */
710 const bool oneline = fpc[-1] == FF_LINESNGL;
711 const char *s = item = SvPV_const(sv, len);
712 const char *const send = s + len;
714 item_is_utf8 = DO_UTF8(sv);
725 to_copy = s - item - 1;
739 /* append to_copy bytes from source to PL_formstring.
740 * item_is_utf8 implies source is utf8.
741 * if trans, translate certain characters during the copy */
746 SvCUR_set(PL_formtarget,
747 t - SvPVX_const(PL_formtarget));
749 if (targ_is_utf8 && !item_is_utf8) {
750 source = tmp = bytes_to_utf8(source, &to_copy);
752 if (item_is_utf8 && !targ_is_utf8) {
754 /* Upgrade targ to UTF8, and then we reduce it to
755 a problem we have a simple solution for.
756 Don't need get magic. */
757 sv_utf8_upgrade_nomg(PL_formtarget);
759 /* re-calculate linemark */
760 s = (U8*)SvPVX(PL_formtarget);
761 /* the bytes we initially allocated to append the
762 * whole line may have been gobbled up during the
763 * upgrade, so allocate a whole new line's worth
768 linemark = s - (U8*)SvPVX(PL_formtarget);
770 /* Easy. They agree. */
771 assert (item_is_utf8 == targ_is_utf8);
774 /* @* and ^* are the only things that can exceed
775 * the linemax, so grow by the output size, plus
776 * a whole new form's worth in case of any further
778 grow = linemax + to_copy;
780 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
781 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
783 Copy(source, t, to_copy, char);
785 /* blank out ~ or control chars, depending on trans.
786 * works on bytes not chars, so relies on not
787 * matching utf8 continuation bytes */
789 U8 *send = s + to_copy;
792 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
799 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
805 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
808 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
811 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
814 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
816 /* If the field is marked with ^ and the value is undefined,
818 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
826 /* overflow evidence */
827 if (num_overflow(value, fieldsize, arg)) {
833 /* Formats aren't yet marked for locales, so assume "yes". */
835 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
837 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
838 STORE_LC_NUMERIC_SET_TO_NEEDED();
839 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
842 const char* qfmt = quadmath_format_single(fmt);
845 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
846 len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
848 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
853 /* we generate fmt ourselves so it is safe */
854 GCC_DIAG_IGNORE(-Wformat-nonliteral);
855 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
858 PERL_MY_SNPRINTF_POST_GUARD(len, max);
859 RESTORE_LC_NUMERIC();
864 case FF_NEWLINE: /* delete trailing spaces, then append \n */
866 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
871 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
874 if (arg) { /* repeat until fields exhausted? */
880 t = SvPVX(PL_formtarget) + linemark;
885 case FF_MORE: /* replace long end of string with '...' */
887 const char *s = chophere;
888 const char *send = item + len;
890 while (isSPACE(*s) && (s < send))
895 arg = fieldsize - itemsize;
902 if (strnEQ(s1," ",3)) {
903 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
913 case FF_END: /* tidy up, then return */
915 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
917 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
919 SvUTF8_on(PL_formtarget);
920 FmLINES(PL_formtarget) += lines;
922 if (fpc[-1] == FF_BLANK)
923 RETURNOP(cLISTOP->op_first);
930 /* also used for: pp_mapstart() */
936 if (PL_stack_base + TOPMARK == SP) {
938 if (GIMME_V == G_SCALAR)
940 RETURNOP(PL_op->op_next->op_next);
942 PL_stack_sp = PL_stack_base + TOPMARK + 1;
943 Perl_pp_pushmark(aTHX); /* push dst */
944 Perl_pp_pushmark(aTHX); /* push src */
945 ENTER_with_name("grep"); /* enter outer scope */
949 ENTER_with_name("grep_item"); /* enter inner scope */
952 src = PL_stack_base[TOPMARK];
954 src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
961 if (PL_op->op_type == OP_MAPSTART)
962 Perl_pp_pushmark(aTHX); /* push top */
963 return ((LOGOP*)PL_op->op_next)->op_other;
969 const U8 gimme = GIMME_V;
970 I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
976 /* first, move source pointer to the next item in the source list */
977 ++PL_markstack_ptr[-1];
979 /* if there are new items, push them into the destination list */
980 if (items && gimme != G_VOID) {
981 /* might need to make room back there first */
982 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
983 /* XXX this implementation is very pessimal because the stack
984 * is repeatedly extended for every set of items. Is possible
985 * to do this without any stack extension or copying at all
986 * by maintaining a separate list over which the map iterates
987 * (like foreach does). --gsar */
989 /* everything in the stack after the destination list moves
990 * towards the end the stack by the amount of room needed */
991 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
993 /* items to shift up (accounting for the moved source pointer) */
994 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
996 /* This optimization is by Ben Tilly and it does
997 * things differently from what Sarathy (gsar)
998 * is describing. The downside of this optimization is
999 * that leaves "holes" (uninitialized and hopefully unused areas)
1000 * to the Perl stack, but on the other hand this
1001 * shouldn't be a problem. If Sarathy's idea gets
1002 * implemented, this optimization should become
1003 * irrelevant. --jhi */
1005 shift = count; /* Avoid shifting too often --Ben Tilly */
1009 dst = (SP += shift);
1010 PL_markstack_ptr[-1] += shift;
1011 *PL_markstack_ptr += shift;
1015 /* copy the new items down to the destination list */
1016 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1017 if (gimme == G_ARRAY) {
1018 /* add returned items to the collection (making mortal copies
1019 * if necessary), then clear the current temps stack frame
1020 * *except* for those items. We do this splicing the items
1021 * into the start of the tmps frame (so some items may be on
1022 * the tmps stack twice), then moving PL_tmps_floor above
1023 * them, then freeing the frame. That way, the only tmps that
1024 * accumulate over iterations are the return values for map.
1025 * We have to do to this way so that everything gets correctly
1026 * freed if we die during the map.
1030 /* make space for the slice */
1031 EXTEND_MORTAL(items);
1032 tmpsbase = PL_tmps_floor + 1;
1033 Move(PL_tmps_stack + tmpsbase,
1034 PL_tmps_stack + tmpsbase + items,
1035 PL_tmps_ix - PL_tmps_floor,
1037 PL_tmps_ix += items;
1042 sv = sv_mortalcopy(sv);
1044 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1046 /* clear the stack frame except for the items */
1047 PL_tmps_floor += items;
1049 /* FREETMPS may have cleared the TEMP flag on some of the items */
1052 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1055 /* scalar context: we don't care about which values map returns
1056 * (we use undef here). And so we certainly don't want to do mortal
1057 * copies of meaningless values. */
1058 while (items-- > 0) {
1060 *dst-- = &PL_sv_undef;
1068 LEAVE_with_name("grep_item"); /* exit inner scope */
1071 if (PL_markstack_ptr[-1] > TOPMARK) {
1073 (void)POPMARK; /* pop top */
1074 LEAVE_with_name("grep"); /* exit outer scope */
1075 (void)POPMARK; /* pop src */
1076 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1077 (void)POPMARK; /* pop dst */
1078 SP = PL_stack_base + POPMARK; /* pop original mark */
1079 if (gimme == G_SCALAR) {
1083 else if (gimme == G_ARRAY)
1090 ENTER_with_name("grep_item"); /* enter inner scope */
1093 /* set $_ to the new source item */
1094 src = PL_stack_base[PL_markstack_ptr[-1]];
1095 if (SvPADTMP(src)) {
1096 src = sv_mortalcopy(src);
1101 RETURNOP(cLOGOP->op_other);
1109 if (GIMME_V == G_ARRAY)
1111 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1112 return cLOGOP->op_other;
1121 if (GIMME_V == G_ARRAY) {
1122 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1126 SV * const targ = PAD_SV(PL_op->op_targ);
1129 if (PL_op->op_private & OPpFLIP_LINENUM) {
1130 if (GvIO(PL_last_in_gv)) {
1131 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1134 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1136 flip = SvIV(sv) == SvIV(GvSV(gv));
1142 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1143 if (PL_op->op_flags & OPf_SPECIAL) {
1151 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1154 sv_setpvs(TARG, "");
1160 /* This code tries to decide if "$left .. $right" should use the
1161 magical string increment, or if the range is numeric (we make
1162 an exception for .."0" [#18165]). AMS 20021031. */
1164 #define RANGE_IS_NUMERIC(left,right) ( \
1165 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1166 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1167 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1168 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1169 && (!SvOK(right) || looks_like_number(right))))
1175 if (GIMME_V == G_ARRAY) {
1181 if (RANGE_IS_NUMERIC(left,right)) {
1183 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1184 (SvOK(right) && (SvIOK(right)
1185 ? SvIsUV(right) && SvUV(right) > IV_MAX
1186 : SvNV_nomg(right) > IV_MAX)))
1187 DIE(aTHX_ "Range iterator outside integer range");
1188 i = SvIV_nomg(left);
1189 j = SvIV_nomg(right);
1191 /* Dance carefully around signed max. */
1192 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1195 /* The wraparound of signed integers is undefined
1196 * behavior, but here we aim for count >=1, and
1197 * negative count is just wrong. */
1199 #if IVSIZE > Size_t_size
1206 Perl_croak(aTHX_ "Out of memory during list extend");
1213 SV * const sv = sv_2mortal(newSViv(i));
1215 if (n) /* avoid incrementing above IV_MAX */
1221 const char * const lpv = SvPV_nomg_const(left, llen);
1222 const char * const tmps = SvPV_nomg_const(right, len);
1224 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1225 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1227 if (strEQ(SvPVX_const(sv),tmps))
1229 sv = sv_2mortal(newSVsv(sv));
1236 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1240 if (PL_op->op_private & OPpFLIP_LINENUM) {
1241 if (GvIO(PL_last_in_gv)) {
1242 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1245 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1246 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1254 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1255 sv_catpvs(targ, "E0");
1265 static const char * const context_name[] = {
1267 NULL, /* CXt_WHEN never actually needs "block" */
1268 NULL, /* CXt_BLOCK never actually needs "block" */
1269 NULL, /* CXt_GIVEN never actually needs "block" */
1270 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1271 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1272 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1273 NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1274 NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1282 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1286 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1288 for (i = cxstack_ix; i >= 0; i--) {
1289 const PERL_CONTEXT * const cx = &cxstack[i];
1290 switch (CxTYPE(cx)) {
1296 /* diag_listed_as: Exiting subroutine via %s */
1297 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1298 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1299 if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1302 case CXt_LOOP_PLAIN:
1303 case CXt_LOOP_LAZYIV:
1304 case CXt_LOOP_LAZYSV:
1308 STRLEN cx_label_len = 0;
1309 U32 cx_label_flags = 0;
1310 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1312 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1315 (const U8*)cx_label, cx_label_len,
1316 (const U8*)label, len) == 0)
1318 (const U8*)label, len,
1319 (const U8*)cx_label, cx_label_len) == 0)
1320 : (len == cx_label_len && ((cx_label == label)
1321 || memEQ(cx_label, label, len))) )) {
1322 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1323 (long)i, cx_label));
1326 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1337 Perl_dowantarray(pTHX)
1339 const U8 gimme = block_gimme();
1340 return (gimme == G_VOID) ? G_SCALAR : gimme;
1344 Perl_block_gimme(pTHX)
1346 const I32 cxix = dopoptosub(cxstack_ix);
1351 gimme = (cxstack[cxix].blk_gimme & G_WANT);
1353 Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1359 Perl_is_lvalue_sub(pTHX)
1361 const I32 cxix = dopoptosub(cxstack_ix);
1362 assert(cxix >= 0); /* We should only be called from inside subs */
1364 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1365 return CxLVAL(cxstack + cxix);
1370 /* only used by cx_pushsub() */
1372 Perl_was_lvalue_sub(pTHX)
1374 const I32 cxix = dopoptosub(cxstack_ix-1);
1375 assert(cxix >= 0); /* We should only be called from inside subs */
1377 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1378 return CxLVAL(cxstack + cxix);
1384 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1388 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1390 PERL_UNUSED_CONTEXT;
1393 for (i = startingblock; i >= 0; i--) {
1394 const PERL_CONTEXT * const cx = &cxstk[i];
1395 switch (CxTYPE(cx)) {
1399 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1400 * twice; the first for the normal foo() call, and the second
1401 * for a faked up re-entry into the sub to execute the
1402 * code block. Hide this faked entry from the world. */
1403 if (cx->cx_type & CXp_SUB_RE_FAKE)
1408 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1416 S_dopoptoeval(pTHX_ I32 startingblock)
1419 for (i = startingblock; i >= 0; i--) {
1420 const PERL_CONTEXT *cx = &cxstack[i];
1421 switch (CxTYPE(cx)) {
1425 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1433 S_dopoptoloop(pTHX_ I32 startingblock)
1436 for (i = startingblock; i >= 0; i--) {
1437 const PERL_CONTEXT * const cx = &cxstack[i];
1438 switch (CxTYPE(cx)) {
1444 /* diag_listed_as: Exiting subroutine via %s */
1445 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1446 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1447 if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1450 case CXt_LOOP_PLAIN:
1451 case CXt_LOOP_LAZYIV:
1452 case CXt_LOOP_LAZYSV:
1455 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1462 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1465 S_dopoptogivenfor(pTHX_ I32 startingblock)
1468 for (i = startingblock; i >= 0; i--) {
1469 const PERL_CONTEXT *cx = &cxstack[i];
1470 switch (CxTYPE(cx)) {
1474 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1476 case CXt_LOOP_PLAIN:
1477 assert(!(cx->cx_type & CXp_FOR_DEF));
1479 case CXt_LOOP_LAZYIV:
1480 case CXt_LOOP_LAZYSV:
1483 if (cx->cx_type & CXp_FOR_DEF) {
1484 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1493 S_dopoptowhen(pTHX_ I32 startingblock)
1496 for (i = startingblock; i >= 0; i--) {
1497 const PERL_CONTEXT *cx = &cxstack[i];
1498 switch (CxTYPE(cx)) {
1502 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1509 /* dounwind(): pop all contexts above (but not including) cxix.
1510 * Note that it clears the savestack frame associated with each popped
1511 * context entry, but doesn't free any temps.
1512 * It does a cx_popblock() of the last frame that it pops, and leaves
1513 * cxstack_ix equal to cxix.
1517 Perl_dounwind(pTHX_ I32 cxix)
1519 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1522 while (cxstack_ix > cxix) {
1523 PERL_CONTEXT *cx = CX_CUR();
1525 CX_DEBUG(cx, "UNWIND");
1526 /* Note: we don't need to restore the base context info till the end. */
1530 switch (CxTYPE(cx)) {
1540 case CXt_LOOP_PLAIN:
1541 case CXt_LOOP_LAZYIV:
1542 case CXt_LOOP_LAZYSV:
1555 /* these two don't have a POPFOO() */
1561 if (cxstack_ix == cxix + 1) {
1570 Perl_qerror(pTHX_ SV *err)
1572 PERL_ARGS_ASSERT_QERROR;
1575 if (PL_in_eval & EVAL_KEEPERR) {
1576 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1580 sv_catsv(ERRSV, err);
1583 sv_catsv(PL_errors, err);
1585 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1587 ++PL_parser->error_count;
1592 /* pop a CXt_EVAL context and in addition, if it was a require then
1594 * 0: do nothing extra;
1595 * 1: undef $INC{$name}; croak "$name did not return a true value";
1596 * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1600 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1602 SV *namesv = NULL; /* init to avoid dumb compiler warning */
1606 do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1608 /* keep namesv alive after cx_popeval() */
1609 namesv = cx->blk_eval.old_namesv;
1610 cx->blk_eval.old_namesv = NULL;
1619 HV *inc_hv = GvHVn(PL_incgv);
1620 I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv);
1621 const char *key = SvPVX_const(namesv);
1624 (void)hv_delete(inc_hv, key, klen, G_DISCARD);
1625 fmt = "%"SVf" did not return a true value";
1629 (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0);
1630 fmt = "%"SVf"Compilation failed in require";
1632 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1635 Perl_croak(aTHX_ fmt, SVfARG(errsv));
1640 /* die_unwind(): this is the final destination for the various croak()
1641 * functions. If we're in an eval, unwind the context and other stacks
1642 * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1643 * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1644 * to is a require the exception will be rethrown, as requires don't
1645 * actually trap exceptions.
1649 Perl_die_unwind(pTHX_ SV *msv)
1652 U8 in_eval = PL_in_eval;
1653 PERL_ARGS_ASSERT_DIE_UNWIND;
1658 exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1661 * Historically, perl used to set ERRSV ($@) early in the die
1662 * process and rely on it not getting clobbered during unwinding.
1663 * That sucked, because it was liable to get clobbered, so the
1664 * setting of ERRSV used to emit the exception from eval{} has
1665 * been moved to much later, after unwinding (see just before
1666 * JMPENV_JUMP below). However, some modules were relying on the
1667 * early setting, by examining $@ during unwinding to use it as
1668 * a flag indicating whether the current unwinding was caused by
1669 * an exception. It was never a reliable flag for that purpose,
1670 * being totally open to false positives even without actual
1671 * clobberage, but was useful enough for production code to
1672 * semantically rely on it.
1674 * We'd like to have a proper introspective interface that
1675 * explicitly describes the reason for whatever unwinding
1676 * operations are currently in progress, so that those modules
1677 * work reliably and $@ isn't further overloaded. But we don't
1678 * have one yet. In its absence, as a stopgap measure, ERRSV is
1679 * now *additionally* set here, before unwinding, to serve as the
1680 * (unreliable) flag that it used to.
1682 * This behaviour is temporary, and should be removed when a
1683 * proper way to detect exceptional unwinding has been developed.
1684 * As of 2010-12, the authors of modules relying on the hack
1685 * are aware of the issue, because the modules failed on
1686 * perls 5.13.{1..7} which had late setting of $@ without this
1687 * early-setting hack.
1689 if (!(in_eval & EVAL_KEEPERR))
1690 sv_setsv_flags(ERRSV, exceptsv,
1691 (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
1693 if (in_eval & EVAL_KEEPERR) {
1694 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1698 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1699 && PL_curstackinfo->si_prev)
1709 JMPENV *restartjmpenv;
1712 if (cxix < cxstack_ix)
1716 assert(CxTYPE(cx) == CXt_EVAL);
1718 /* return false to the caller of eval */
1719 oldsp = PL_stack_base + cx->blk_oldsp;
1720 gimme = cx->blk_gimme;
1721 if (gimme == G_SCALAR)
1722 *++oldsp = &PL_sv_undef;
1723 PL_stack_sp = oldsp;
1725 restartjmpenv = cx->blk_eval.cur_top_env;
1726 restartop = cx->blk_eval.retop;
1727 /* Note that unlike pp_entereval, pp_require isn't supposed to
1728 * trap errors. So if we're a require, after we pop the
1729 * CXt_EVAL that pp_require pushed, rethrow the error with
1730 * croak(exceptsv). This is all handled by the call below when
1733 S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
1735 if (!(in_eval & EVAL_KEEPERR))
1736 sv_setsv(ERRSV, exceptsv);
1737 PL_restartjmpenv = restartjmpenv;
1738 PL_restartop = restartop;
1740 NOT_REACHED; /* NOTREACHED */
1744 write_to_stderr(exceptsv);
1746 NOT_REACHED; /* NOTREACHED */
1752 if (SvTRUE(left) != SvTRUE(right))
1760 =head1 CV Manipulation Functions
1762 =for apidoc caller_cx
1764 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1765 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1766 information returned to Perl by C<caller>. Note that XSUBs don't get a
1767 stack frame, so C<caller_cx(0, NULL)> will return information for the
1768 immediately-surrounding Perl code.
1770 This function skips over the automatic calls to C<&DB::sub> made on the
1771 behalf of the debugger. If the stack frame requested was a sub called by
1772 C<DB::sub>, the return value will be the frame for the call to
1773 C<DB::sub>, since that has the correct line number/etc. for the call
1774 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1775 frame for the sub call itself.
1780 const PERL_CONTEXT *
1781 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1783 I32 cxix = dopoptosub(cxstack_ix);
1784 const PERL_CONTEXT *cx;
1785 const PERL_CONTEXT *ccstack = cxstack;
1786 const PERL_SI *top_si = PL_curstackinfo;
1789 /* we may be in a higher stacklevel, so dig down deeper */
1790 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1791 top_si = top_si->si_prev;
1792 ccstack = top_si->si_cxstack;
1793 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1797 /* caller() should not report the automatic calls to &DB::sub */
1798 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1799 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1803 cxix = dopoptosub_at(ccstack, cxix - 1);
1806 cx = &ccstack[cxix];
1807 if (dbcxp) *dbcxp = cx;
1809 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1810 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1811 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1812 field below is defined for any cx. */
1813 /* caller() should not report the automatic calls to &DB::sub */
1814 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1815 cx = &ccstack[dbcxix];
1824 const PERL_CONTEXT *cx;
1825 const PERL_CONTEXT *dbcx;
1827 const HEK *stash_hek;
1829 bool has_arg = MAXARG && TOPs;
1838 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1840 if (gimme != G_ARRAY) {
1847 CX_DEBUG(cx, "CALLER");
1848 assert(CopSTASH(cx->blk_oldcop));
1849 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1850 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1852 if (gimme != G_ARRAY) {
1855 PUSHs(&PL_sv_undef);
1858 sv_sethek(TARG, stash_hek);
1867 PUSHs(&PL_sv_undef);
1870 sv_sethek(TARG, stash_hek);
1873 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1874 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1875 cx->blk_sub.retop, TRUE);
1877 lcop = cx->blk_oldcop;
1878 mPUSHu(CopLINE(lcop));
1881 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1882 /* So is ccstack[dbcxix]. */
1883 if (CvHASGV(dbcx->blk_sub.cv)) {
1884 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1885 PUSHs(boolSV(CxHASARGS(cx)));
1888 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1889 PUSHs(boolSV(CxHASARGS(cx)));
1893 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1896 gimme = cx->blk_gimme;
1897 if (gimme == G_VOID)
1898 PUSHs(&PL_sv_undef);
1900 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1901 if (CxTYPE(cx) == CXt_EVAL) {
1903 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1904 SV *cur_text = cx->blk_eval.cur_text;
1905 if (SvCUR(cur_text) >= 2) {
1906 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1907 SvUTF8(cur_text)|SVs_TEMP));
1910 /* I think this is will always be "", but be sure */
1911 PUSHs(sv_2mortal(newSVsv(cur_text)));
1917 else if (cx->blk_eval.old_namesv) {
1918 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1921 /* eval BLOCK (try blocks have old_namesv == 0) */
1923 PUSHs(&PL_sv_undef);
1924 PUSHs(&PL_sv_undef);
1928 PUSHs(&PL_sv_undef);
1929 PUSHs(&PL_sv_undef);
1931 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1932 && CopSTASH_eq(PL_curcop, PL_debstash))
1934 /* slot 0 of the pad contains the original @_ */
1935 AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
1936 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1937 cx->blk_sub.olddepth+1]))[0]);
1938 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1940 Perl_init_dbargs(aTHX);
1942 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1943 av_extend(PL_dbargs, AvFILLp(ary) + off);
1944 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1945 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1947 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1950 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1952 if (old_warnings == pWARN_NONE)
1953 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1954 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1955 mask = &PL_sv_undef ;
1956 else if (old_warnings == pWARN_ALL ||
1957 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1958 /* Get the bit mask for $warnings::Bits{all}, because
1959 * it could have been extended by warnings::register */
1961 HV * const bits = get_hv("warnings::Bits", 0);
1962 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1963 mask = newSVsv(*bits_all);
1966 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1970 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1974 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1975 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1985 if (MAXARG < 1 || (!TOPs && !POPs))
1986 tmps = NULL, len = 0;
1988 tmps = SvPVx_const(POPs, len);
1989 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1994 /* like pp_nextstate, but used instead when the debugger is active */
1998 PL_curcop = (COP*)PL_op;
1999 TAINT_NOT; /* Each statement is presumed innocent */
2000 PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
2005 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2006 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2010 const U8 gimme = G_ARRAY;
2011 GV * const gv = PL_DBgv;
2014 if (gv && isGV_with_GP(gv))
2017 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2018 DIE(aTHX_ "No DB::DB routine defined");
2020 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2021 /* don't do recursive DB::DB call */
2031 (void)(*CvXSUB(cv))(aTHX_ cv);
2037 cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
2038 cx_pushsub(cx, cv, PL_op->op_next, 0);
2039 /* OP_DBSTATE's op_private holds hint bits rather than
2040 * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2041 * any CxLVAL() flags that have now been mis-calculated */
2048 if (CvDEPTH(cv) >= 2)
2049 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2050 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2051 RETURNOP(CvSTART(cv));
2063 (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2075 assert(CxTYPE(cx) == CXt_BLOCK);
2077 if (PL_op->op_flags & OPf_SPECIAL)
2078 /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */
2079 cx->blk_oldpm = PL_curpm;
2081 oldsp = PL_stack_base + cx->blk_oldsp;
2082 gimme = cx->blk_gimme;
2084 if (gimme == G_VOID)
2085 PL_stack_sp = oldsp;
2087 leave_adjust_stacks(oldsp, oldsp, gimme,
2088 PL_op->op_private & OPpLVALUE ? 3 : 1);
2098 S_outside_integer(pTHX_ SV *sv)
2101 const NV nv = SvNV_nomg(sv);
2102 if (Perl_isinfnan(nv))
2104 #ifdef NV_PRESERVES_UV
2105 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2108 if (nv <= (NV)IV_MIN)
2111 ((nv > (NV)UV_MAX ||
2112 SvUV_nomg(sv) > (UV)IV_MAX)))
2123 const U8 gimme = GIMME_V;
2124 void *itervarp; /* GV or pad slot of the iteration variable */
2125 SV *itersave; /* the old var in the iterator var slot */
2128 if (PL_op->op_targ) { /* "my" variable */
2129 itervarp = &PAD_SVl(PL_op->op_targ);
2130 itersave = *(SV**)itervarp;
2132 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2133 /* the SV currently in the pad slot is never live during
2134 * iteration (the slot is always aliased to one of the items)
2135 * so it's always stale */
2136 SvPADSTALE_on(itersave);
2138 SvREFCNT_inc_simple_void_NN(itersave);
2139 cxflags = CXp_FOR_PAD;
2142 SV * const sv = POPs;
2143 itervarp = (void *)sv;
2144 if (LIKELY(isGV(sv))) { /* symbol table variable */
2145 itersave = GvSV(sv);
2146 SvREFCNT_inc_simple_void(itersave);
2147 cxflags = CXp_FOR_GV;
2148 if (PL_op->op_private & OPpITER_DEF)
2149 cxflags |= CXp_FOR_DEF;
2151 else { /* LV ref: for \$foo (...) */
2152 assert(SvTYPE(sv) == SVt_PVMG);
2153 assert(SvMAGIC(sv));
2154 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2156 cxflags = CXp_FOR_LVREF;
2159 /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2160 assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2162 /* Note that this context is initially set as CXt_NULL. Further on
2163 * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2164 * there mustn't be anything in the blk_loop substruct that requires
2165 * freeing or undoing, in case we die in the meantime. And vice-versa.
2167 cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2168 cx_pushloop_for(cx, itervarp, itersave);
2170 if (PL_op->op_flags & OPf_STACKED) {
2171 /* OPf_STACKED implies either a single array: for(@), with a
2172 * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2174 SV *maybe_ary = POPs;
2175 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2178 SV * const right = maybe_ary;
2179 if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2180 DIE(aTHX_ "Assigned value is not a reference");
2183 if (RANGE_IS_NUMERIC(sv,right)) {
2184 cx->cx_type |= CXt_LOOP_LAZYIV;
2185 if (S_outside_integer(aTHX_ sv) ||
2186 S_outside_integer(aTHX_ right))
2187 DIE(aTHX_ "Range iterator outside integer range");
2188 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2189 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2192 cx->cx_type |= CXt_LOOP_LAZYSV;
2193 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2194 cx->blk_loop.state_u.lazysv.end = right;
2195 SvREFCNT_inc_simple_void_NN(right);
2196 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2197 /* This will do the upgrade to SVt_PV, and warn if the value
2198 is uninitialised. */
2199 (void) SvPV_nolen_const(right);
2200 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2201 to replace !SvOK() with a pointer to "". */
2203 SvREFCNT_dec(right);
2204 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2208 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2209 /* for (@array) {} */
2210 cx->cx_type |= CXt_LOOP_ARY;
2211 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2212 SvREFCNT_inc_simple_void_NN(maybe_ary);
2213 cx->blk_loop.state_u.ary.ix =
2214 (PL_op->op_private & OPpITER_REVERSED) ?
2215 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2218 /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
2220 else { /* iterating over items on the stack */
2221 cx->cx_type |= CXt_LOOP_LIST;
2222 cx->blk_oldsp = SP - PL_stack_base;
2223 cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2224 cx->blk_loop.state_u.stack.ix =
2225 (PL_op->op_private & OPpITER_REVERSED)
2227 : cx->blk_loop.state_u.stack.basesp;
2228 /* pre-extend stack so pp_iter doesn't have to check every time
2229 * it pushes yes/no */
2239 const U8 gimme = GIMME_V;
2241 cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2242 cx_pushloop_plain(cx);
2255 assert(CxTYPE_is_LOOP(cx));
2256 oldsp = PL_stack_base + cx->blk_oldsp;
2257 base = CxTYPE(cx) == CXt_LOOP_LIST
2258 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2260 gimme = cx->blk_gimme;
2262 if (gimme == G_VOID)
2265 leave_adjust_stacks(oldsp, base, gimme,
2266 PL_op->op_private & OPpLVALUE ? 3 : 1);
2269 cx_poploop(cx); /* Stack values are safe: release loop vars ... */
2277 /* This duplicates most of pp_leavesub, but with additional code to handle
2278 * return args in lvalue context. It was forked from pp_leavesub to
2279 * avoid slowing down that function any further.
2281 * Any changes made to this function may need to be copied to pp_leavesub
2284 * also tail-called by pp_return
2295 assert(CxTYPE(cx) == CXt_SUB);
2297 if (CxMULTICALL(cx)) {
2298 /* entry zero of a stack is always PL_sv_undef, which
2299 * simplifies converting a '()' return into undef in scalar context */
2300 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2304 gimme = cx->blk_gimme;
2305 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2307 if (gimme == G_VOID)
2308 PL_stack_sp = oldsp;
2310 U8 lval = CxLVAL(cx);
2311 bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2312 const char *what = NULL;
2314 if (gimme == G_SCALAR) {
2316 /* check for bad return arg */
2317 if (oldsp < PL_stack_sp) {
2318 SV *sv = *PL_stack_sp;
2319 if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2321 SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2322 : "a readonly value" : "a temporary";
2327 /* sub:lvalue{} will take us here. */
2332 "Can't return %s from lvalue subroutine", what);
2336 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2338 if (lval & OPpDEREF) {
2339 /* lval_sub()->{...} and similar */
2343 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2349 assert(gimme == G_ARRAY);
2350 assert (!(lval & OPpDEREF));
2353 /* scan for bad return args */
2355 for (p = PL_stack_sp; p > oldsp; p--) {
2357 /* the PL_sv_undef exception is to allow things like
2358 * this to work, where PL_sv_undef acts as 'skip'
2359 * placeholder on the LHS of list assigns:
2360 * sub foo :lvalue { undef }
2361 * ($a, undef, foo(), $b) = 1..4;
2363 if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2365 /* Might be flattened array after $#array = */
2366 what = SvREADONLY(sv)
2367 ? "a readonly value" : "a temporary";
2373 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2378 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
2380 retop = cx->blk_sub.retop;
2391 const I32 cxix = dopoptosub(cxstack_ix);
2393 assert(cxstack_ix >= 0);
2394 if (cxix < cxstack_ix) {
2396 if (!( PL_curstackinfo->si_type == PERLSI_SORT
2397 || ( PL_curstackinfo->si_type == PERLSI_MULTICALL
2398 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2401 DIE(aTHX_ "Can't return outside a subroutine");
2403 * a sort block, which is a CXt_NULL not a CXt_SUB;
2404 * or a /(?{...})/ block.
2405 * Handle specially. */
2406 assert(CxTYPE(&cxstack[0]) == CXt_NULL
2407 || ( CxTYPE(&cxstack[0]) == CXt_SUB
2408 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2409 if (cxstack_ix > 0) {
2410 /* See comment below about context popping. Since we know
2411 * we're scalar and not lvalue, we can preserve the return
2412 * value in a simpler fashion than there. */
2414 assert(cxstack[0].blk_gimme == G_SCALAR);
2415 if ( (sp != PL_stack_base)
2416 && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2418 *SP = sv_mortalcopy(sv);
2421 /* caller responsible for popping cxstack[0] */
2425 /* There are contexts that need popping. Doing this may free the
2426 * return value(s), so preserve them first: e.g. popping the plain
2427 * loop here would free $x:
2428 * sub f { { my $x = 1; return $x } }
2429 * We may also need to shift the args down; for example,
2430 * for (1,2) { return 3,4 }
2431 * leaves 1,2,3,4 on the stack. Both these actions will be done by
2432 * leave_adjust_stacks(), along with freeing any temps. Note that
2433 * whoever we tail-call (e.g. pp_leaveeval) will also call
2434 * leave_adjust_stacks(); however, the second call is likely to
2435 * just see a bunch of SvTEMPs with a ref count of 1, and so just
2436 * pass them through, rather than copying them again. So this
2437 * isn't as inefficient as it sounds.
2439 cx = &cxstack[cxix];
2441 if (cx->blk_gimme != G_VOID)
2442 leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2444 CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2448 cx = &cxstack[cxix]; /* CX stack may have been realloced */
2451 /* Like in the branch above, we need to handle any extra junk on
2452 * the stack. But because we're not also popping extra contexts, we
2453 * don't have to worry about prematurely freeing args. So we just
2454 * need to do the bare minimum to handle junk, and leave the main
2455 * arg processing in the function we tail call, e.g. pp_leavesub.
2456 * In list context we have to splice out the junk; in scalar
2457 * context we can leave as-is (pp_leavesub will later return the
2458 * top stack element). But for an empty arg list, e.g.
2459 * for (1,2) { return }
2460 * we need to set sp = oldsp so that pp_leavesub knows to push
2461 * &PL_sv_undef onto the stack.
2464 cx = &cxstack[cxix];
2465 oldsp = PL_stack_base + cx->blk_oldsp;
2466 if (oldsp != MARK) {
2467 SSize_t nargs = SP - MARK;
2469 if (cx->blk_gimme == G_ARRAY) {
2470 /* shift return args to base of call stack frame */
2471 Move(MARK + 1, oldsp + 1, nargs, SV*);
2472 PL_stack_sp = oldsp + nargs;
2476 PL_stack_sp = oldsp;
2480 /* fall through to a normal exit */
2481 switch (CxTYPE(cx)) {
2483 return CxTRYBLOCK(cx)
2484 ? Perl_pp_leavetry(aTHX)
2485 : Perl_pp_leaveeval(aTHX);
2487 return CvLVALUE(cx->blk_sub.cv)
2488 ? Perl_pp_leavesublv(aTHX)
2489 : Perl_pp_leavesub(aTHX);
2491 return Perl_pp_leavewrite(aTHX);
2493 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2497 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2499 static PERL_CONTEXT *
2503 if (PL_op->op_flags & OPf_SPECIAL) {
2504 cxix = dopoptoloop(cxstack_ix);
2506 /* diag_listed_as: Can't "last" outside a loop block */
2507 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2513 const char * const label =
2514 PL_op->op_flags & OPf_STACKED
2515 ? SvPV(TOPs,label_len)
2516 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2517 const U32 label_flags =
2518 PL_op->op_flags & OPf_STACKED
2520 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2522 cxix = dopoptolabel(label, label_len, label_flags);
2524 /* diag_listed_as: Label not found for "last %s" */
2525 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2527 SVfARG(PL_op->op_flags & OPf_STACKED
2528 && !SvGMAGICAL(TOPp1s)
2530 : newSVpvn_flags(label,
2532 label_flags | SVs_TEMP)));
2534 if (cxix < cxstack_ix)
2536 return &cxstack[cxix];
2545 cx = S_unwind_loop(aTHX);
2547 assert(CxTYPE_is_LOOP(cx));
2548 PL_stack_sp = PL_stack_base
2549 + (CxTYPE(cx) == CXt_LOOP_LIST
2550 ? cx->blk_loop.state_u.stack.basesp
2556 /* Stack values are safe: */
2558 cx_poploop(cx); /* release loop vars ... */
2560 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2570 /* if not a bare 'next' in the main scope, search for it */
2572 if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
2573 cx = S_unwind_loop(aTHX);
2576 PL_curcop = cx->blk_oldcop;
2578 return (cx)->blk_loop.my_op->op_nextop;
2583 PERL_CONTEXT *cx = S_unwind_loop(aTHX);
2584 OP* redo_op = cx->blk_loop.my_op->op_redoop;
2586 if (redo_op->op_type == OP_ENTER) {
2587 /* pop one less context to avoid $x being freed in while (my $x..) */
2590 assert(CxTYPE(cx) == CXt_BLOCK);
2591 redo_op = redo_op->op_next;
2597 PL_curcop = cx->blk_oldcop;
2603 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2606 static const char* const too_deep = "Target of goto is too deeply nested";
2608 PERL_ARGS_ASSERT_DOFINDLABEL;
2611 Perl_croak(aTHX_ "%s", too_deep);
2612 if (o->op_type == OP_LEAVE ||
2613 o->op_type == OP_SCOPE ||
2614 o->op_type == OP_LEAVELOOP ||
2615 o->op_type == OP_LEAVESUB ||
2616 o->op_type == OP_LEAVETRY)
2618 *ops++ = cUNOPo->op_first;
2620 Perl_croak(aTHX_ "%s", too_deep);
2623 if (o->op_flags & OPf_KIDS) {
2625 /* First try all the kids at this level, since that's likeliest. */
2626 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2627 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2628 STRLEN kid_label_len;
2629 U32 kid_label_flags;
2630 const char *kid_label = CopLABEL_len_flags(kCOP,
2631 &kid_label_len, &kid_label_flags);
2633 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2636 (const U8*)kid_label, kid_label_len,
2637 (const U8*)label, len) == 0)
2639 (const U8*)label, len,
2640 (const U8*)kid_label, kid_label_len) == 0)
2641 : ( len == kid_label_len && ((kid_label == label)
2642 || memEQ(kid_label, label, len)))))
2646 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2647 if (kid == PL_lastgotoprobe)
2649 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2652 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2653 ops[-1]->op_type == OP_DBSTATE)
2658 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2667 /* also used for: pp_dump() */
2675 #define GOTO_DEPTH 64
2676 OP *enterops[GOTO_DEPTH];
2677 const char *label = NULL;
2678 STRLEN label_len = 0;
2679 U32 label_flags = 0;
2680 const bool do_dump = (PL_op->op_type == OP_DUMP);
2681 static const char* const must_have_label = "goto must have label";
2683 if (PL_op->op_flags & OPf_STACKED) {
2684 /* goto EXPR or goto &foo */
2686 SV * const sv = POPs;
2689 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2690 /* This egregious kludge implements goto &subroutine */
2693 CV *cv = MUTABLE_CV(SvRV(sv));
2694 AV *arg = GvAV(PL_defgv);
2696 while (!CvROOT(cv) && !CvXSUB(cv)) {
2697 const GV * const gv = CvGV(cv);
2701 /* autoloaded stub? */
2702 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2704 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2706 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2707 if (autogv && (cv = GvCV(autogv)))
2709 tmpstr = sv_newmortal();
2710 gv_efullname3(tmpstr, gv, NULL);
2711 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2713 DIE(aTHX_ "Goto undefined subroutine");
2716 cxix = dopoptosub(cxstack_ix);
2718 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2720 cx = &cxstack[cxix];
2721 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2722 if (CxTYPE(cx) == CXt_EVAL) {
2724 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2725 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2727 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2728 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2730 else if (CxMULTICALL(cx))
2731 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2733 /* First do some returnish stuff. */
2735 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2737 if (cxix < cxstack_ix) {
2744 /* protect @_ during save stack unwind. */
2746 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
2748 assert(PL_scopestack_ix == cx->blk_oldscopesp);
2751 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2752 /* this is part of cx_popsub_args() */
2753 AV* av = MUTABLE_AV(PAD_SVl(0));
2754 assert(AvARRAY(MUTABLE_AV(
2755 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2756 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2758 /* we are going to donate the current @_ from the old sub
2759 * to the new sub. This first part of the donation puts a
2760 * new empty AV in the pad[0] slot of the old sub,
2761 * unless pad[0] and @_ differ (e.g. if the old sub did
2762 * local *_ = []); in which case clear the old pad[0]
2763 * array in the usual way */
2764 if (av == arg || AvREAL(av))
2765 clear_defarray(av, av == arg);
2766 else CLEAR_ARGARRAY(av);
2769 /* don't restore PL_comppad here. It won't be needed if the
2770 * sub we're going to is non-XS, but restoring it early then
2771 * croaking (e.g. the "Goto undefined subroutine" below)
2772 * means the CX block gets processed again in dounwind,
2773 * but this time with the wrong PL_comppad */
2775 /* A destructor called during LEAVE_SCOPE could have undefined
2776 * our precious cv. See bug #99850. */
2777 if (!CvROOT(cv) && !CvXSUB(cv)) {
2778 const GV * const gv = CvGV(cv);
2780 SV * const tmpstr = sv_newmortal();
2781 gv_efullname3(tmpstr, gv, NULL);
2782 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2785 DIE(aTHX_ "Goto undefined subroutine");
2788 if (CxTYPE(cx) == CXt_SUB) {
2789 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2790 SvREFCNT_dec_NN(cx->blk_sub.cv);
2793 /* Now do some callish stuff. */
2795 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2796 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2801 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2803 /* put GvAV(defgv) back onto stack */
2805 EXTEND(SP, items+1); /* @_ could have been extended. */
2810 bool r = cBOOL(AvREAL(arg));
2811 for (index=0; index<items; index++)
2815 SV ** const svp = av_fetch(arg, index, 0);
2816 sv = svp ? *svp : NULL;
2818 else sv = AvARRAY(arg)[index];
2820 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2821 : sv_2mortal(newSVavdefelem(arg, index, 1));
2825 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2826 /* Restore old @_ */
2827 CX_POP_SAVEARRAY(cx);
2830 retop = cx->blk_sub.retop;
2831 PL_comppad = cx->blk_sub.prevcomppad;
2832 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2834 /* XS subs don't have a CXt_SUB, so pop it;
2835 * this is a cx_popblock(), less all the stuff we already did
2836 * for cx_topblock() earlier */
2837 PL_curcop = cx->blk_oldcop;
2840 /* Push a mark for the start of arglist */
2843 (void)(*CvXSUB(cv))(aTHX_ cv);
2848 PADLIST * const padlist = CvPADLIST(cv);
2850 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2852 /* partial unrolled cx_pushsub(): */
2854 cx->blk_sub.cv = cv;
2855 cx->blk_sub.olddepth = CvDEPTH(cv);
2858 SvREFCNT_inc_simple_void_NN(cv);
2859 if (CvDEPTH(cv) > 1) {
2860 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2861 sub_crush_depth(cv);
2862 pad_push(padlist, CvDEPTH(cv));
2864 PL_curcop = cx->blk_oldcop;
2865 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2868 /* second half of donating @_ from the old sub to the
2869 * new sub: abandon the original pad[0] AV in the
2870 * new sub, and replace it with the donated @_.
2871 * pad[0] takes ownership of the extra refcount
2872 * we gave arg earlier */
2874 SvREFCNT_dec(PAD_SVl(0));
2875 PAD_SVl(0) = (SV *)arg;
2876 SvREFCNT_inc_simple_void_NN(arg);
2879 /* GvAV(PL_defgv) might have been modified on scope
2880 exit, so point it at arg again. */
2881 if (arg != GvAV(PL_defgv)) {
2882 AV * const av = GvAV(PL_defgv);
2883 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2888 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2889 Perl_get_db_sub(aTHX_ NULL, cv);
2891 CV * const gotocv = get_cvs("DB::goto", 0);
2893 PUSHMARK( PL_stack_sp );
2894 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2899 retop = CvSTART(cv);
2900 goto putback_return;
2905 label = SvPV_nomg_const(sv, label_len);
2906 label_flags = SvUTF8(sv);
2909 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2910 /* goto LABEL or dump LABEL */
2911 label = cPVOP->op_pv;
2912 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2913 label_len = strlen(label);
2915 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2920 OP *gotoprobe = NULL;
2921 bool leaving_eval = FALSE;
2922 bool in_block = FALSE;
2923 PERL_CONTEXT *last_eval_cx = NULL;
2927 PL_lastgotoprobe = NULL;
2929 for (ix = cxstack_ix; ix >= 0; ix--) {
2931 switch (CxTYPE(cx)) {
2933 leaving_eval = TRUE;
2934 if (!CxTRYBLOCK(cx)) {
2935 gotoprobe = (last_eval_cx ?
2936 last_eval_cx->blk_eval.old_eval_root :
2941 /* else fall through */
2942 case CXt_LOOP_PLAIN:
2943 case CXt_LOOP_LAZYIV:
2944 case CXt_LOOP_LAZYSV:
2949 gotoprobe = OpSIBLING(cx->blk_oldcop);
2955 gotoprobe = OpSIBLING(cx->blk_oldcop);
2958 gotoprobe = PL_main_root;
2961 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2962 gotoprobe = CvROOT(cx->blk_sub.cv);
2968 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2971 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
2972 CxTYPE(cx), (long) ix);
2973 gotoprobe = PL_main_root;
2979 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
2980 enterops, enterops + GOTO_DEPTH);
2983 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
2984 sibl1->op_type == OP_UNSTACK &&
2985 (sibl2 = OpSIBLING(sibl1)))
2987 retop = dofindlabel(sibl2,
2988 label, label_len, label_flags, enterops,
2989 enterops + GOTO_DEPTH);
2994 PL_lastgotoprobe = gotoprobe;
2997 DIE(aTHX_ "Can't find label %"UTF8f,
2998 UTF8fARG(label_flags, label_len, label));
3000 /* if we're leaving an eval, check before we pop any frames
3001 that we're not going to punt, otherwise the error
3004 if (leaving_eval && *enterops && enterops[1]) {
3006 for (i = 1; enterops[i]; i++)
3007 if (enterops[i]->op_type == OP_ENTERITER)
3008 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3011 if (*enterops && enterops[1]) {
3012 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3014 deprecate("\"goto\" to jump into a construct");
3017 /* pop unwanted frames */
3019 if (ix < cxstack_ix) {
3021 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3027 /* push wanted frames */
3029 if (*enterops && enterops[1]) {
3030 OP * const oldop = PL_op;
3031 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3032 for (; enterops[ix]; ix++) {
3033 PL_op = enterops[ix];
3034 /* Eventually we may want to stack the needed arguments
3035 * for each op. For now, we punt on the hard ones. */
3036 if (PL_op->op_type == OP_ENTERITER)
3037 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3038 PL_op->op_ppaddr(aTHX);
3046 if (!retop) retop = PL_main_start;
3048 PL_restartop = retop;
3049 PL_do_undump = TRUE;
3053 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3054 PL_do_undump = FALSE;
3072 anum = 0; (void)POPs;
3078 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3081 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3084 PL_exit_flags |= PERL_EXIT_EXPECTED;
3086 PUSHs(&PL_sv_undef);
3093 S_save_lines(pTHX_ AV *array, SV *sv)
3095 const char *s = SvPVX_const(sv);
3096 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3099 PERL_ARGS_ASSERT_SAVE_LINES;
3101 while (s && s < send) {
3103 SV * const tmpstr = newSV_type(SVt_PVMG);
3105 t = (const char *)memchr(s, '\n', send - s);
3111 sv_setpvn(tmpstr, s, t - s);
3112 av_store(array, line++, tmpstr);
3120 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3122 0 is used as continue inside eval,
3124 3 is used for a die caught by an inner eval - continue inner loop
3126 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3127 establish a local jmpenv to handle exception traps.
3132 S_docatch(pTHX_ OP *o)
3135 OP * const oldop = PL_op;
3139 assert(CATCH_GET == TRUE);
3146 assert(cxstack_ix >= 0);
3147 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3148 CX_CUR()->blk_eval.cur_top_env = PL_top_env;
3153 /* die caught by an inner eval - continue inner loop */
3154 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3155 PL_restartjmpenv = NULL;
3156 PL_op = PL_restartop;
3165 NOT_REACHED; /* NOTREACHED */
3174 =for apidoc find_runcv
3176 Locate the CV corresponding to the currently executing sub or eval.
3177 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3178 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3179 entered. (This allows debuggers to eval in the scope of the breakpoint
3180 rather than in the scope of the debugger itself.)
3186 Perl_find_runcv(pTHX_ U32 *db_seqp)
3188 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3191 /* If this becomes part of the API, it might need a better name. */
3193 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3200 PL_curcop == &PL_compiling
3202 : PL_curcop->cop_seq;
3204 for (si = PL_curstackinfo; si; si = si->si_prev) {
3206 for (ix = si->si_cxix; ix >= 0; ix--) {
3207 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3209 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3210 cv = cx->blk_sub.cv;
3211 /* skip DB:: code */
3212 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3213 *db_seqp = cx->blk_oldcop->cop_seq;
3216 if (cx->cx_type & CXp_SUB_RE)
3219 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3220 cv = cx->blk_eval.cv;
3223 case FIND_RUNCV_padid_eq:
3225 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3228 case FIND_RUNCV_level_eq:
3229 if (level++ != arg) continue;
3237 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3241 /* Run yyparse() in a setjmp wrapper. Returns:
3242 * 0: yyparse() successful
3243 * 1: yyparse() failed
3247 S_try_yyparse(pTHX_ int gramtype)
3252 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3256 ret = yyparse(gramtype) ? 1 : 0;
3263 NOT_REACHED; /* NOTREACHED */
3270 /* Compile a require/do or an eval ''.
3272 * outside is the lexically enclosing CV (if any) that invoked us.
3273 * seq is the current COP scope value.
3274 * hh is the saved hints hash, if any.
3276 * Returns a bool indicating whether the compile was successful; if so,
3277 * PL_eval_start contains the first op of the compiled code; otherwise,
3280 * This function is called from two places: pp_require and pp_entereval.
3281 * These can be distinguished by whether PL_op is entereval.
3285 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3288 OP * const saveop = PL_op;
3289 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3290 COP * const oldcurcop = PL_curcop;
3291 bool in_require = (saveop->op_type == OP_REQUIRE);
3295 PL_in_eval = (in_require
3296 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3298 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3299 ? EVAL_RE_REPARSING : 0)));
3303 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3305 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3306 CX_CUR()->blk_eval.cv = evalcv;
3307 CX_CUR()->blk_gimme = gimme;
3309 CvOUTSIDE_SEQ(evalcv) = seq;
3310 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3312 /* set up a scratch pad */
3314 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3315 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3318 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3320 /* make sure we compile in the right package */
3322 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3323 SAVEGENERICSV(PL_curstash);
3324 PL_curstash = (HV *)CopSTASH(PL_curcop);
3325 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3326 else SvREFCNT_inc_simple_void(PL_curstash);
3328 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3329 SAVESPTR(PL_beginav);
3330 PL_beginav = newAV();
3331 SAVEFREESV(PL_beginav);
3332 SAVESPTR(PL_unitcheckav);
3333 PL_unitcheckav = newAV();
3334 SAVEFREESV(PL_unitcheckav);
3337 ENTER_with_name("evalcomp");
3338 SAVESPTR(PL_compcv);
3341 /* try to compile it */
3343 PL_eval_root = NULL;
3344 PL_curcop = &PL_compiling;
3345 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3346 PL_in_eval |= EVAL_KEEPERR;
3353 hv_clear(GvHV(PL_hintgv));
3356 PL_hints = saveop->op_private & OPpEVAL_COPHH
3357 ? oldcurcop->cop_hints : saveop->op_targ;
3359 /* making 'use re eval' not be in scope when compiling the
3360 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3361 * infinite recursion when S_has_runtime_code() gives a false
3362 * positive: the second time round, HINT_RE_EVAL isn't set so we
3363 * don't bother calling S_has_runtime_code() */
3364 if (PL_in_eval & EVAL_RE_REPARSING)
3365 PL_hints &= ~HINT_RE_EVAL;
3368 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3369 SvREFCNT_dec(GvHV(PL_hintgv));
3370 GvHV(PL_hintgv) = hh;
3373 SAVECOMPILEWARNINGS();
3375 if (PL_dowarn & G_WARN_ALL_ON)
3376 PL_compiling.cop_warnings = pWARN_ALL ;
3377 else if (PL_dowarn & G_WARN_ALL_OFF)
3378 PL_compiling.cop_warnings = pWARN_NONE ;
3380 PL_compiling.cop_warnings = pWARN_STD ;
3383 PL_compiling.cop_warnings =
3384 DUP_WARNINGS(oldcurcop->cop_warnings);
3385 cophh_free(CopHINTHASH_get(&PL_compiling));
3386 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3387 /* The label, if present, is the first entry on the chain. So rather
3388 than writing a blank label in front of it (which involves an
3389 allocation), just use the next entry in the chain. */
3390 PL_compiling.cop_hints_hash
3391 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3392 /* Check the assumption that this removed the label. */
3393 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3396 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3399 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3401 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3402 * so honour CATCH_GET and trap it here if necessary */
3405 /* compile the code */
3406 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3408 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3413 /* note that if yystatus == 3, then the require/eval died during
3414 * compilation, so the EVAL CX block has already been popped, and
3415 * various vars restored */
3416 if (yystatus != 3) {
3418 op_free(PL_eval_root);
3419 PL_eval_root = NULL;
3421 SP = PL_stack_base + POPMARK; /* pop original mark */
3423 assert(CxTYPE(cx) == CXt_EVAL);
3424 /* pop the CXt_EVAL, and if was a require, croak */
3425 S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
3428 /* die_unwind() re-croaks when in require, having popped the
3429 * require EVAL context. So we should never catch a require
3431 assert(!in_require);
3434 if (!*(SvPV_nolen_const(errsv)))
3435 sv_setpvs(errsv, "Compilation error");
3437 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3442 /* Compilation successful. Now clean up */
3444 LEAVE_with_name("evalcomp");
3446 CopLINE_set(&PL_compiling, 0);
3447 SAVEFREEOP(PL_eval_root);
3448 cv_forget_slab(evalcv);
3450 DEBUG_x(dump_eval());
3452 /* Register with debugger: */
3453 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3454 CV * const cv = get_cvs("DB::postponed", 0);
3458 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3460 call_sv(MUTABLE_SV(cv), G_DISCARD);
3464 if (PL_unitcheckav) {
3465 OP *es = PL_eval_start;
3466 call_list(PL_scopestack_ix, PL_unitcheckav);
3470 CvDEPTH(evalcv) = 1;
3471 SP = PL_stack_base + POPMARK; /* pop original mark */
3472 PL_op = saveop; /* The caller may need it. */
3473 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3481 S_check_type_and_open(pTHX_ SV *name)
3486 const char *p = SvPV_const(name, len);
3489 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3491 /* checking here captures a reasonable error message when
3492 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3493 * user gets a confusing message about looking for the .pmc file
3494 * rather than for the .pm file so do the check in S_doopen_pm when
3495 * PMC is on instead of here. S_doopen_pm calls this func.
3496 * This check prevents a \0 in @INC causing problems.
3498 #ifdef PERL_DISABLE_PMC
3499 if (!IS_SAFE_PATHNAME(p, len, "require"))
3503 /* on Win32 stat is expensive (it does an open() and close() twice and
3504 a couple other IO calls), the open will fail with a dir on its own with
3505 errno EACCES, so only do a stat to separate a dir from a real EACCES
3506 caused by user perms */
3508 /* we use the value of errno later to see how stat() or open() failed.
3509 * We don't want it set if the stat succeeded but we still failed,
3510 * such as if the name exists, but is a directory */
3513 st_rc = PerlLIO_stat(p, &st);
3515 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3520 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3522 /* EACCES stops the INC search early in pp_require to implement
3523 feature RT #113422 */
3524 if(!retio && errno == EACCES) { /* exists but probably a directory */
3526 st_rc = PerlLIO_stat(p, &st);
3528 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3539 #ifndef PERL_DISABLE_PMC
3541 S_doopen_pm(pTHX_ SV *name)
3544 const char *p = SvPV_const(name, namelen);
3546 PERL_ARGS_ASSERT_DOOPEN_PM;
3548 /* check the name before trying for the .pmc name to avoid the
3549 * warning referring to the .pmc which the user probably doesn't
3550 * know or care about
3552 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3555 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3556 SV *const pmcsv = sv_newmortal();
3559 SvSetSV_nosteal(pmcsv,name);
3560 sv_catpvs(pmcsv, "c");
3562 pmcio = check_type_and_open(pmcsv);
3566 return check_type_and_open(name);
3569 # define doopen_pm(name) check_type_and_open(name)
3570 #endif /* !PERL_DISABLE_PMC */
3572 /* require doesn't search for absolute names, or when the name is
3573 explicitly relative the current directory */
3574 PERL_STATIC_INLINE bool
3575 S_path_is_searchable(const char *name)
3577 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3579 if (PERL_FILE_IS_ABSOLUTE(name)
3581 || (*name == '.' && ((name[1] == '/' ||
3582 (name[1] == '.' && name[2] == '/'))
3583 || (name[1] == '\\' ||
3584 ( name[1] == '.' && name[2] == '\\')))
3587 || (*name == '.' && (name[1] == '/' ||
3588 (name[1] == '.' && name[2] == '/')))
3599 /* implement 'require 5.010001' */
3602 S_require_version(pTHX_ SV *sv)
3606 sv = sv_2mortal(new_version(sv));
3607 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3608 upg_version(PL_patchlevel, TRUE);
3609 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3610 if ( vcmp(sv,PL_patchlevel) <= 0 )
3611 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3612 SVfARG(sv_2mortal(vnormal(sv))),
3613 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3617 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3620 SV * const req = SvRV(sv);
3621 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3623 /* get the left hand term */
3624 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3626 first = SvIV(*av_fetch(lav,0,0));
3627 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3628 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3629 || av_tindex(lav) > 1 /* FP with > 3 digits */
3630 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3632 DIE(aTHX_ "Perl %"SVf" required--this is only "
3634 SVfARG(sv_2mortal(vnormal(req))),
3635 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3638 else { /* probably 'use 5.10' or 'use 5.8' */
3642 if (av_tindex(lav)>=1)
3643 second = SvIV(*av_fetch(lav,1,0));
3645 second /= second >= 600 ? 100 : 10;
3646 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3647 (int)first, (int)second);
3648 upg_version(hintsv, TRUE);
3650 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3651 "--this is only %"SVf", stopped",
3652 SVfARG(sv_2mortal(vnormal(req))),
3653 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3654 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3663 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
3664 * The first form will have already been converted at compile time to
3665 * the second form */
3668 S_require_file(pTHX_ SV *const sv)
3678 int vms_unixname = 0;
3681 const char *tryname = NULL;
3683 const U8 gimme = GIMME_V;
3684 int filter_has_file = 0;
3685 PerlIO *tryrsfp = NULL;
3686 SV *filter_cache = NULL;
3687 SV *filter_state = NULL;
3688 SV *filter_sub = NULL;
3692 bool path_searchable;
3693 I32 old_savestack_ix;
3696 DIE(aTHX_ "Missing or undefined argument to require");
3697 name = SvPV_nomg_const(sv, len);
3698 if (!(name && len > 0 && *name))
3699 DIE(aTHX_ "Missing or undefined argument to require");
3701 if (!IS_SAFE_PATHNAME(name, len, "require")) {
3702 DIE(aTHX_ "Can't locate %s: %s",
3703 pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
3704 NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3707 TAINT_PROPER("require");
3709 path_searchable = path_is_searchable(name);
3712 /* The key in the %ENV hash is in the syntax of file passed as the argument
3713 * usually this is in UNIX format, but sometimes in VMS format, which
3714 * can result in a module being pulled in more than once.
3715 * To prevent this, the key must be stored in UNIX format if the VMS
3716 * name can be translated to UNIX.
3720 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3722 unixlen = strlen(unixname);
3728 /* if not VMS or VMS name can not be translated to UNIX, pass it
3731 unixname = (char *) name;
3734 if (PL_op->op_type == OP_REQUIRE) {
3735 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3736 unixname, unixlen, 0);
3738 if (*svp != &PL_sv_undef)
3741 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3742 "Compilation failed in require", unixname);
3745 if (PL_op->op_flags & OPf_KIDS) {
3746 SVOP * const kid = (SVOP*)cUNOP->op_first;
3748 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3749 /* require foo (or use foo) with a bareword.
3750 Perl_load_module fakes up the identical optree, but its
3751 arguments aren't restricted by the parser to real barewords.
3753 const STRLEN package_len = len - 3;
3754 const char slashdot[2] = {'/', '.'};
3756 const char backslashdot[2] = {'\\', '.'};
3759 /* Disallow *purported* barewords that map to absolute
3760 filenames, filenames relative to the current or parent
3761 directory, or (*nix) hidden filenames. Also sanity check
3762 that the generated filename ends .pm */
3763 if (!path_searchable || len < 3 || name[0] == '.'
3764 || !memEQ(name + package_len, ".pm", 3))
3765 DIE(aTHX_ "Bareword in require maps to disallowed filename \"%"SVf"\"", sv);
3766 if (memchr(name, 0, package_len)) {
3767 /* diag_listed_as: Bareword in require contains "%s" */
3768 DIE(aTHX_ "Bareword in require contains \"\\0\"");
3770 if (ninstr(name, name + package_len, slashdot,
3771 slashdot + sizeof(slashdot))) {
3772 /* diag_listed_as: Bareword in require contains "%s" */
3773 DIE(aTHX_ "Bareword in require contains \"/.\"");
3776 if (ninstr(name, name + package_len, backslashdot,
3777 backslashdot + sizeof(backslashdot))) {
3778 /* diag_listed_as: Bareword in require contains "%s" */
3779 DIE(aTHX_ "Bareword in require contains \"\\.\"");
3786 PERL_DTRACE_PROBE_FILE_LOADING(unixname);
3788 /* prepare to compile file */
3790 if (!path_searchable) {
3791 /* At this point, name is SvPVX(sv) */
3793 tryrsfp = doopen_pm(sv);
3795 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3796 AV * const ar = GvAVn(PL_incgv);
3803 namesv = newSV_type(SVt_PV);
3804 for (i = 0; i <= AvFILL(ar); i++) {
3805 SV * const dirsv = *av_fetch(ar, i, TRUE);
3813 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3814 && !SvOBJECT(SvRV(loader)))
3816 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3820 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3821 PTR2UV(SvRV(dirsv)), name);
3822 tryname = SvPVX_const(namesv);
3825 if (SvPADTMP(nsv)) {
3826 nsv = sv_newmortal();
3827 SvSetSV_nosteal(nsv,sv);
3830 ENTER_with_name("call_INC");
3838 if (SvGMAGICAL(loader)) {
3839 SV *l = sv_newmortal();
3840 sv_setsv_nomg(l, loader);
3843 if (sv_isobject(loader))
3844 count = call_method("INC", G_ARRAY);
3846 count = call_sv(loader, G_ARRAY);
3856 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3857 && !isGV_with_GP(SvRV(arg))) {
3858 filter_cache = SvRV(arg);
3865 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3869 if (isGV_with_GP(arg)) {
3870 IO * const io = GvIO((const GV *)arg);
3875 tryrsfp = IoIFP(io);
3876 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3877 PerlIO_close(IoOFP(io));
3888 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3890 SvREFCNT_inc_simple_void_NN(filter_sub);
3893 filter_state = SP[i];
3894 SvREFCNT_inc_simple_void(filter_state);
3898 if (!tryrsfp && (filter_cache || filter_sub)) {
3899 tryrsfp = PerlIO_open(BIT_BUCKET,
3905 /* FREETMPS may free our filter_cache */
3906 SvREFCNT_inc_simple_void(filter_cache);
3910 LEAVE_with_name("call_INC");
3912 /* Now re-mortalize it. */
3913 sv_2mortal(filter_cache);
3915 /* Adjust file name if the hook has set an %INC entry.
3916 This needs to happen after the FREETMPS above. */
3917 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3919 tryname = SvPV_nolen_const(*svp);
3926 filter_has_file = 0;
3927 filter_cache = NULL;
3929 SvREFCNT_dec_NN(filter_state);
3930 filter_state = NULL;
3933 SvREFCNT_dec_NN(filter_sub);
3938 if (path_searchable) {
3943 dir = SvPV_nomg_const(dirsv, dirlen);
3949 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3953 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3956 sv_setpv(namesv, unixdir);
3957 sv_catpv(namesv, unixname);
3959 # ifdef __SYMBIAN32__
3960 if (PL_origfilename[0] &&
3961 PL_origfilename[1] == ':' &&
3962 !(dir[0] && dir[1] == ':'))
3963 Perl_sv_setpvf(aTHX_ namesv,
3968 Perl_sv_setpvf(aTHX_ namesv,
3972 /* The equivalent of
3973 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3974 but without the need to parse the format string, or
3975 call strlen on either pointer, and with the correct
3976 allocation up front. */
3978 char *tmp = SvGROW(namesv, dirlen + len + 2);
3980 memcpy(tmp, dir, dirlen);
3983 /* Avoid '<dir>//<file>' */
3984 if (!dirlen || *(tmp-1) != '/') {
3987 /* So SvCUR_set reports the correct length below */
3991 /* name came from an SV, so it will have a '\0' at the
3992 end that we can copy as part of this memcpy(). */
3993 memcpy(tmp, name, len + 1);
3995 SvCUR_set(namesv, dirlen + len + 1);
4000 TAINT_PROPER("require");
4001 tryname = SvPVX_const(namesv);
4002 tryrsfp = doopen_pm(namesv);
4004 if (tryname[0] == '.' && tryname[1] == '/') {
4006 while (*++tryname == '/') {}
4010 else if (errno == EMFILE || errno == EACCES) {
4011 /* no point in trying other paths if out of handles;
4012 * on the other hand, if we couldn't open one of the
4013 * files, then going on with the search could lead to
4014 * unexpected results; see perl #113422
4023 saved_errno = errno; /* sv_2mortal can realloc things */
4026 if (PL_op->op_type == OP_REQUIRE) {
4027 if(saved_errno == EMFILE || saved_errno == EACCES) {
4028 /* diag_listed_as: Can't locate %s */
4029 DIE(aTHX_ "Can't locate %s: %s: %s",
4030 name, tryname, Strerror(saved_errno));
4032 if (namesv) { /* did we lookup @INC? */
4033 AV * const ar = GvAVn(PL_incgv);
4035 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4036 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4037 for (i = 0; i <= AvFILL(ar); i++) {
4038 sv_catpvs(inc, " ");
4039 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4041 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4042 const char *c, *e = name + len - 3;
4043 sv_catpv(msg, " (you may need to install the ");
4044 for (c = name; c < e; c++) {
4046 sv_catpvs(msg, "::");
4049 sv_catpvn(msg, c, 1);
4052 sv_catpv(msg, " module)");
4054 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4055 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4057 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4058 sv_catpv(msg, " (did you run h2ph?)");
4061 /* diag_listed_as: Can't locate %s */
4063 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4067 DIE(aTHX_ "Can't locate %s", name);
4074 SETERRNO(0, SS_NORMAL);
4076 /* Assume success here to prevent recursive requirement. */
4077 /* name is never assigned to again, so len is still strlen(name) */
4078 /* Check whether a hook in @INC has already filled %INC */
4080 (void)hv_store(GvHVn(PL_incgv),
4081 unixname, unixlen, newSVpv(tryname,0),0);
4083 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4085 (void)hv_store(GvHVn(PL_incgv),
4086 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4089 old_savestack_ix = PL_savestack_ix;
4090 SAVECOPFILE_FREE(&PL_compiling);
4091 CopFILE_set(&PL_compiling, tryname);
4092 lex_start(NULL, tryrsfp, 0);
4094 if (filter_sub || filter_cache) {
4095 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4096 than hanging another SV from it. In turn, filter_add() optionally
4097 takes the SV to use as the filter (or creates a new SV if passed
4098 NULL), so simply pass in whatever value filter_cache has. */
4099 SV * const fc = filter_cache ? newSV(0) : NULL;
4101 if (fc) sv_copypv(fc, filter_cache);
4102 datasv = filter_add(S_run_user_filter, fc);
4103 IoLINES(datasv) = filter_has_file;
4104 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4105 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4108 /* switch to eval mode */
4109 cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4110 cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4112 SAVECOPLINE(&PL_compiling);
4113 CopLINE_set(&PL_compiling, 0);
4117 if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4118 op = DOCATCH(PL_eval_start);
4120 op = PL_op->op_next;
4122 PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4128 /* also used for: pp_dofile() */
4136 return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4137 ? S_require_version(aTHX_ sv)
4138 : S_require_file(aTHX_ sv);
4142 /* This is a op added to hold the hints hash for
4143 pp_entereval. The hash can be modified by the code
4144 being eval'ed, so we return a copy instead. */
4149 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4159 const U8 gimme = GIMME_V;
4160 const U32 was = PL_breakable_sub_gen;
4161 char tbuf[TYPE_DIGITS(long) + 12];
4162 bool saved_delete = FALSE;
4163 char *tmpbuf = tbuf;
4166 U32 seq, lex_flags = 0;
4167 HV *saved_hh = NULL;
4168 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4169 I32 old_savestack_ix;
4171 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4172 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4174 else if (PL_hints & HINT_LOCALIZE_HH || (
4175 PL_op->op_private & OPpEVAL_COPHH
4176 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4178 saved_hh = cop_hints_2hv(PL_curcop, 0);
4179 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4183 /* make sure we've got a plain PV (no overload etc) before testing
4184 * for taint. Making a copy here is probably overkill, but better
4185 * safe than sorry */
4187 const char * const p = SvPV_const(sv, len);
4189 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4190 lex_flags |= LEX_START_COPIED;
4192 if (bytes && SvUTF8(sv))
4193 SvPVbyte_force(sv, len);
4195 else if (bytes && SvUTF8(sv)) {
4196 /* Don't modify someone else's scalar */
4199 (void)sv_2mortal(sv);
4200 SvPVbyte_force(sv,len);
4201 lex_flags |= LEX_START_COPIED;
4204 TAINT_IF(SvTAINTED(sv));
4205 TAINT_PROPER("eval");
4207 old_savestack_ix = PL_savestack_ix;
4209 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4210 ? LEX_IGNORE_UTF8_HINTS
4211 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4215 /* switch to eval mode */
4217 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4218 SV * const temp_sv = sv_newmortal();
4219 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4220 (unsigned long)++PL_evalseq,
4221 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4222 tmpbuf = SvPVX(temp_sv);
4223 len = SvCUR(temp_sv);
4226 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4227 SAVECOPFILE_FREE(&PL_compiling);
4228 CopFILE_set(&PL_compiling, tmpbuf+2);
4229 SAVECOPLINE(&PL_compiling);
4230 CopLINE_set(&PL_compiling, 1);
4231 /* special case: an eval '' executed within the DB package gets lexically
4232 * placed in the first non-DB CV rather than the current CV - this
4233 * allows the debugger to execute code, find lexicals etc, in the
4234 * scope of the code being debugged. Passing &seq gets find_runcv
4235 * to do the dirty work for us */
4236 runcv = find_runcv(&seq);
4238 cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
4239 cx_pusheval(cx, PL_op->op_next, NULL);
4241 /* prepare to compile string */
4243 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4244 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4246 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4247 deleting the eval's FILEGV from the stash before gv_check() runs
4248 (i.e. before run-time proper). To work around the coredump that
4249 ensues, we always turn GvMULTI_on for any globals that were
4250 introduced within evals. See force_ident(). GSAR 96-10-12 */
4251 char *const safestr = savepvn(tmpbuf, len);
4252 SAVEDELETE(PL_defstash, safestr, len);
4253 saved_delete = TRUE;
4258 if (doeval_compile(gimme, runcv, seq, saved_hh)) {
4259 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4260 ? PERLDB_LINE_OR_SAVESRC
4261 : PERLDB_SAVESRC_NOSUBS) {
4262 /* Retain the filegv we created. */
4263 } else if (!saved_delete) {
4264 char *const safestr = savepvn(tmpbuf, len);
4265 SAVEDELETE(PL_defstash, safestr, len);
4267 return DOCATCH(PL_eval_start);
4269 /* We have already left the scope set up earlier thanks to the LEAVE
4270 in doeval_compile(). */
4271 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4272 ? PERLDB_LINE_OR_SAVESRC
4273 : PERLDB_SAVESRC_INVALID) {
4274 /* Retain the filegv we created. */
4275 } else if (!saved_delete) {
4276 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4278 return PL_op->op_next;
4283 /* also tail-called by pp_return */
4298 assert(CxTYPE(cx) == CXt_EVAL);
4300 oldsp = PL_stack_base + cx->blk_oldsp;
4301 gimme = cx->blk_gimme;
4303 /* did require return a false value? */
4304 failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE
4305 && !(gimme == G_SCALAR
4306 ? SvTRUE(*PL_stack_sp)
4307 : PL_stack_sp > oldsp);
4309 if (gimme == G_VOID)
4310 PL_stack_sp = oldsp;
4312 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4314 /* the cx_popeval does a leavescope, which frees the optree associated
4315 * with eval, which if it frees the nextstate associated with
4316 * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
4317 * regex when running under 'use re Debug' because it needs PL_curcop
4318 * to get the current hints. So restore it early.
4320 PL_curcop = cx->blk_oldcop;
4322 /* grab this value before cx_popeval restores the old PL_in_eval */
4323 keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4324 retop = cx->blk_eval.retop;
4325 evalcv = cx->blk_eval.cv;
4327 assert(CvDEPTH(evalcv) == 1);
4329 CvDEPTH(evalcv) = 0;
4331 /* pop the CXt_EVAL, and if a require failed, croak */
4332 S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
4340 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4341 close to the related Perl_create_eval_scope. */
4343 Perl_delete_eval_scope(pTHX)
4354 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4355 also needed by Perl_fold_constants. */
4357 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
4360 const U8 gimme = GIMME_V;
4362 cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
4363 PL_stack_sp, PL_savestack_ix);
4364 cx_pusheval(cx, retop, NULL);
4366 PL_in_eval = EVAL_INEVAL;
4367 if (flags & G_KEEPERR)
4368 PL_in_eval |= EVAL_KEEPERR;
4371 if (flags & G_FAKINGEVAL) {
4372 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4378 create_eval_scope(cLOGOP->op_other->op_next, 0);
4379 return DOCATCH(PL_op->op_next);
4383 /* also tail-called by pp_return */
4395 assert(CxTYPE(cx) == CXt_EVAL);
4396 oldsp = PL_stack_base + cx->blk_oldsp;
4397 gimme = cx->blk_gimme;
4399 if (gimme == G_VOID)
4400 PL_stack_sp = oldsp;
4402 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4406 retop = cx->blk_eval.retop;
4417 const U8 gimme = GIMME_V;
4421 assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4422 GvSV(PL_defgv) = SvREFCNT_inc(newsv);
4424 cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
4425 cx_pushgiven(cx, origsv);
4435 PERL_UNUSED_CONTEXT;
4438 assert(CxTYPE(cx) == CXt_GIVEN);
4439 oldsp = PL_stack_base + cx->blk_oldsp;
4440 gimme = cx->blk_gimme;
4442 if (gimme == G_VOID)
4443 PL_stack_sp = oldsp;
4445 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4455 /* Helper routines used by pp_smartmatch */
4457 S_make_matcher(pTHX_ REGEXP *re)
4459 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4461 PERL_ARGS_ASSERT_MAKE_MATCHER;
4463 PM_SETRE(matcher, ReREFCNT_inc(re));
4465 SAVEFREEOP((OP *) matcher);
4466 ENTER_with_name("matcher"); SAVETMPS;
4472 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4477 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4479 PL_op = (OP *) matcher;
4482 (void) Perl_pp_match(aTHX);
4484 result = SvTRUEx(POPs);
4491 S_destroy_matcher(pTHX_ PMOP *matcher)
4493 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4494 PERL_UNUSED_ARG(matcher);
4497 LEAVE_with_name("matcher");
4500 /* Do a smart match */
4503 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4504 return do_smartmatch(NULL, NULL, 0);
4507 /* This version of do_smartmatch() implements the
4508 * table of smart matches that is found in perlsyn.
4511 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4515 bool object_on_left = FALSE;
4516 SV *e = TOPs; /* e is for 'expression' */
4517 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4519 /* Take care only to invoke mg_get() once for each argument.
4520 * Currently we do this by copying the SV if it's magical. */
4522 if (!copied && SvGMAGICAL(d))
4523 d = sv_mortalcopy(d);
4530 e = sv_mortalcopy(e);
4532 /* First of all, handle overload magic of the rightmost argument */
4535 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4536 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4538 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4545 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4548 SP -= 2; /* Pop the values */
4553 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4560 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4561 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4562 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4564 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4565 object_on_left = TRUE;
4568 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4570 if (object_on_left) {
4571 goto sm_any_sub; /* Treat objects like scalars */
4573 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4574 /* Test sub truth for each key */
4576 bool andedresults = TRUE;
4577 HV *hv = (HV*) SvRV(d);
4578 I32 numkeys = hv_iterinit(hv);
4579 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4582 while ( (he = hv_iternext(hv)) ) {
4583 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4584 ENTER_with_name("smartmatch_hash_key_test");
4587 PUSHs(hv_iterkeysv(he));
4589 c = call_sv(e, G_SCALAR);
4592 andedresults = FALSE;
4594 andedresults = SvTRUEx(POPs) && andedresults;
4596 LEAVE_with_name("smartmatch_hash_key_test");
4603 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4604 /* Test sub truth for each element */
4606 bool andedresults = TRUE;
4607 AV *av = (AV*) SvRV(d);
4608 const I32 len = av_tindex(av);
4609 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4612 for (i = 0; i <= len; ++i) {
4613 SV * const * const svp = av_fetch(av, i, FALSE);
4614 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4615 ENTER_with_name("smartmatch_array_elem_test");
4621 c = call_sv(e, G_SCALAR);
4624 andedresults = FALSE;
4626 andedresults = SvTRUEx(POPs) && andedresults;
4628 LEAVE_with_name("smartmatch_array_elem_test");
4637 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4638 ENTER_with_name("smartmatch_coderef");
4643 c = call_sv(e, G_SCALAR);
4647 else if (SvTEMP(TOPs))
4648 SvREFCNT_inc_void(TOPs);
4650 LEAVE_with_name("smartmatch_coderef");
4655 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4656 if (object_on_left) {
4657 goto sm_any_hash; /* Treat objects like scalars */
4659 else if (!SvOK(d)) {
4660 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4663 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4664 /* Check that the key-sets are identical */
4666 HV *other_hv = MUTABLE_HV(SvRV(d));
4669 U32 this_key_count = 0,
4670 other_key_count = 0;
4671 HV *hv = MUTABLE_HV(SvRV(e));
4673 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4674 /* Tied hashes don't know how many keys they have. */
4675 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4676 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4680 HV * const temp = other_hv;
4686 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4690 /* The hashes have the same number of keys, so it suffices
4691 to check that one is a subset of the other. */
4692 (void) hv_iterinit(hv);
4693 while ( (he = hv_iternext(hv)) ) {
4694 SV *key = hv_iterkeysv(he);
4696 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4699 if(!hv_exists_ent(other_hv, key, 0)) {
4700 (void) hv_iterinit(hv); /* reset iterator */
4706 (void) hv_iterinit(other_hv);
4707 while ( hv_iternext(other_hv) )
4711 other_key_count = HvUSEDKEYS(other_hv);
4713 if (this_key_count != other_key_count)
4718 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4719 AV * const other_av = MUTABLE_AV(SvRV(d));
4720 const SSize_t other_len = av_tindex(other_av) + 1;
4722 HV *hv = MUTABLE_HV(SvRV(e));
4724 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4725 for (i = 0; i < other_len; ++i) {
4726 SV ** const svp = av_fetch(other_av, i, FALSE);
4727 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4728 if (svp) { /* ??? When can this not happen? */
4729 if (hv_exists_ent(hv, *svp, 0))
4735 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4736 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4739 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4741 HV *hv = MUTABLE_HV(SvRV(e));
4743 (void) hv_iterinit(hv);
4744 while ( (he = hv_iternext(hv)) ) {
4745 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4747 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4749 (void) hv_iterinit(hv);
4750 destroy_matcher(matcher);
4755 destroy_matcher(matcher);
4761 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4762 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4769 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4770 if (object_on_left) {
4771 goto sm_any_array; /* Treat objects like scalars */
4773 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4774 AV * const other_av = MUTABLE_AV(SvRV(e));
4775 const SSize_t other_len = av_tindex(other_av) + 1;
4778 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4779 for (i = 0; i < other_len; ++i) {
4780 SV ** const svp = av_fetch(other_av, i, FALSE);
4782 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4783 if (svp) { /* ??? When can this not happen? */
4784 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4790 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4791 AV *other_av = MUTABLE_AV(SvRV(d));
4792 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4793 if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4797 const SSize_t other_len = av_tindex(other_av);
4799 if (NULL == seen_this) {
4800 seen_this = newHV();
4801 (void) sv_2mortal(MUTABLE_SV(seen_this));
4803 if (NULL == seen_other) {
4804 seen_other = newHV();
4805 (void) sv_2mortal(MUTABLE_SV(seen_other));
4807 for(i = 0; i <= other_len; ++i) {
4808 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4809 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4811 if (!this_elem || !other_elem) {
4812 if ((this_elem && SvOK(*this_elem))
4813 || (other_elem && SvOK(*other_elem)))
4816 else if (hv_exists_ent(seen_this,
4817 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4818 hv_exists_ent(seen_other,
4819 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4821 if (*this_elem != *other_elem)
4825 (void)hv_store_ent(seen_this,
4826 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4828 (void)hv_store_ent(seen_other,
4829 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4835 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4836 (void) do_smartmatch(seen_this, seen_other, 0);
4838 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4847 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4848 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4851 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4852 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4855 for(i = 0; i <= this_len; ++i) {
4856 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4857 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4859 if (svp && matcher_matches_sv(matcher, *svp)) {
4861 destroy_matcher(matcher);
4866 destroy_matcher(matcher);
4870 else if (!SvOK(d)) {
4871 /* undef ~~ array */
4872 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4875 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4876 for (i = 0; i <= this_len; ++i) {
4877 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4878 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4879 if (!svp || !SvOK(*svp))
4888 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4890 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4891 for (i = 0; i <= this_len; ++i) {
4892 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4899 /* infinite recursion isn't supposed to happen here */
4900 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4901 (void) do_smartmatch(NULL, NULL, 1);
4903 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4912 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4913 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4914 SV *t = d; d = e; e = t;
4915 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4918 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4919 SV *t = d; d = e; e = t;
4920 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4921 goto sm_regex_array;
4924 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4927 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4929 result = matcher_matches_sv(matcher, d);
4931 PUSHs(result ? &PL_sv_yes : &PL_sv_no);
4932 destroy_matcher(matcher);
4937 /* See if there is overload magic on left */
4938 else if (object_on_left && SvAMAGIC(d)) {
4940 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4941 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4944 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4952 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4955 else if (!SvOK(d)) {
4956 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4957 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4962 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4963 DEBUG_M(if (SvNIOK(e))
4964 Perl_deb(aTHX_ " applying rule Any-Num\n");
4966 Perl_deb(aTHX_ " applying rule Num-numish\n");
4968 /* numeric comparison */
4971 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4972 (void) Perl_pp_i_eq(aTHX);
4974 (void) Perl_pp_eq(aTHX);
4982 /* As a last resort, use string comparison */
4983 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4986 return Perl_pp_seq(aTHX);
4993 const U8 gimme = GIMME_V;
4995 /* This is essentially an optimization: if the match
4996 fails, we don't want to push a context and then
4997 pop it again right away, so we skip straight
4998 to the op that follows the leavewhen.
4999 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5001 if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs))
5002 RETURNOP(cLOGOP->op_other->op_next);
5004 cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
5018 assert(CxTYPE(cx) == CXt_WHEN);
5019 gimme = cx->blk_gimme;
5021 cxix = dopoptogivenfor(cxstack_ix);
5023 /* diag_listed_as: Can't "when" outside a topicalizer */
5024 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5025 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5027 oldsp = PL_stack_base + cx->blk_oldsp;
5028 if (gimme == G_VOID)
5029 PL_stack_sp = oldsp;
5031 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5033 /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
5034 assert(cxix < cxstack_ix);
5037 cx = &cxstack[cxix];
5039 if (CxFOREACH(cx)) {
5040 /* emulate pp_next. Note that any stack(s) cleanup will be
5041 * done by the pp_unstack which op_nextop should point to */
5044 PL_curcop = cx->blk_oldcop;
5045 return cx->blk_loop.my_op->op_nextop;
5049 assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
5050 return cx->blk_givwhen.leave_op;
5060 cxix = dopoptowhen(cxstack_ix);
5062 DIE(aTHX_ "Can't \"continue\" outside a when block");
5064 if (cxix < cxstack_ix)
5068 assert(CxTYPE(cx) == CXt_WHEN);
5069 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5073 nextop = cx->blk_givwhen.leave_op->op_next;
5084 cxix = dopoptogivenfor(cxstack_ix);
5086 DIE(aTHX_ "Can't \"break\" outside a given block");
5088 cx = &cxstack[cxix];
5090 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5092 if (cxix < cxstack_ix)
5095 /* Restore the sp at the time we entered the given block */
5097 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5099 return cx->blk_givwhen.leave_op;
5103 S_doparseform(pTHX_ SV *sv)
5106 char *s = SvPV(sv, len);
5108 char *base = NULL; /* start of current field */
5109 I32 skipspaces = 0; /* number of contiguous spaces seen */
5110 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5111 bool repeat = FALSE; /* ~~ seen on this line */
5112 bool postspace = FALSE; /* a text field may need right padding */
5115 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5117 bool ischop; /* it's a ^ rather than a @ */
5118 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5119 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5123 PERL_ARGS_ASSERT_DOPARSEFORM;
5126 Perl_croak(aTHX_ "Null picture in formline");
5128 if (SvTYPE(sv) >= SVt_PVMG) {
5129 /* This might, of course, still return NULL. */
5130 mg = mg_find(sv, PERL_MAGIC_fm);
5132 sv_upgrade(sv, SVt_PVMG);
5136 /* still the same as previously-compiled string? */
5137 SV *old = mg->mg_obj;
5138 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5139 && len == SvCUR(old)
5140 && strnEQ(SvPVX(old), SvPVX(sv), len)
5142 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5146 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5147 Safefree(mg->mg_ptr);
5153 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5154 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5157 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5158 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5162 /* estimate the buffer size needed */
5163 for (base = s; s <= send; s++) {
5164 if (*s == '\n' || *s == '@' || *s == '^')
5170 Newx(fops, maxops, U32);
5175 *fpc++ = FF_LINEMARK;
5176 noblank = repeat = FALSE;
5194 case ' ': case '\t':
5201 } /* else FALL THROUGH */
5209 *fpc++ = FF_LITERAL;
5217 *fpc++ = (U32)skipspaces;
5221 *fpc++ = FF_NEWLINE;
5225 arg = fpc - linepc + 1;
5232 *fpc++ = FF_LINEMARK;
5233 noblank = repeat = FALSE;
5242 ischop = s[-1] == '^';
5248 arg = (s - base) - 1;
5250 *fpc++ = FF_LITERAL;
5256 if (*s == '*') { /* @* or ^* */
5258 *fpc++ = 2; /* skip the @* or ^* */
5260 *fpc++ = FF_LINESNGL;
5263 *fpc++ = FF_LINEGLOB;
5265 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5266 arg = ischop ? FORM_NUM_BLANK : 0;
5271 const char * const f = ++s;
5274 arg |= FORM_NUM_POINT + (s - f);
5276 *fpc++ = s - base; /* fieldsize for FETCH */
5277 *fpc++ = FF_DECIMAL;
5279 unchopnum |= ! ischop;
5281 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5282 arg = ischop ? FORM_NUM_BLANK : 0;
5284 s++; /* skip the '0' first */
5288 const char * const f = ++s;
5291 arg |= FORM_NUM_POINT + (s - f);
5293 *fpc++ = s - base; /* fieldsize for FETCH */
5294 *fpc++ = FF_0DECIMAL;
5296 unchopnum |= ! ischop;
5298 else { /* text field */
5300 bool ismore = FALSE;
5303 while (*++s == '>') ;
5304 prespace = FF_SPACE;
5306 else if (*s == '|') {
5307 while (*++s == '|') ;
5308 prespace = FF_HALFSPACE;
5313 while (*++s == '<') ;
5316 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5320 *fpc++ = s - base; /* fieldsize for FETCH */
5322 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5325 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5339 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5342 mg->mg_ptr = (char *) fops;
5343 mg->mg_len = arg * sizeof(U32);
5344 mg->mg_obj = sv_copy;
5345 mg->mg_flags |= MGf_REFCOUNTED;
5347 if (unchopnum && repeat)
5348 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5355 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5357 /* Can value be printed in fldsize chars, using %*.*f ? */
5361 int intsize = fldsize - (value < 0 ? 1 : 0);
5363 if (frcsize & FORM_NUM_POINT)
5365 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5368 while (intsize--) pwr *= 10.0;
5369 while (frcsize--) eps /= 10.0;
5372 if (value + eps >= pwr)
5375 if (value - eps <= -pwr)
5382 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5384 SV * const datasv = FILTER_DATA(idx);
5385 const int filter_has_file = IoLINES(datasv);
5386 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5387 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5392 char *prune_from = NULL;
5393 bool read_from_cache = FALSE;
5397 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5399 assert(maxlen >= 0);
5402 /* I was having segfault trouble under Linux 2.2.5 after a
5403 parse error occurred. (Had to hack around it with a test
5404 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5405 not sure where the trouble is yet. XXX */
5408 SV *const cache = datasv;
5411 const char *cache_p = SvPV(cache, cache_len);
5415 /* Running in block mode and we have some cached data already.
5417 if (cache_len >= umaxlen) {
5418 /* In fact, so much data we don't even need to call
5423 const char *const first_nl =
5424 (const char *)memchr(cache_p, '\n', cache_len);
5426 take = first_nl + 1 - cache_p;
5430 sv_catpvn(buf_sv, cache_p, take);
5431 sv_chop(cache, cache_p + take);
5432 /* Definitely not EOF */
5436 sv_catsv(buf_sv, cache);
5438 umaxlen -= cache_len;
5441 read_from_cache = TRUE;
5445 /* Filter API says that the filter appends to the contents of the buffer.
5446 Usually the buffer is "", so the details don't matter. But if it's not,
5447 then clearly what it contains is already filtered by this filter, so we
5448 don't want to pass it in a second time.
5449 I'm going to use a mortal in case the upstream filter croaks. */
5450 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5451 ? sv_newmortal() : buf_sv;
5452 SvUPGRADE(upstream, SVt_PV);
5454 if (filter_has_file) {
5455 status = FILTER_READ(idx+1, upstream, 0);
5458 if (filter_sub && status >= 0) {
5462 ENTER_with_name("call_filter_sub");
5467 DEFSV_set(upstream);
5471 PUSHs(filter_state);
5474 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5484 SV * const errsv = ERRSV;
5485 if (SvTRUE_NN(errsv))
5486 err = newSVsv(errsv);
5492 LEAVE_with_name("call_filter_sub");
5495 if (SvGMAGICAL(upstream)) {
5497 if (upstream == buf_sv) mg_free(buf_sv);
5499 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5500 if(!err && SvOK(upstream)) {
5501 got_p = SvPV_nomg(upstream, got_len);
5503 if (got_len > umaxlen) {
5504 prune_from = got_p + umaxlen;
5507 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5508 if (first_nl && first_nl + 1 < got_p + got_len) {
5509 /* There's a second line here... */
5510 prune_from = first_nl + 1;
5514 if (!err && prune_from) {
5515 /* Oh. Too long. Stuff some in our cache. */
5516 STRLEN cached_len = got_p + got_len - prune_from;
5517 SV *const cache = datasv;
5520 /* Cache should be empty. */
5521 assert(!SvCUR(cache));
5524 sv_setpvn(cache, prune_from, cached_len);
5525 /* If you ask for block mode, you may well split UTF-8 characters.
5526 "If it breaks, you get to keep both parts"
5527 (Your code is broken if you don't put them back together again
5528 before something notices.) */
5529 if (SvUTF8(upstream)) {
5532 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5534 /* Cannot just use sv_setpvn, as that could free the buffer
5535 before we have a chance to assign it. */
5536 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5537 got_len - cached_len);
5539 /* Can't yet be EOF */
5544 /* If they are at EOF but buf_sv has something in it, then they may never
5545 have touched the SV upstream, so it may be undefined. If we naively
5546 concatenate it then we get a warning about use of uninitialised value.
5548 if (!err && upstream != buf_sv &&
5550 sv_catsv_nomg(buf_sv, upstream);
5552 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5555 IoLINES(datasv) = 0;
5557 SvREFCNT_dec(filter_state);
5558 IoTOP_GV(datasv) = NULL;
5561 SvREFCNT_dec(filter_sub);
5562 IoBOTTOM_GV(datasv) = NULL;
5564 filter_del(S_run_user_filter);
5570 if (status == 0 && read_from_cache) {
5571 /* If we read some data from the cache (and by getting here it implies
5572 that we emptied the cache) then we aren't yet at EOF, and mustn't
5573 report that to our caller. */
5580 * ex: set ts=8 sts=4 sw=4 et: