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
38 #define dopopto_cursub() \
39 (PL_curstackinfo->si_cxsubix >= 0 \
40 ? PL_curstackinfo->si_cxsubix \
41 : dopoptosub_at(cxstack, cxstack_ix))
43 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
48 const PERL_CONTEXT *cx;
51 if (PL_op->op_private & OPpOFFBYONE) {
52 if (!(cx = caller_cx(1,NULL))) {
58 cxix = dopopto_cursub();
66 switch (cx->blk_gimme) {
91 PMOP *pm = cPMOPx(cLOGOP->op_other);
96 const regexp_engine *eng;
97 bool is_bare_re= FALSE;
99 if (PL_op->op_flags & OPf_STACKED) {
101 nargs = PL_stack_sp - MARK;
109 /* prevent recompiling under /o and ithreads. */
110 #if defined(USE_ITHREADS)
111 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
116 assert (re != (REGEXP*) &PL_sv_undef);
117 eng = re ? RX_ENGINE(re) : current_re_engine();
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 /* handle the empty pattern */
175 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) {
176 if (PL_curpm == PL_reg_curpm) {
177 if (PL_curpm_under && PL_curpm_under == PL_reg_curpm) {
178 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
183 #if !defined(USE_ITHREADS)
184 /* can't change the optree at runtime either */
185 /* PMf_KEEP is handled differently under threads to avoid these problems */
186 if (pm->op_pmflags & PMf_KEEP) {
187 cLOGOP->op_first->op_next = PL_op->op_next;
191 #if defined(USE_ITHREADS)
194 rpp_popfree_to(args - 1);
199 /* how many stack arguments a substcont op expects */
202 S_substcont_argcount(pTHX)
204 PERL_CONTEXT *cx = CX_CUR();
205 /* the scalar result of the expression in s//expression/ is on the
206 * stack only on iterations 2+ */
207 return cx->sb_iters ? 1 : 0;
211 PP_wrapped(pp_substcont, S_substcont_argcount(aTHX), 0)
214 PERL_CONTEXT *cx = CX_CUR();
215 PMOP * const pm = cPMOPx(cLOGOP->op_other);
216 SV * const dstr = cx->sb_dstr;
219 char *orig = cx->sb_orig;
220 REGEXP * const rx = cx->sb_rx;
222 REGEXP *old = PM_GETRE(pm);
229 PM_SETRE(pm,ReREFCNT_inc(rx));
232 rxres_restore(&cx->sb_rxres, rx);
234 if (cx->sb_iters++) {
235 const SSize_t saviters = cx->sb_iters;
236 if (cx->sb_iters > cx->sb_maxiters)
237 DIE(aTHX_ "Substitution loop");
239 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
241 /* See "how taint works": pp_subst() in pp_hot.c */
242 sv_catsv_nomg(dstr, POPs);
243 if (UNLIKELY(TAINT_get))
244 cx->sb_rxtainted |= SUBST_TAINT_REPL;
245 if (CxONCE(cx) || s < orig ||
246 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
247 (s == m), cx->sb_targ, NULL,
248 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
250 SV *targ = cx->sb_targ;
252 assert(cx->sb_strend >= s);
253 if(cx->sb_strend > s) {
254 if (DO_UTF8(dstr) && !SvUTF8(targ))
255 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
257 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
259 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
260 cx->sb_rxtainted |= SUBST_TAINT_PAT;
262 if (pm->op_pmflags & PMf_NONDESTRUCT) {
264 /* From here on down we're using the copy, and leaving the
265 original untouched. */
269 SV_CHECK_THINKFIRST_COW_DROP(targ);
270 if (isGV(targ)) Perl_croak_no_modify();
272 SvPV_set(targ, SvPVX(dstr));
273 SvCUR_set(targ, SvCUR(dstr));
274 SvLEN_set(targ, SvLEN(dstr));
277 SvPV_set(dstr, NULL);
280 mPUSHi(saviters - 1);
282 (void)SvPOK_only_UTF8(targ);
285 /* update the taint state of various variables in
286 * preparation for final exit.
287 * See "how taint works": pp_subst() in pp_hot.c */
289 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
290 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
291 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
293 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
295 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
296 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
298 SvTAINTED_on(TOPs); /* taint return value */
299 /* needed for mg_set below */
301 cBOOL(cx->sb_rxtainted &
302 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
305 /* sv_magic(), when adding magic (e.g.taint magic), also
306 * recalculates any pos() magic, converting any byte offset
307 * to utf8 offset. Make sure pos() is reset before this
308 * happens rather than using the now invalid value (since
309 * we've just replaced targ's pvx buffer with the
310 * potentially shorter dstr buffer). Normally (i.e. in
311 * non-taint cases), pos() gets removed a few lines later
312 * with the SvSETMAGIC().
316 mg = mg_find_mglob(targ);
318 MgBYTEPOS_set(mg, targ, SvPVX(targ), -1);
324 /* PL_tainted must be correctly set for this mg_set */
333 RETURNOP(pm->op_next);
334 NOT_REACHED; /* NOTREACHED */
336 cx->sb_iters = saviters;
338 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
341 assert(!RX_SUBOFFSET(rx));
342 cx->sb_orig = orig = RX_SUBBEG(rx);
344 cx->sb_strend = s + (cx->sb_strend - m);
346 cx->sb_m = m = RX_OFFS_START(rx,0) + orig;
348 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
349 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
351 sv_catpvn_nomg(dstr, s, m-s);
353 cx->sb_s = RX_OFFS_END(rx,0) + orig;
354 { /* Update the pos() information. */
356 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
359 /* the string being matched against may no longer be a string,
360 * e.g. $_=0; s/.../$_++/ge */
363 SvPV_force_nomg_nolen(sv);
365 if (!(mg = mg_find_mglob(sv))) {
366 mg = sv_magicext_mglob(sv);
368 MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
371 (void)ReREFCNT_inc(rx);
372 /* update the taint state of various variables in preparation
373 * for calling the code block.
374 * See "how taint works": pp_subst() in pp_hot.c */
376 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
377 cx->sb_rxtainted |= SUBST_TAINT_PAT;
379 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
380 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
381 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
383 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
385 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
386 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
387 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
388 ? cx->sb_dstr : cx->sb_targ);
391 rxres_save(&cx->sb_rxres, rx);
393 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
398 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
403 PERL_ARGS_ASSERT_RXRES_SAVE;
406 /* deal with regexp_paren_pair items */
407 if (!p || p[1] < RX_NPARENS(rx)) {
409 i = 7 + (RX_NPARENS(rx)+1) * 2;
411 i = 6 + (RX_NPARENS(rx)+1) * 2;
420 /* what (if anything) to free on croak */
421 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
422 RX_MATCH_COPIED_off(rx);
423 *p++ = RX_NPARENS(rx);
426 *p++ = PTR2UV(RX_SAVED_COPY(rx));
427 RX_SAVED_COPY(rx) = NULL;
430 *p++ = PTR2UV(RX_SUBBEG(rx));
431 *p++ = (UV)RX_SUBLEN(rx);
432 *p++ = (UV)RX_SUBOFFSET(rx);
433 *p++ = (UV)RX_SUBCOFFSET(rx);
434 for (i = 0; i <= RX_NPARENS(rx); ++i) {
435 *p++ = (UV)RX_OFFSp(rx)[i].start;
436 *p++ = (UV)RX_OFFSp(rx)[i].end;
441 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
446 PERL_ARGS_ASSERT_RXRES_RESTORE;
449 RX_MATCH_COPY_FREE(rx);
450 RX_MATCH_COPIED_set(rx, *p);
452 RX_NPARENS(rx) = *p++;
455 if (RX_SAVED_COPY(rx))
456 SvREFCNT_dec (RX_SAVED_COPY(rx));
457 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
461 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
462 RX_SUBLEN(rx) = (SSize_t)(*p++);
463 RX_SUBOFFSET(rx) = (Size_t)*p++;
464 RX_SUBCOFFSET(rx) = (SSize_t)*p++;
465 for (i = 0; i <= RX_NPARENS(rx); ++i) {
466 RX_OFFSp(rx)[i].start = (SSize_t)(*p++);
467 RX_OFFSp(rx)[i].end = (SSize_t)(*p++);
472 S_rxres_free(pTHX_ void **rsp)
474 UV * const p = (UV*)*rsp;
476 PERL_ARGS_ASSERT_RXRES_FREE;
480 void *tmp = INT2PTR(char*,*p);
483 U32 i = 9 + p[1] * 2;
485 U32 i = 8 + p[1] * 2;
490 SvREFCNT_dec (INT2PTR(SV*,p[2]));
493 PoisonFree(p, i, sizeof(UV));
502 #define FORM_NUM_BLANK (1<<30)
503 #define FORM_NUM_POINT (1<<29)
505 PP_wrapped(pp_formline, 0, 1)
507 dSP; dMARK; dORIGMARK;
508 SV * const tmpForm = *++MARK;
509 SV *formsv; /* contains text of original format */
510 U32 *fpc; /* format ops program counter */
511 char *t; /* current append position in target string */
512 const char *f; /* current position in format string */
514 SV *sv = NULL; /* current item */
515 const char *item = NULL;/* string value of current item */
516 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
517 I32 itembytes = 0; /* as itemsize, but length in bytes */
518 I32 fieldsize = 0; /* width of current field */
519 I32 lines = 0; /* number of lines that have been output */
520 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
521 const char *chophere = NULL; /* where to chop current item */
522 STRLEN linemark = 0; /* pos of start of line in output */
524 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
525 STRLEN len; /* length of current sv */
526 STRLEN linemax; /* estimate of output size in bytes */
527 bool item_is_utf8 = FALSE;
528 bool targ_is_utf8 = FALSE;
531 U8 *source; /* source of bytes to append */
532 STRLEN to_copy; /* how may bytes to append */
533 char trans; /* what chars to translate */
534 bool copied_form = FALSE; /* have we duplicated the form? */
536 mg = doparseform(tmpForm);
538 fpc = (U32*)mg->mg_ptr;
539 /* the actual string the format was compiled from.
540 * with overload etc, this may not match tmpForm */
544 SvPV_force(PL_formtarget, len);
545 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
546 SvTAINTED_on(PL_formtarget);
547 if (DO_UTF8(PL_formtarget))
549 /* this is an initial estimate of how much output buffer space
550 * to allocate. It may be exceeded later */
551 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
552 t = SvGROW(PL_formtarget, len + linemax + 1);
553 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
555 f = SvPV_const(formsv, len);
559 const char *name = "???";
562 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
563 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
564 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
565 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
566 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
568 case FF_CHECKNL: name = "CHECKNL"; break;
569 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
570 case FF_SPACE: name = "SPACE"; break;
571 case FF_HALFSPACE: name = "HALFSPACE"; break;
572 case FF_ITEM: name = "ITEM"; break;
573 case FF_CHOP: name = "CHOP"; break;
574 case FF_LINEGLOB: name = "LINEGLOB"; break;
575 case FF_NEWLINE: name = "NEWLINE"; break;
576 case FF_MORE: name = "MORE"; break;
577 case FF_LINEMARK: name = "LINEMARK"; break;
578 case FF_END: name = "END"; break;
579 case FF_0DECIMAL: name = "0DECIMAL"; break;
580 case FF_LINESNGL: name = "LINESNGL"; break;
583 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
585 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
588 case FF_LINEMARK: /* start (or end) of a line */
589 linemark = t - SvPVX(PL_formtarget);
594 case FF_LITERAL: /* append <arg> literal chars */
599 item_is_utf8 = (targ_is_utf8)
600 ? cBOOL(DO_UTF8(formsv))
601 : cBOOL(SvUTF8(formsv));
604 case FF_SKIP: /* skip <arg> chars in format */
608 case FF_FETCH: /* get next item and set field size to <arg> */
617 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
620 SvTAINTED_on(PL_formtarget);
623 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
625 const char *s = item = SvPV_const(sv, len);
626 const char *send = s + len;
629 item_is_utf8 = DO_UTF8(sv);
641 if (itemsize == fieldsize)
644 itembytes = s - item;
649 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
651 const char *s = item = SvPV_const(sv, len);
652 const char *send = s + len;
656 item_is_utf8 = DO_UTF8(sv);
658 /* look for a legal split position */
666 /* provisional split point */
670 /* we delay testing fieldsize until after we've
671 * processed the possible split char directly
672 * following the last field char; so if fieldsize=3
673 * and item="a b cdef", we consume "a b", not "a".
674 * Ditto further down.
676 if (size == fieldsize)
680 if (size == fieldsize)
682 if (strchr(PL_chopset, *s)) {
683 /* provisional split point */
684 /* for a non-space split char, we include
685 * the split char; hence the '+1' */
699 if (!chophere || s == send) {
703 itembytes = chophere - item;
708 case FF_SPACE: /* append padding space (diff of field, item size) */
709 arg = fieldsize - itemsize;
717 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
718 arg = fieldsize - itemsize;
727 case FF_ITEM: /* append a text item, while blanking ctrl chars */
733 case FF_CHOP: /* (for ^*) chop the current item */
734 if (sv != &PL_sv_no) {
735 const char *s = chophere;
737 ((sv == tmpForm || SvSMAGICAL(sv))
738 || (SvGMAGICAL(tmpForm) && !sv_only_taint_gmagic(tmpForm))) ) {
739 /* sv and tmpForm are either the same SV, or magic might allow modification
740 of tmpForm when sv is modified, so copy */
741 SV *newformsv = sv_mortalcopy(formsv);
744 f = SvPV_nolen(newformsv) + (f - SvPV_nolen(formsv));
745 Newx(new_compiled, mg->mg_len / sizeof(U32), U32);
746 memcpy(new_compiled, mg->mg_ptr, mg->mg_len);
747 SAVEFREEPV(new_compiled);
748 fpc = new_compiled + (fpc - (U32*)mg->mg_ptr);
760 /* tied, overloaded or similar strangeness.
761 * Do it the hard way */
762 sv_setpvn(sv, s, len - (s-item));
768 case FF_LINESNGL: /* process ^* */
772 case FF_LINEGLOB: /* process @* */
774 const bool oneline = fpc[-1] == FF_LINESNGL;
775 const char *s = item = SvPV_const(sv, len);
776 const char *const send = s + len;
778 item_is_utf8 = DO_UTF8(sv);
789 to_copy = s - item - 1;
803 /* append to_copy bytes from source to PL_formstring.
804 * item_is_utf8 implies source is utf8.
805 * if trans, translate certain characters during the copy */
810 SvCUR_set(PL_formtarget,
811 t - SvPVX_const(PL_formtarget));
813 if (targ_is_utf8 && !item_is_utf8) {
814 source = tmp = bytes_to_utf8(source, &to_copy);
817 if (item_is_utf8 && !targ_is_utf8) {
819 /* Upgrade targ to UTF8, and then we reduce it to
820 a problem we have a simple solution for.
821 Don't need get magic. */
822 sv_utf8_upgrade_nomg(PL_formtarget);
824 /* re-calculate linemark */
825 s = (U8*)SvPVX(PL_formtarget);
826 /* the bytes we initially allocated to append the
827 * whole line may have been gobbled up during the
828 * upgrade, so allocate a whole new line's worth
832 s += UTF8_SAFE_SKIP(s,
833 (U8 *) SvEND(PL_formtarget));
834 linemark = s - (U8*)SvPVX(PL_formtarget);
836 /* Easy. They agree. */
837 assert (item_is_utf8 == targ_is_utf8);
840 /* @* and ^* are the only things that can exceed
841 * the linemax, so grow by the output size, plus
842 * a whole new form's worth in case of any further
844 grow = linemax + to_copy;
846 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
847 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
849 Copy(source, t, to_copy, char);
851 /* blank out ~ or control chars, depending on trans.
852 * works on bytes not chars, so relies on not
853 * matching utf8 continuation bytes */
855 U8 *send = s + to_copy;
858 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
865 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
871 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
874 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
877 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
880 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
882 /* If the field is marked with ^ and the value is undefined,
884 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
892 /* overflow evidence */
893 if (num_overflow(value, fieldsize, arg)) {
899 /* Formats aren't yet marked for locales, so assume "yes". */
901 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
903 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
907 if (!quadmath_format_valid(fmt))
908 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
909 WITH_LC_NUMERIC_SET_TO_NEEDED(
910 len = quadmath_snprintf(t, max, fmt, (int) fieldsize,
914 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", fmt);
917 /* we generate fmt ourselves so it is safe */
918 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
919 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
920 GCC_DIAG_RESTORE_STMT;
922 PERL_MY_SNPRINTF_POST_GUARD(len, max);
927 case FF_NEWLINE: /* delete trailing spaces, then append \n */
929 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
934 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
937 if (arg) { /* repeat until fields exhausted? */
943 t = SvPVX(PL_formtarget) + linemark;
948 case FF_MORE: /* replace long end of string with '...' */
950 const char *s = chophere;
951 const char *send = item + len;
953 while (isSPACE(*s) && (s < send))
958 arg = fieldsize - itemsize;
965 if (strBEGINs(s1," ")) {
966 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
976 case FF_END: /* tidy up, then return */
978 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
980 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
982 SvUTF8_on(PL_formtarget);
983 FmLINES(PL_formtarget) += lines;
985 if (fpc[-1] == FF_BLANK)
986 RETURNOP(cLISTOP->op_first);
993 /* also used for: pp_mapstart() */
996 /* See the code comments at the start of pp_grepwhile() and
997 * pp_mapwhile() for an explanation of how the stack is used
998 * during a grep or map.
1003 if (PL_stack_base + TOPMARK == PL_stack_sp) {
1005 if (GIMME_V == G_SCALAR) {
1007 *++PL_stack_sp = &PL_sv_zero;
1009 return PL_op->op_next->op_next;
1011 svp = PL_stack_base + TOPMARK + 1;
1012 PUSHMARK(svp); /* push dst */
1013 PUSHMARK(svp); /* push src */
1014 ENTER_with_name("grep"); /* enter outer scope */
1018 ENTER_with_name("grep_item"); /* enter inner scope */
1021 src = PL_stack_base[TOPMARK];
1022 if (SvPADTMP(src)) {
1023 SV *newsrc = sv_mortalcopy(src);
1025 PL_stack_base[TOPMARK] = newsrc;
1026 #ifdef PERL_RC_STACK
1027 SvREFCNT_inc_simple_void_NN(newsrc);
1035 if (PL_op->op_type == OP_MAPSTART)
1036 PUSHMARK(PL_stack_sp); /* push top */
1037 return cLOGOPx(PL_op->op_next)->op_other;
1040 /* pp_grepwhile() lives in pp_hot.c */
1044 /* Understanding the stack during a map.
1046 * 'map expr, args' is implemented in the form of
1048 * grepstart; // which handles map too
1054 * The stack examples below are in the form of 'perl -Ds' output,
1055 * where any stack element indexed by PL_markstack_ptr[i] has a star
1056 * just to the right of it. In addition, the corresponding i value
1057 * is displayed under the indexed stack element.
1059 * On entry to mapwhile, the stack looks like this:
1061 * => * A1..An X1 * X2..Xn C * R1..Rn * E1..En
1062 * [-3] [-2] [-1] [0]
1065 * A1..An Accumulated results from all previous iterations of expr
1066 * X1..Xn Random garbage
1067 * C The current (just processed) arg, still aliased to $_.
1068 * R1..Rn The args remaining to be processed.
1069 * E1..En the (list) result of the just-executed map expression.
1071 * Note that it is easiest to think of stack marks [-1] and [-2] as both
1072 * being one too high, and so it would make more sense to have had the
1075 * => * A1..An * X1..Xn * C R1..Rn * E1..En
1076 * [-3] [-2] [-1] [0]
1078 * where the stack is divided neatly into 4 groups:
1079 * - accumulated results
1080 * - discards and/or holes proactively created for later result storage
1081 * - being, or yet to be, processed,
1082 * - results of last expr
1083 * But off-by-one is the way it is currently, and it works as long as
1084 * we keep it consistent and bear it in mind.
1086 * pp_mapwhile() does the following:
1088 * - If there isn't enough space in the X1..Xn zone to insert the
1089 * expression results, grow the stack and shift up everything above C.
1090 * - move E1..En to just above An
1091 * - at the same time, manipulate the tmps stack so that temporaries
1092 * from executing expr can be freed without prematurely freeing
1094 * - if on last iteration, pop all the marks, reset the stack pointer
1095 * and update the return args based on caller context.
1096 * - else alias $_ to the next arg.
1100 const U8 gimme = GIMME_V;
1101 SSize_t items = (PL_stack_sp - PL_stack_base) - TOPMARK; /* how many new items */
1107 #ifdef PERL_RC_STACK
1108 /* for ref-counted stack, we need to account for the currently-aliased
1109 * stack element, as it might (or might not) get over-written when
1110 * copying values from the expr to the end of the accumulated results
1111 * section of the list. By RC--ing and zeroing out the stack entry, we
1112 * ensure consistent handling.
1114 dst = PL_stack_base + PL_markstack_ptr[-1];
1115 SvREFCNT_dec_NN(*dst);
1119 /* first, move source pointer to the next item in the source list */
1120 ++PL_markstack_ptr[-1];
1122 /* if there are new items, push them into the destination list */
1123 if (items && gimme != G_VOID) {
1124 /* might need to make room back there first */
1125 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1126 /* XXX this implementation is very pessimal because the stack
1127 * is repeatedly extended for every set of items. Is possible
1128 * to do this without any stack extension or copying at all
1129 * by maintaining a separate list over which the map iterates
1130 * (like foreach does). --gsar */
1132 /* everything in the stack after the destination list moves
1133 * towards the end the stack by the amount of room needed */
1134 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1136 /* items to shift up (accounting for the moved source pointer) */
1137 count = (PL_stack_sp - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1139 /* This optimization is by Ben Tilly and it does
1140 * things differently from what Sarathy (gsar)
1141 * is describing. The downside of this optimization is
1142 * that leaves "holes" (uninitialized and hopefully unused areas)
1143 * to the Perl stack, but on the other hand this
1144 * shouldn't be a problem. If Sarathy's idea gets
1145 * implemented, this optimization should become
1146 * irrelevant. --jhi */
1148 shift = count; /* Avoid shifting too often --Ben Tilly */
1152 PL_stack_sp += shift;
1154 PL_markstack_ptr[-1] += shift;
1155 *PL_markstack_ptr += shift;
1158 #ifdef PERL_RC_STACK
1159 /* zero out the hole just created, so that on a
1160 * reference-counted stack, so that the just-shifted SVs
1161 * aren't counted twice.
1163 Zero(src+1, (dst-src), SV*);
1166 /* copy the new items down to the destination list */
1167 PL_markstack_ptr[-2] += items;
1168 dst = PL_stack_base + PL_markstack_ptr[-2] - 1;
1169 if (gimme == G_LIST) {
1170 /* add returned items to the collection (making mortal copies
1171 * if necessary), then clear the current temps stack frame
1172 * *except* for those items. We do this splicing the items
1173 * into the start of the tmps frame (so some items may be on
1174 * the tmps stack twice), then moving PL_tmps_floor above
1175 * them, then freeing the frame. That way, the only tmps that
1176 * accumulate over iterations are the return values for map.
1177 * We have to do to this way so that everything gets correctly
1178 * freed if we die during the map.
1182 /* make space for the slice */
1183 EXTEND_MORTAL(items);
1184 tmpsbase = PL_tmps_floor + 1;
1185 Move(PL_tmps_stack + tmpsbase,
1186 PL_tmps_stack + tmpsbase + items,
1187 PL_tmps_ix - PL_tmps_floor,
1189 PL_tmps_ix += items;
1192 #ifdef PERL_RC_STACK
1193 SV *sv = *PL_stack_sp;
1194 assert(!*dst); /* not overwriting ptrs to refcnted SVs */
1196 sv = sv_mortalcopy(sv);
1197 /* NB - don't really need the mortalising above.
1198 * A simple copy would suffice */
1200 SvREFCNT_inc_simple_void_NN(sv);
1209 SV *sv = *PL_stack_sp--;
1211 sv = sv_mortalcopy(sv);
1214 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1216 /* clear the stack frame except for the items */
1217 PL_tmps_floor += items;
1219 /* FREETMPS may have cleared the TEMP flag on some of the items */
1222 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1225 /* scalar context: we don't care about which values map returns
1226 * (we use undef here). And so we certainly don't want to do mortal
1227 * copies of meaningless values. */
1228 *(dst - items + 1) = &PL_sv_undef;
1229 rpp_popfree_to(PL_stack_sp - items);
1235 assert(gimme == G_VOID);
1236 rpp_popfree_to(PL_stack_sp - items);
1240 LEAVE_with_name("grep_item"); /* exit inner scope */
1243 if (PL_markstack_ptr[-1] > TOPMARK) {
1245 (void)POPMARK; /* pop top */
1246 LEAVE_with_name("grep"); /* exit outer scope */
1247 (void)POPMARK; /* pop src */
1248 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1249 (void)POPMARK; /* pop dst */
1250 SV **svp = PL_stack_base + POPMARK; /* pop original mark */
1251 if (gimme == G_LIST)
1253 rpp_popfree_to(svp);
1254 if (gimme == G_SCALAR) {
1257 /* XXX is the extend necessary? */
1265 ENTER_with_name("grep_item"); /* enter inner scope */
1268 /* set $_ to the new source item */
1269 src = PL_stack_base[PL_markstack_ptr[-1]];
1270 if (SvPADTMP(src)) {
1271 SV *newsrc = sv_mortalcopy(src);
1272 PL_stack_base[PL_markstack_ptr[-1]] = newsrc;
1273 #ifdef PERL_RC_STACK
1274 SvREFCNT_inc_simple_void_NN(newsrc);
1279 if (SvPADTMP(src)) {
1280 src = sv_mortalcopy(src);
1285 return cLOGOP->op_other;
1294 if (GIMME_V == G_LIST)
1297 if (SvTRUE_NN(targ))
1298 return cLOGOP->op_other;
1304 PP_wrapped(pp_flip,((GIMME_V == G_LIST) ? 0 : 1), 0)
1308 if (GIMME_V == G_LIST) {
1309 RETURNOP(cLOGOPx(cUNOP->op_first)->op_other);
1313 SV * const targ = PAD_SV(PL_op->op_targ);
1316 if (PL_op->op_private & OPpFLIP_LINENUM) {
1317 if (GvIO(PL_last_in_gv)) {
1318 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1321 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1323 flip = SvIV(sv) == SvIV(GvSV(gv));
1326 flip = SvTRUE_NN(sv);
1329 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1330 if (PL_op->op_flags & OPf_SPECIAL) {
1338 RETURNOP(cLOGOPx(cUNOP->op_first)->op_other);
1348 /* This code tries to decide if "$left .. $right" should use the
1349 magical string increment, or if the range is numeric. Initially,
1350 an exception was made for *any* string beginning with "0" (see
1351 [#18165], AMS 20021031), but now that is only applied when the
1352 string's length is also >1 - see the rules now documented in
1355 #define RANGE_IS_NUMERIC(left,right) ( \
1356 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1357 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1358 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1359 looks_like_number(left)) && SvPOKp(left) \
1360 && !(*SvPVX_const(left) == '0' && SvCUR(left)>1 ) )) \
1361 && (!SvOK(right) || looks_like_number(right))))
1364 PP_wrapped(pp_flop, (GIMME_V == G_LIST) ? 2 : 1, 0)
1368 if (GIMME_V == G_LIST) {
1374 if (RANGE_IS_NUMERIC(left,right)) {
1376 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1377 (SvOK(right) && (SvIOK(right)
1378 ? SvIsUV(right) && SvUV(right) > IV_MAX
1379 : SvNV_nomg(right) > (NV) IV_MAX)))
1380 DIE(aTHX_ "Range iterator outside integer range");
1381 i = SvIV_nomg(left);
1382 j = SvIV_nomg(right);
1384 /* Dance carefully around signed max. */
1385 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1388 /* The wraparound of signed integers is undefined
1389 * behavior, but here we aim for count >=1, and
1390 * negative count is just wrong. */
1392 #if IVSIZE > Size_t_size
1399 Perl_croak(aTHX_ "Out of memory during list extend");
1406 SV * const sv = sv_2mortal(newSViv(i));
1408 if (n) /* avoid incrementing above IV_MAX */
1414 const char * const lpv = SvPV_nomg_const(left, llen);
1415 const char * const tmps = SvPV_nomg_const(right, len);
1417 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1418 if (DO_UTF8(right) && IN_UNI_8_BIT)
1419 len = sv_len_utf8_nomg(right);
1420 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1422 if (strEQ(SvPVX_const(sv),tmps))
1424 sv = sv_2mortal(newSVsv(sv));
1431 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1435 if (PL_op->op_private & OPpFLIP_LINENUM) {
1436 if (GvIO(PL_last_in_gv)) {
1437 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1440 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1441 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1445 flop = SvTRUE_NN(sv);
1449 sv_setiv(PAD_SV(cUNOPx(cUNOP->op_first)->op_first->op_targ), 0);
1450 sv_catpvs(targ, "E0");
1461 static const char * const context_name[] = {
1463 NULL, /* CXt_WHEN never actually needs "block" */
1464 NULL, /* CXt_BLOCK never actually needs "block" */
1465 NULL, /* CXt_GIVEN never actually needs "block" */
1466 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1467 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1468 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1469 NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1470 NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1479 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1483 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1485 for (i = cxstack_ix; i >= 0; i--) {
1486 const PERL_CONTEXT * const cx = &cxstack[i];
1487 switch (CxTYPE(cx)) {
1496 /* diag_listed_as: Exiting subroutine via %s */
1497 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1498 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1499 if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1502 case CXt_LOOP_PLAIN:
1503 case CXt_LOOP_LAZYIV:
1504 case CXt_LOOP_LAZYSV:
1508 STRLEN cx_label_len = 0;
1509 U32 cx_label_flags = 0;
1510 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1512 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1515 (const U8*)cx_label, cx_label_len,
1516 (const U8*)label, len) == 0)
1518 (const U8*)label, len,
1519 (const U8*)cx_label, cx_label_len) == 0)
1520 : (len == cx_label_len && ((cx_label == label)
1521 || memEQ(cx_label, label, len))) )) {
1522 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1523 (long)i, cx_label));
1526 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1535 =for apidoc_section $callback
1536 =for apidoc dowantarray
1538 Implements the deprecated L<perlapi/C<GIMME>>.
1544 Perl_dowantarray(pTHX)
1546 const U8 gimme = block_gimme();
1547 return (gimme == G_VOID) ? G_SCALAR : gimme;
1550 /* note that this function has mostly been superseded by Perl_gimme_V */
1553 Perl_block_gimme(pTHX)
1555 const I32 cxix = dopopto_cursub();
1560 gimme = (cxstack[cxix].blk_gimme & G_WANT);
1562 Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1567 =for apidoc is_lvalue_sub
1569 Returns non-zero if the sub calling this function is being called in an lvalue
1570 context. Returns 0 otherwise.
1576 Perl_is_lvalue_sub(pTHX)
1578 const I32 cxix = dopopto_cursub();
1579 assert(cxix >= 0); /* We should only be called from inside subs */
1581 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1582 return CxLVAL(cxstack + cxix);
1587 /* only used by cx_pushsub() */
1589 Perl_was_lvalue_sub(pTHX)
1591 const I32 cxix = dopoptosub(cxstack_ix-1);
1592 assert(cxix >= 0); /* We should only be called from inside subs */
1594 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1595 return CxLVAL(cxstack + cxix);
1601 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1605 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1607 PERL_UNUSED_CONTEXT;
1610 for (i = startingblock; i >= 0; i--) {
1611 const PERL_CONTEXT * const cx = &cxstk[i];
1612 switch (CxTYPE(cx)) {
1616 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1617 * twice; the first for the normal foo() call, and the second
1618 * for a faked up re-entry into the sub to execute the
1619 * code block. Hide this faked entry from the world. */
1620 if (cx->cx_type & CXp_SUB_RE_FAKE)
1622 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1628 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1632 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1640 S_dopoptoeval(pTHX_ I32 startingblock)
1643 for (i = startingblock; i >= 0; i--) {
1644 const PERL_CONTEXT *cx = &cxstack[i];
1645 switch (CxTYPE(cx)) {
1649 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1657 S_dopoptoloop(pTHX_ I32 startingblock)
1660 for (i = startingblock; i >= 0; i--) {
1661 const PERL_CONTEXT * const cx = &cxstack[i];
1662 switch (CxTYPE(cx)) {
1671 /* diag_listed_as: Exiting subroutine via %s */
1672 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1673 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1674 if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1677 case CXt_LOOP_PLAIN:
1678 case CXt_LOOP_LAZYIV:
1679 case CXt_LOOP_LAZYSV:
1682 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1689 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1692 S_dopoptogivenfor(pTHX_ I32 startingblock)
1695 for (i = startingblock; i >= 0; i--) {
1696 const PERL_CONTEXT *cx = &cxstack[i];
1697 switch (CxTYPE(cx)) {
1701 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1703 case CXt_LOOP_PLAIN:
1704 assert(!(cx->cx_type & CXp_FOR_DEF));
1706 case CXt_LOOP_LAZYIV:
1707 case CXt_LOOP_LAZYSV:
1710 if (cx->cx_type & CXp_FOR_DEF) {
1711 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1720 S_dopoptowhen(pTHX_ I32 startingblock)
1723 for (i = startingblock; i >= 0; i--) {
1724 const PERL_CONTEXT *cx = &cxstack[i];
1725 switch (CxTYPE(cx)) {
1729 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1736 /* dounwind(): pop all contexts above (but not including) cxix.
1737 * Note that it clears the savestack frame associated with each popped
1738 * context entry, but doesn't free any temps.
1739 * It does a cx_popblock() of the last frame that it pops, and leaves
1740 * cxstack_ix equal to cxix.
1744 Perl_dounwind(pTHX_ I32 cxix)
1746 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1749 while (cxstack_ix > cxix) {
1750 PERL_CONTEXT *cx = CX_CUR();
1752 CX_DEBUG(cx, "UNWIND");
1753 /* Note: we don't need to restore the base context info till the end. */
1757 switch (CxTYPE(cx)) {
1760 /* CXt_SUBST is not a block context type, so skip the
1761 * cx_popblock(cx) below */
1762 if (cxstack_ix == cxix + 1) {
1773 case CXt_LOOP_PLAIN:
1774 case CXt_LOOP_LAZYIV:
1775 case CXt_LOOP_LAZYSV:
1789 /* these two don't have a POPFOO() */
1795 if (cxstack_ix == cxix + 1) {
1804 /* Like rpp_popfree_to(), but takes an offset rather than a pointer,
1805 * and frees everything above ix appropriately, *regardless* of the
1806 * refcountedness of the stack. If necessary it removes any split stack.
1807 * Intended for use during exit() and die() and similar.
1810 Perl_rpp_obliterate_stack_to(pTHX_ I32 ix)
1812 #ifdef PERL_RC_STACK
1813 I32 nonrc_base = PL_curstackinfo->si_stack_nonrc_base;
1815 assert(ix <= PL_stack_sp - PL_stack_base);
1816 assert(nonrc_base <= PL_stack_sp - PL_stack_base + 1);
1818 if (nonrc_base && nonrc_base > ix) {
1819 /* abandon any non-refcounted stuff */
1820 PL_stack_sp = PL_stack_base + nonrc_base - 1;
1821 /* and mark the stack as fully refcounted again */
1822 PL_curstackinfo->si_stack_nonrc_base = 0;
1825 if (rpp_stack_is_rc())
1826 rpp_popfree_to(PL_stack_base + ix);
1828 PL_stack_sp = PL_stack_base + ix;
1830 PL_stack_sp = PL_stack_base + ix;
1837 Perl_qerror(pTHX_ SV *err)
1839 PERL_ARGS_ASSERT_QERROR;
1842 if (PL_in_eval & EVAL_KEEPERR) {
1843 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1847 sv_catsv(ERRSV, err);
1851 sv_catsv(PL_errors, err);
1853 Perl_warn(aTHX_ "%" SVf, SVfARG(err));
1856 ++PL_parser->error_count;
1860 if ( PL_parser && (err == NULL ||
1861 PL_parser->error_count >= PERL_STOP_PARSING_AFTER_N_ERRORS)
1863 const char * const name = OutCopFILE(PL_curcop);
1865 U8 raw_error_count = PERL_PARSE_ERROR_COUNT(PL_parser->error_count);
1872 abort_execution(errsv, name);
1875 if (raw_error_count >= PERL_STOP_PARSING_AFTER_N_ERRORS) {
1877 Perl_croak(aTHX_ "%" SVf "%s has too many errors.\n",
1878 SVfARG(errsv), name);
1880 Perl_croak(aTHX_ "%s has too many errors.\n", name);
1887 /* pop a CXt_EVAL context and in addition, if it was a require then
1889 * 0: do nothing extra;
1890 * 1: undef $INC{$name}; croak "$name did not return a true value";
1891 * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1895 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1897 SV *namesv = NULL; /* init to avoid dumb compiler warning */
1901 do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1903 /* keep namesv alive after cx_popeval() */
1904 namesv = cx->blk_eval.old_namesv;
1905 cx->blk_eval.old_namesv = NULL;
1914 HV *inc_hv = GvHVn(PL_incgv);
1917 (void)hv_delete_ent(inc_hv, namesv, G_DISCARD, 0);
1918 fmt = "%" SVf " did not return a true value";
1922 (void)hv_store_ent(inc_hv, namesv, &PL_sv_undef, 0);
1923 fmt = "%" SVf "Compilation failed in require";
1925 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1928 Perl_croak(aTHX_ fmt, SVfARG(errsv));
1933 /* die_unwind(): this is the final destination for the various croak()
1934 * functions. If we're in an eval, unwind the context and other stacks
1935 * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1936 * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1937 * to is a require the exception will be rethrown, as requires don't
1938 * actually trap exceptions.
1942 Perl_die_unwind(pTHX_ SV *msv)
1945 U8 in_eval = PL_in_eval;
1946 PERL_ARGS_ASSERT_DIE_UNWIND;
1951 /* We need to keep this SV alive through all the stack unwinding
1952 * and FREETMPSing below, while ensuing that it doesn't leak
1953 * if we call out to something which then dies (e.g. sub STORE{die}
1954 * when unlocalising a tied var). So we do a dance with
1955 * mortalising and SAVEFREEing.
1957 if (PL_phase == PERL_PHASE_DESTRUCT) {
1958 exceptsv = sv_mortalcopy(exceptsv);
1960 exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1964 * Historically, perl used to set ERRSV ($@) early in the die
1965 * process and rely on it not getting clobbered during unwinding.
1966 * That sucked, because it was liable to get clobbered, so the
1967 * setting of ERRSV used to emit the exception from eval{} has
1968 * been moved to much later, after unwinding (see just before
1969 * JMPENV_JUMP below). However, some modules were relying on the
1970 * early setting, by examining $@ during unwinding to use it as
1971 * a flag indicating whether the current unwinding was caused by
1972 * an exception. It was never a reliable flag for that purpose,
1973 * being totally open to false positives even without actual
1974 * clobberage, but was useful enough for production code to
1975 * semantically rely on it.
1977 * We'd like to have a proper introspective interface that
1978 * explicitly describes the reason for whatever unwinding
1979 * operations are currently in progress, so that those modules
1980 * work reliably and $@ isn't further overloaded. But we don't
1981 * have one yet. In its absence, as a stopgap measure, ERRSV is
1982 * now *additionally* set here, before unwinding, to serve as the
1983 * (unreliable) flag that it used to.
1985 * This behaviour is temporary, and should be removed when a
1986 * proper way to detect exceptional unwinding has been developed.
1987 * As of 2010-12, the authors of modules relying on the hack
1988 * are aware of the issue, because the modules failed on
1989 * perls 5.13.{1..7} which had late setting of $@ without this
1990 * early-setting hack.
1992 if (!(in_eval & EVAL_KEEPERR)) {
1993 /* remove any read-only/magic from the SV, so we don't
1994 get infinite recursion when setting ERRSV */
1996 sv_setsv_flags(ERRSV, exceptsv,
1997 (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
2000 if (in_eval & EVAL_KEEPERR) {
2001 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
2005 while ((cxix = dopoptoeval(cxstack_ix)) < 0
2006 && PL_curstackinfo->si_prev)
2009 rpp_obliterate_stack_to(0);
2016 JMPENV *restartjmpenv;
2019 if (cxix < cxstack_ix)
2023 assert(CxTYPE(cx) == CXt_EVAL);
2025 rpp_obliterate_stack_to(cx->blk_oldsp);
2027 /* return false to the caller of eval */
2028 gimme = cx->blk_gimme;
2029 if (gimme == G_SCALAR) {
2031 if (rpp_stack_is_rc())
2032 rpp_push_1(&PL_sv_undef);
2034 *++PL_stack_sp = &PL_sv_undef;
2037 restartjmpenv = cx->blk_eval.cur_top_env;
2038 restartop = cx->blk_eval.retop;
2040 /* We need a FREETMPS here to avoid late-called destructors
2041 * clobbering $@ *after* we set it below, e.g.
2042 * sub DESTROY { eval { die "X" } }
2043 * eval { my $x = bless []; die $x = 0, "Y" };
2045 * Here the clearing of the $x ref mortalises the anon array,
2046 * which needs to be freed *before* $& is set to "Y",
2047 * otherwise it gets overwritten with "X".
2049 * However, the FREETMPS will clobber exceptsv, so preserve it
2050 * on the savestack for now.
2052 SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv));
2054 /* now we're about to pop the savestack, so re-mortalise it */
2055 sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
2057 /* Note that unlike pp_entereval, pp_require isn't supposed to
2058 * trap errors. So if we're a require, after we pop the
2059 * CXt_EVAL that pp_require pushed, rethrow the error with
2060 * croak(exceptsv). This is all handled by the call below when
2063 S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
2065 if (!(in_eval & EVAL_KEEPERR)) {
2067 sv_setsv(ERRSV, exceptsv);
2069 PL_restartjmpenv = restartjmpenv;
2070 PL_restartop = restartop;
2072 NOT_REACHED; /* NOTREACHED */
2076 write_to_stderr(exceptsv);
2078 NOT_REACHED; /* NOTREACHED */
2084 SV *left = PL_stack_sp[0];
2085 SV *right = PL_stack_sp[-1];
2086 rpp_replace_2_1(SvTRUE_NN(left) != SvTRUE_NN(right)
2095 =for apidoc_section $CV
2097 =for apidoc caller_cx
2099 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
2100 returned C<PERL_CONTEXT> structure can be interrogated to find all the
2101 information returned to Perl by C<caller>. Note that XSUBs don't get a
2102 stack frame, so C<caller_cx(0, NULL)> will return information for the
2103 immediately-surrounding Perl code.
2105 This function skips over the automatic calls to C<&DB::sub> made on the
2106 behalf of the debugger. If the stack frame requested was a sub called by
2107 C<DB::sub>, the return value will be the frame for the call to
2108 C<DB::sub>, since that has the correct line number/etc. for the call
2109 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
2110 frame for the sub call itself.
2115 const PERL_CONTEXT *
2116 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
2118 I32 cxix = dopopto_cursub();
2119 const PERL_CONTEXT *cx;
2120 const PERL_CONTEXT *ccstack = cxstack;
2121 const PERL_SI *top_si = PL_curstackinfo;
2124 /* we may be in a higher stacklevel, so dig down deeper */
2125 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
2126 top_si = top_si->si_prev;
2127 ccstack = top_si->si_cxstack;
2128 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
2132 /* caller() should not report the automatic calls to &DB::sub */
2133 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
2134 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
2138 cxix = dopoptosub_at(ccstack, cxix - 1);
2141 cx = &ccstack[cxix];
2142 if (dbcxp) *dbcxp = cx;
2144 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2145 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
2146 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
2147 field below is defined for any cx. */
2148 /* caller() should not report the automatic calls to &DB::sub */
2149 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2150 cx = &ccstack[dbcxix];
2156 PP_wrapped(pp_caller, MAXARG, 0)
2159 const PERL_CONTEXT *cx;
2160 const PERL_CONTEXT *dbcx;
2162 const HEK *stash_hek;
2164 bool has_arg = MAXARG && TOPs;
2173 cx = caller_cx(count + cBOOL(PL_op->op_private & OPpOFFBYONE), &dbcx);
2175 if (gimme != G_LIST) {
2182 /* populate @DB::args ? */
2183 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
2184 && CopSTASH_eq(PL_curcop, PL_debstash))
2186 /* slot 0 of the pad contains the original @_ */
2187 AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
2188 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2189 cx->blk_sub.olddepth+1]))[0]);
2190 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
2192 Perl_init_dbargs(aTHX);
2194 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
2195 av_extend(PL_dbargs, AvFILLp(ary) + off);
2197 /* Alias elements of @_ to @DB::args */
2198 for (SSize_t i = AvFILLp(ary) + off; i >= 0; i--) {
2199 SV* sv = AvALLOC(ary)[i];
2200 /* for a shifted @_, the elements between AvALLOC and AvARRAY
2201 * point to old SVs which may have been freed or even
2202 * reallocated in the meantime. In the interests of
2203 * reconstructing the original @_ before any shifting, use
2204 * those old values, even at the risk of them being wrong.
2205 * But if the ref count is 0, then don't use it because
2206 * further assigning that value anywhere will panic.
2207 * Of course there's nothing to stop a RC != 0 SV being
2208 * subsequently freed, but hopefully people quickly copy the
2209 * contents of @DB::args before doing anything else.
2211 if (sv && (SvREFCNT(sv) == 0 || SvIS_FREED(sv)))
2213 AvARRAY(PL_dbargs)[i] = sv;
2215 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
2218 CX_DEBUG(cx, "CALLER");
2219 assert(CopSTASH(cx->blk_oldcop));
2220 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
2221 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
2223 if (gimme != G_LIST) {
2226 PUSHs(&PL_sv_undef);
2229 sv_sethek(TARG, stash_hek);
2238 PUSHs(&PL_sv_undef);
2241 sv_sethek(TARG, stash_hek);
2244 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
2245 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
2246 cx->blk_sub.retop, TRUE);
2248 lcop = cx->blk_oldcop;
2249 mPUSHu(CopLINE(lcop));
2252 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2253 /* So is ccstack[dbcxix]. */
2254 if (CvHASGV(dbcx->blk_sub.cv)) {
2255 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
2256 PUSHs(boolSV(CxHASARGS(cx)));
2259 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
2260 PUSHs(boolSV(CxHASARGS(cx)));
2264 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
2267 gimme = cx->blk_gimme;
2268 if (gimme == G_VOID)
2269 PUSHs(&PL_sv_undef);
2271 PUSHs(boolSV((gimme & G_WANT) == G_LIST));
2272 if (CxTYPE(cx) == CXt_EVAL) {
2274 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
2275 SV *cur_text = cx->blk_eval.cur_text;
2276 if (SvCUR(cur_text) >= 2) {
2277 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
2278 SvUTF8(cur_text)|SVs_TEMP));
2281 /* I think this is will always be "", but be sure */
2282 PUSHs(sv_2mortal(newSVsv(cur_text)));
2288 else if (cx->blk_eval.old_namesv) {
2289 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
2292 /* eval BLOCK (try blocks have old_namesv == 0) */
2294 PUSHs(&PL_sv_undef);
2295 PUSHs(&PL_sv_undef);
2299 PUSHs(&PL_sv_undef);
2300 PUSHs(&PL_sv_undef);
2303 mPUSHi(CopHINTS_get(cx->blk_oldcop));
2306 char *old_warnings = cx->blk_oldcop->cop_warnings;
2308 if (old_warnings == pWARN_NONE)
2309 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
2310 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
2311 mask = &PL_sv_undef ;
2312 else if (old_warnings == pWARN_ALL ||
2313 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
2314 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
2317 mask = newSVpvn(old_warnings, RCPV_LEN(old_warnings));
2321 PUSHs(cx->blk_oldcop->cop_hints_hash ?
2322 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2328 PP_wrapped(pp_reset, MAXARG, 0)
2333 if (MAXARG < 1 || (!TOPs && !POPs)) {
2335 tmps = NULL, len = 0;
2338 tmps = SvPVx_const(POPs, len);
2339 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
2344 /* like pp_nextstate, but used instead when the debugger is active */
2348 PL_curcop = (COP*)PL_op;
2349 TAINT_NOT; /* Each statement is presumed innocent */
2350 rpp_popfree_to(PL_stack_base + CX_CUR()->blk_oldsp);
2355 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2356 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2359 const U8 gimme = G_LIST;
2360 GV * const gv = PL_DBgv;
2363 if (gv && isGV_with_GP(gv))
2366 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2367 DIE(aTHX_ "No DB::DB routine defined");
2369 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2370 /* don't do recursive DB::DB call */
2377 /* I suspect that saving the stack position is no longer
2378 * required. It was added in 5.001 by:
2380 * NETaa13155: &DB::DB left trash on the stack.
2381 * From: Thomas Koenig
2382 * Files patched: lib/perl5db.pl pp_ctl.c
2383 * The call by pp_dbstate() to &DB::DB left trash on the
2384 * stack. It now calls DB in list context, and DB returns
2387 * but the details of what bug it fixed are long lost to
2388 * history. SAVESTACK_POS() doesn't work well with stacks
2389 * which may be split into partly reference-counted and partly
2390 * not halves, so skip it and hope it doesn't cause any
2393 #ifndef PERL_RC_STACK
2397 PUSHMARK(PL_stack_sp);
2404 #ifdef PERL_RC_STACK
2405 assert(!PL_curstackinfo->si_stack_nonrc_base);
2407 cx = cx_pushblock(CXt_SUB, gimme, PL_stack_sp, PL_savestack_ix);
2408 cx_pushsub(cx, cv, PL_op->op_next, 0);
2409 /* OP_DBSTATE's op_private holds hint bits rather than
2410 * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2411 * any CxLVAL() flags that have now been mis-calculated */
2416 /* see comment above about SAVESTACK_POS */
2417 #ifndef PERL_RC_STACK
2421 if (CvDEPTH(cv) >= 2)
2422 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2423 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2436 (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2448 assert(CxTYPE(cx) == CXt_BLOCK);
2450 if (PL_op->op_flags & OPf_SPECIAL)
2451 /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */
2452 cx->blk_oldpm = PL_curpm;
2454 oldsp = PL_stack_base + cx->blk_oldsp;
2455 gimme = cx->blk_gimme;
2457 if (gimme == G_VOID)
2458 rpp_popfree_to(oldsp);
2460 leave_adjust_stacks(oldsp, oldsp, gimme,
2461 PL_op->op_private & OPpLVALUE ? 3 : 1);
2471 S_outside_integer(pTHX_ SV *sv)
2474 const NV nv = SvNV_nomg(sv);
2475 if (Perl_isinfnan(nv))
2477 #ifdef NV_PRESERVES_UV
2478 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2481 if (nv <= (NV)IV_MIN)
2484 ((nv > (NV)UV_MAX ||
2485 SvUV_nomg(sv) > (UV)IV_MAX)))
2496 const U8 gimme = GIMME_V;
2497 void *itervarp; /* GV or pad slot of the iteration variable */
2498 SV *itersave; /* the old var in the iterator var slot */
2501 if (PL_op->op_targ) { /* "my" variable */
2502 itervarp = &PAD_SVl(PL_op->op_targ);
2503 itersave = *(SV**)itervarp;
2505 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2506 /* the SV currently in the pad slot is never live during
2507 * iteration (the slot is always aliased to one of the items)
2508 * so it's always stale */
2509 SvPADSTALE_on(itersave);
2511 SvREFCNT_inc_simple_void_NN(itersave);
2512 cxflags = CXp_FOR_PAD;
2515 SV * const sv = *PL_stack_sp;
2516 itervarp = (void *)sv;
2517 if (LIKELY(isGV(sv))) { /* symbol table variable */
2518 itersave = GvSV(sv);
2519 SvREFCNT_inc_simple_void(itersave);
2520 cxflags = CXp_FOR_GV;
2521 if (PL_op->op_private & OPpITER_DEF)
2522 cxflags |= CXp_FOR_DEF;
2524 else { /* LV ref: for \$foo (...) */
2525 assert(SvTYPE(sv) == SVt_PVMG);
2526 assert(SvMAGIC(sv));
2527 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2529 cxflags = CXp_FOR_LVREF;
2531 /* we transfer ownership of 1 ref count of itervarp from the stack
2532 * to the CX entry, so no SvREFCNT_dec() needed */
2533 (void)rpp_pop_1_norc();
2535 /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2536 assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2538 /* Note that this context is initially set as CXt_NULL. Further on
2539 * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2540 * there mustn't be anything in the blk_loop substruct that requires
2541 * freeing or undoing, in case we die in the meantime. And vice-versa.
2543 cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2544 cx_pushloop_for(cx, itervarp, itersave);
2546 if (PL_op->op_flags & OPf_STACKED) {
2547 /* OPf_STACKED implies either a single array: for(@), with a
2548 * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2550 SV *maybe_ary = *PL_stack_sp;
2551 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2553 SV* sv = PL_stack_sp[-1];
2554 SV * const right = maybe_ary;
2555 if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2556 DIE(aTHX_ "Assigned value is not a reference");
2559 if (RANGE_IS_NUMERIC(sv,right)) {
2560 cx->cx_type |= CXt_LOOP_LAZYIV;
2561 if (S_outside_integer(aTHX_ sv) ||
2562 S_outside_integer(aTHX_ right))
2563 DIE(aTHX_ "Range iterator outside integer range");
2564 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2565 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2569 cx->cx_type |= CXt_LOOP_LAZYSV;
2570 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2571 cx->blk_loop.state_u.lazysv.end = right;
2573 /* we transfer ownership of 1 ref count of right from the
2574 * stack to the CX .end entry, so no SvREFCNT_dec() needed */
2575 (void)rpp_pop_1_norc();
2577 rpp_popfree_1(); /* free the (now copied) start SV */
2578 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2579 /* This will do the upgrade to SVt_PV, and warn if the value
2580 is uninitialised. */
2581 (void) SvPV_nolen_const(right);
2582 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2583 to replace !SvOK() with a pointer to "". */
2585 SvREFCNT_dec(right);
2586 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2590 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2591 /* for (@array) {} */
2592 cx->cx_type |= CXt_LOOP_ARY;
2593 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2594 /* we transfer ownership of 1 ref count of the av from the
2595 * stack to the CX .ary entry, so no SvREFCNT_dec() needed */
2596 (void)rpp_pop_1_norc();
2597 cx->blk_loop.state_u.ary.ix =
2598 (PL_op->op_private & OPpITER_REVERSED) ?
2599 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2602 /* rpp_extend(1) not needed in this branch because we just did POPs */
2604 else { /* iterating over items on the stack */
2605 cx->cx_type |= CXt_LOOP_LIST;
2606 cx->blk_oldsp = PL_stack_sp - PL_stack_base;
2607 cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2608 cx->blk_loop.state_u.stack.ix =
2609 (PL_op->op_private & OPpITER_REVERSED)
2611 : cx->blk_loop.state_u.stack.basesp;
2612 /* pre-extend stack so pp_iter doesn't have to check every time
2613 * it pushes yes/no */
2623 const U8 gimme = GIMME_V;
2625 cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2626 cx_pushloop_plain(cx);
2639 assert(CxTYPE_is_LOOP(cx));
2640 oldsp = PL_stack_base + cx->blk_oldsp;
2641 base = CxTYPE(cx) == CXt_LOOP_LIST
2642 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2644 gimme = cx->blk_gimme;
2646 if (gimme == G_VOID)
2647 rpp_popfree_to(base);
2649 leave_adjust_stacks(oldsp, base, gimme,
2650 PL_op->op_private & OPpLVALUE ? 3 : 1);
2653 cx_poploop(cx); /* Stack values are safe: release loop vars ... */
2661 /* This duplicates most of pp_leavesub, but with additional code to handle
2662 * return args in lvalue context. It was forked from pp_leavesub to
2663 * avoid slowing down that function any further.
2665 * Any changes made to this function may need to be copied to pp_leavesub
2668 * also tail-called by pp_return
2679 assert(CxTYPE(cx) == CXt_SUB);
2681 if (CxMULTICALL(cx)) {
2682 /* entry zero of a stack is always PL_sv_undef, which
2683 * simplifies converting a '()' return into undef in scalar context */
2684 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2688 gimme = cx->blk_gimme;
2689 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2691 if (gimme == G_VOID)
2692 rpp_popfree_to(oldsp);
2694 U8 lval = CxLVAL(cx);
2695 bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2696 const char *what = NULL;
2698 if (gimme == G_SCALAR) {
2700 /* check for bad return arg */
2701 if (oldsp < PL_stack_sp) {
2702 SV *sv = *PL_stack_sp;
2703 if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2705 SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2706 : "a readonly value" : "a temporary";
2711 /* sub:lvalue{} will take us here. */
2716 "Can't return %s from lvalue subroutine", what);
2720 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2722 if (lval & OPpDEREF) {
2723 /* lval_sub()->{...} and similar */
2724 SvGETMAGIC(*PL_stack_sp);
2725 if (!SvOK(*PL_stack_sp)) {
2726 SV *sv = vivify_ref(*PL_stack_sp, CxLVAL(cx) & OPpDEREF);
2727 rpp_replace_1_1(sv);
2732 assert(gimme == G_LIST);
2733 assert (!(lval & OPpDEREF));
2736 /* scan for bad return args */
2738 for (p = PL_stack_sp; p > oldsp; p--) {
2740 /* the PL_sv_undef exception is to allow things like
2741 * this to work, where PL_sv_undef acts as 'skip'
2742 * placeholder on the LHS of list assigns:
2743 * sub foo :lvalue { undef }
2744 * ($a, undef, foo(), $b) = 1..4;
2746 if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2748 /* Might be flattened array after $#array = */
2749 what = SvREADONLY(sv)
2750 ? "a readonly value" : "a temporary";
2756 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2761 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
2763 retop = cx->blk_sub.retop;
2769 static const char *S_defer_blockname(PERL_CONTEXT *cx)
2771 return (cx->cx_type & CXp_FINALLY) ? "finally" : "defer";
2779 I32 cxix = dopopto_cursub();
2781 assert(cxstack_ix >= 0);
2782 if (cxix < cxstack_ix) {
2784 /* Check for defer { return; } */
2785 for(i = cxstack_ix; i > cxix; i--) {
2786 if(CxTYPE(&cxstack[i]) == CXt_DEFER)
2787 /* diag_listed_as: Can't "%s" out of a "defer" block */
2788 /* diag_listed_as: Can't "%s" out of a "finally" block */
2789 Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
2790 "return", S_defer_blockname(&cxstack[i]));
2793 if (!( PL_curstackinfo->si_type == PERLSI_SORT
2794 || ( PL_curstackinfo->si_type == PERLSI_MULTICALL
2795 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2798 DIE(aTHX_ "Can't return outside a subroutine");
2800 * a sort block, which is a CXt_NULL not a CXt_SUB;
2801 * or a /(?{...})/ block.
2802 * Handle specially. */
2803 assert(CxTYPE(&cxstack[0]) == CXt_NULL
2804 || ( CxTYPE(&cxstack[0]) == CXt_SUB
2805 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2806 if (cxstack_ix > 0) {
2807 /* See comment below about context popping. Since we know
2808 * we're scalar and not lvalue, we can preserve the return
2809 * value in a simpler fashion than there. */
2810 SV *sv = *PL_stack_sp;
2811 assert(cxstack[0].blk_gimme == G_SCALAR);
2812 if ( (PL_stack_sp != PL_stack_base)
2813 && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2815 #ifdef PERL_RC_STACK
2816 rpp_replace_1_1(newSVsv(sv));
2818 *PL_stack_sp = sv_mortalcopy(sv);
2822 /* caller responsible for popping cxstack[0] */
2826 /* There are contexts that need popping. Doing this may free the
2827 * return value(s), so preserve them first: e.g. popping the plain
2828 * loop here would free $x:
2829 * sub f { { my $x = 1; return $x } }
2830 * We may also need to shift the args down; for example,
2831 * for (1,2) { return 3,4 }
2832 * leaves 1,2,3,4 on the stack. Both these actions will be done by
2833 * leave_adjust_stacks(), along with freeing any temps. Note that
2834 * whoever we tail-call (e.g. pp_leaveeval) will also call
2835 * leave_adjust_stacks(); however, the second call is likely to
2836 * just see a bunch of SvTEMPs with a ref count of 1, and so just
2837 * pass them through, rather than copying them again. So this
2838 * isn't as inefficient as it sounds.
2840 cx = &cxstack[cxix];
2841 if (cx->blk_gimme != G_VOID)
2842 leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2844 CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2847 cx = &cxstack[cxix]; /* CX stack may have been realloced */
2850 /* Like in the branch above, we need to handle any extra junk on
2851 * the stack. But because we're not also popping extra contexts, we
2852 * don't have to worry about prematurely freeing args. So we just
2853 * need to do the bare minimum to handle junk, and leave the main
2854 * arg processing in the function we tail call, e.g. pp_leavesub.
2855 * In list context we have to splice out the junk; in scalar
2856 * context we can leave as-is (pp_leavesub will later return the
2857 * top stack element). But for an empty arg list, e.g.
2858 * for (1,2) { return }
2859 * we need to set PL_stack_sp = oldsp so that pp_leavesub knows to
2860 * push &PL_sv_undef onto the stack.
2863 cx = &cxstack[cxix];
2864 oldsp = PL_stack_base + cx->blk_oldsp;
2865 if (oldsp != MARK) {
2866 SSize_t nargs = PL_stack_sp - MARK;
2868 if (cx->blk_gimme == G_LIST) {
2869 /* shift return args to base of call stack frame */
2870 #ifdef PERL_RC_STACK
2871 /* free the items on the stack that will get
2874 for (p = MARK; p > oldsp; p--) {
2880 Move(MARK + 1, oldsp + 1, nargs, SV*);
2881 PL_stack_sp = oldsp + nargs;
2885 rpp_popfree_to(oldsp);
2889 /* fall through to a normal exit */
2890 switch (CxTYPE(cx)) {
2892 return CxEVALBLOCK(cx)
2893 ? Perl_pp_leavetry(aTHX)
2894 : Perl_pp_leaveeval(aTHX);
2896 return CvLVALUE(cx->blk_sub.cv)
2897 ? Perl_pp_leavesublv(aTHX)
2898 : Perl_pp_leavesub(aTHX);
2900 return Perl_pp_leavewrite(aTHX);
2902 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2906 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2908 static PERL_CONTEXT *
2912 if (PL_op->op_flags & OPf_SPECIAL) {
2913 cxix = dopoptoloop(cxstack_ix);
2915 /* diag_listed_as: Can't "last" outside a loop block */
2916 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2925 if (PL_op->op_flags & OPf_STACKED) {
2927 label = SvPV(sv, label_len);
2928 label_flags = SvUTF8(sv);
2931 sv = NULL; /* not needed, but shuts up compiler warn */
2932 label = cPVOP->op_pv;
2933 label_len = strlen(label);
2934 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2937 cxix = dopoptolabel(label, label_len, label_flags);
2939 /* diag_listed_as: Label not found for "last %s" */
2940 Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"",
2942 SVfARG(PL_op->op_flags & OPf_STACKED
2945 : newSVpvn_flags(label,
2947 label_flags | SVs_TEMP)));
2948 if (PL_op->op_flags & OPf_STACKED)
2952 if (cxix < cxstack_ix) {
2954 /* Check for defer { last ... } etc */
2955 for(i = cxstack_ix; i > cxix; i--) {
2956 if(CxTYPE(&cxstack[i]) == CXt_DEFER)
2957 /* diag_listed_as: Can't "%s" out of a "defer" block */
2958 /* diag_listed_as: Can't "%s" out of a "finally" block */
2959 Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
2960 OP_NAME(PL_op), S_defer_blockname(&cxstack[i]));
2964 return &cxstack[cxix];
2973 cx = S_unwind_loop(aTHX);
2975 assert(CxTYPE_is_LOOP(cx));
2976 rpp_popfree_to(PL_stack_base
2977 + (CxTYPE(cx) == CXt_LOOP_LIST
2978 ? cx->blk_loop.state_u.stack.basesp
2984 /* Stack values are safe: */
2986 cx_poploop(cx); /* release loop vars ... */
2988 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2998 /* if not a bare 'next' in the main scope, search for it */
3000 if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
3001 cx = S_unwind_loop(aTHX);
3004 PL_curcop = cx->blk_oldcop;
3006 return (cx)->blk_loop.my_op->op_nextop;
3011 PERL_CONTEXT *cx = S_unwind_loop(aTHX);
3012 OP* redo_op = cx->blk_loop.my_op->op_redoop;
3014 if (redo_op->op_type == OP_ENTER) {
3015 /* pop one less context to avoid $x being freed in while (my $x..) */
3018 assert(CxTYPE(cx) == CXt_BLOCK);
3019 redo_op = redo_op->op_next;
3025 PL_curcop = cx->blk_oldcop;
3030 #define UNENTERABLE (OP *)1
3031 #define GOTO_DEPTH 64
3034 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
3037 static const char* const too_deep = "Target of goto is too deeply nested";
3039 PERL_ARGS_ASSERT_DOFINDLABEL;
3042 Perl_croak(aTHX_ "%s", too_deep);
3043 if (o->op_type == OP_LEAVE ||
3044 o->op_type == OP_SCOPE ||
3045 o->op_type == OP_LEAVELOOP ||
3046 o->op_type == OP_LEAVESUB ||
3047 o->op_type == OP_LEAVETRY ||
3048 o->op_type == OP_LEAVEGIVEN)
3050 *ops++ = cUNOPo->op_first;
3052 else if (oplimit - opstack < GOTO_DEPTH) {
3053 if (o->op_flags & OPf_KIDS
3054 && cUNOPo->op_first->op_type == OP_PUSHMARK) {
3055 *ops++ = UNENTERABLE;
3057 else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type]
3058 && OP_CLASS(o) != OA_LOGOP
3059 && o->op_type != OP_LINESEQ
3060 && o->op_type != OP_SREFGEN
3061 && o->op_type != OP_ENTEREVAL
3062 && o->op_type != OP_GLOB
3063 && o->op_type != OP_RV2CV) {
3064 OP * const kid = cUNOPo->op_first;
3065 if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid))
3066 *ops++ = UNENTERABLE;
3070 Perl_croak(aTHX_ "%s", too_deep);
3072 if (o->op_flags & OPf_KIDS) {
3074 OP * const kid1 = cUNOPo->op_first;
3075 /* First try all the kids at this level, since that's likeliest. */
3076 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3077 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3078 STRLEN kid_label_len;
3079 U32 kid_label_flags;
3080 const char *kid_label = CopLABEL_len_flags(kCOP,
3081 &kid_label_len, &kid_label_flags);
3083 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
3086 (const U8*)kid_label, kid_label_len,
3087 (const U8*)label, len) == 0)
3089 (const U8*)label, len,
3090 (const U8*)kid_label, kid_label_len) == 0)
3091 : ( len == kid_label_len && ((kid_label == label)
3092 || memEQ(kid_label, label, len)))))
3096 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3097 bool first_kid_of_binary = FALSE;
3098 if (kid == PL_lastgotoprobe)
3100 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3103 else if (ops[-1] != UNENTERABLE
3104 && (ops[-1]->op_type == OP_NEXTSTATE ||
3105 ops[-1]->op_type == OP_DBSTATE))
3110 if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) {
3111 first_kid_of_binary = TRUE;
3114 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit))) {
3115 if (kid->op_type == OP_PUSHDEFER)
3116 Perl_croak(aTHX_ "Can't \"goto\" into a \"defer\" block");
3119 if (first_kid_of_binary)
3120 *ops++ = UNENTERABLE;
3129 S_check_op_type(pTHX_ OP * const o)
3131 /* Eventually we may want to stack the needed arguments
3132 * for each op. For now, we punt on the hard ones. */
3133 /* XXX This comment seems to me like wishful thinking. --sprout */
3134 if (o == UNENTERABLE)
3136 "Can't \"goto\" into a binary or list expression");
3137 if (o->op_type == OP_ENTERITER)
3139 "Can't \"goto\" into the middle of a foreach loop");
3140 if (o->op_type == OP_ENTERGIVEN)
3142 "Can't \"goto\" into a \"given\" block");
3145 /* also used for: pp_dump() */
3152 OP *enterops[GOTO_DEPTH];
3153 const char *label = NULL;
3154 STRLEN label_len = 0;
3155 U32 label_flags = 0;
3156 const bool do_dump = (PL_op->op_type == OP_DUMP);
3157 static const char* const must_have_label = "goto must have label";
3159 if (PL_op->op_flags & OPf_STACKED) {
3160 /* goto EXPR or goto &foo */
3162 SV * const sv = *PL_stack_sp;
3165 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
3166 /* This egregious kludge implements goto &subroutine */
3169 CV *cv = MUTABLE_CV(SvRV(sv));
3170 AV *arg = GvAV(PL_defgv);
3173 while (!CvROOT(cv) && !CvXSUB(cv)) {
3174 const GV * const gv = CvGV(cv);
3178 /* autoloaded stub? */
3179 if (cv != GvCV(gv) && (cv = GvCV(gv)))
3181 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
3183 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
3184 if (autogv && (cv = GvCV(autogv)))
3186 tmpstr = sv_newmortal();
3187 gv_efullname3(tmpstr, gv, NULL);
3188 DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
3190 DIE(aTHX_ "Goto undefined subroutine");
3193 cxix = dopopto_cursub();
3195 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
3197 cx = &cxstack[cxix];
3198 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
3199 if (CxTYPE(cx) == CXt_EVAL) {
3201 /* diag_listed_as: Can't goto subroutine from an eval-%s */
3202 DIE(aTHX_ "Can't goto subroutine from an eval-string");
3204 /* diag_listed_as: Can't goto subroutine from an eval-%s */
3205 DIE(aTHX_ "Can't goto subroutine from an eval-block");
3207 else if (CxMULTICALL(cx))
3208 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
3210 /* Check for defer { goto &...; } */
3211 for(ix = cxstack_ix; ix > cxix; ix--) {
3212 if(CxTYPE(&cxstack[ix]) == CXt_DEFER)
3213 /* diag_listed_as: Can't "%s" out of a "defer" block */
3214 Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
3215 "goto", S_defer_blockname(&cxstack[ix]));
3218 /* First do some returnish stuff. */
3220 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
3221 rpp_popfree_1(); /* safe to free original sv now */
3224 if (cxix < cxstack_ix) {
3230 /* protect @_ during save stack unwind. */
3232 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
3234 assert(PL_scopestack_ix == cx->blk_oldscopesp);
3237 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
3238 /* this is part of cx_popsub_args() */
3239 AV* av = MUTABLE_AV(PAD_SVl(0));
3240 assert(AvARRAY(MUTABLE_AV(
3241 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
3242 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
3244 /* we are going to donate the current @_ from the old sub
3245 * to the new sub. This first part of the donation puts a
3246 * new empty AV in the pad[0] slot of the old sub,
3247 * unless pad[0] and @_ differ (e.g. if the old sub did
3248 * local *_ = []); in which case clear the old pad[0]
3249 * array in the usual way */
3251 if (av != arg && !SvMAGICAL(av) && SvREFCNT(av) == 1
3252 #ifndef PERL_RC_STACK
3256 clear_defarray_simple(av);
3258 clear_defarray(av, av == arg);
3261 /* don't restore PL_comppad here. It won't be needed if the
3262 * sub we're going to is non-XS, but restoring it early then
3263 * croaking (e.g. the "Goto undefined subroutine" below)
3264 * means the CX block gets processed again in dounwind,
3265 * but this time with the wrong PL_comppad */
3267 /* A destructor called during LEAVE_SCOPE could have undefined
3268 * our precious cv. See bug #99850. */
3269 if (!CvROOT(cv) && !CvXSUB(cv)) {
3270 const GV * const gv = CvGV(cv);
3272 SV * const tmpstr = sv_newmortal();
3273 gv_efullname3(tmpstr, gv, NULL);
3274 DIE(aTHX_ "Goto undefined subroutine &%" SVf,
3277 DIE(aTHX_ "Goto undefined subroutine");
3280 if (CxTYPE(cx) == CXt_SUB) {
3281 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
3282 /*on XS calls defer freeing the old CV as it could
3283 * prematurely set PL_op to NULL, which could cause
3284 * e..g XS subs using GIMME_V to SEGV */
3286 old_cv = cx->blk_sub.cv;
3288 SvREFCNT_dec_NN(cx->blk_sub.cv);
3291 /* Now do some callish stuff. */
3293 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
3294 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
3300 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
3302 SAVEFREESV(old_cv); /* ditto, deferred freeing of old CV */
3304 /* put GvAV(defgv) back onto stack */
3306 rpp_extend(items + 1); /* @_ could have been extended. */
3310 #ifdef PERL_RC_STACK
3311 assert(AvREAL(arg));
3313 bool r = cBOOL(AvREAL(arg));
3315 for (index=0; index<items; index++)
3319 SV ** const svp = av_fetch(arg, index, 0);
3320 sv = svp ? *svp : NULL;
3322 else sv = AvARRAY(arg)[index];
3324 #ifdef PERL_RC_STACK
3328 : newSVavdefelem(arg, index, 1)
3333 ? (r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv)
3334 : sv_2mortal(newSVavdefelem(arg, index, 1))
3340 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
3341 /* Restore old @_ */
3342 CX_POP_SAVEARRAY(cx);
3345 retop = cx->blk_sub.retop;
3346 PL_comppad = cx->blk_sub.prevcomppad;
3347 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
3349 /* Make a temporary a copy of the current GOTO op on the C
3350 * stack, but with a modified gimme (we can't modify the
3351 * real GOTO op as that's not thread-safe). This allows XS
3352 * users of GIMME_V to get the correct calling context,
3353 * even though there is no longer a CXt_SUB frame to
3354 * provide that information.
3356 Copy(PL_op, &fake_goto_op, 1, UNOP);
3357 fake_goto_op.op_flags =
3358 (fake_goto_op.op_flags & ~OPf_WANT)
3359 | (cx->blk_gimme & G_WANT);
3360 PL_op = (OP*)&fake_goto_op;
3362 /* XS subs don't have a CXt_SUB, so pop it;
3363 * this is a cx_popblock(), less all the stuff we already did
3364 * for cx_topblock() earlier */
3365 PL_curcop = cx->blk_oldcop;
3366 /* this is cx_popsub, less all the stuff we already did */
3367 PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
3371 /* Push a mark for the start of arglist */
3378 PADLIST * const padlist = CvPADLIST(cv);
3380 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
3382 /* partial unrolled cx_pushsub(): */
3384 cx->blk_sub.cv = cv;
3385 cx->blk_sub.olddepth = CvDEPTH(cv);
3388 SvREFCNT_inc_simple_void_NN(cv);
3389 if (CvDEPTH(cv) > 1) {
3390 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
3391 sub_crush_depth(cv);
3392 pad_push(padlist, CvDEPTH(cv));
3394 PL_curcop = cx->blk_oldcop;
3395 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
3399 /* second half of donating @_ from the old sub to the
3400 * new sub: abandon the original pad[0] AV in the
3401 * new sub, and replace it with the donated @_.
3402 * pad[0] takes ownership of the extra refcount
3403 * we gave arg earlier */
3405 SvREFCNT_dec(PAD_SVl(0));
3406 PAD_SVl(0) = (SV *)arg;
3407 SvREFCNT_inc_simple_void_NN(arg);
3410 /* GvAV(PL_defgv) might have been modified on scope
3411 exit, so point it at arg again. */
3412 if (arg != GvAV(PL_defgv)) {
3413 AV * const av = GvAV(PL_defgv);
3414 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
3419 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
3420 Perl_get_db_sub(aTHX_ NULL, cv);
3422 CV * const gotocv = get_cvs("DB::goto", 0);
3424 PUSHMARK( PL_stack_sp );
3425 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
3430 retop = CvSTART(cv);
3436 /* avoid premature free of label before popping it off stack */
3437 SvREFCNT_inc_NN(sv);
3440 label = SvPV_nomg_const(sv, label_len);
3441 label_flags = SvUTF8(sv);
3444 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
3445 /* goto LABEL or dump LABEL */
3446 label = cPVOP->op_pv;
3447 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
3448 label_len = strlen(label);
3450 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
3455 OP *gotoprobe = NULL;
3456 bool leaving_eval = FALSE;
3457 bool in_block = FALSE;
3458 bool pseudo_block = FALSE;
3459 PERL_CONTEXT *last_eval_cx = NULL;
3463 PL_lastgotoprobe = NULL;
3465 for (ix = cxstack_ix; ix >= 0; ix--) {
3467 switch (CxTYPE(cx)) {
3469 leaving_eval = TRUE;
3470 if (!CxEVALBLOCK(cx)) {
3471 gotoprobe = (last_eval_cx ?
3472 last_eval_cx->blk_eval.old_eval_root :
3477 /* else fall through */
3478 case CXt_LOOP_PLAIN:
3479 case CXt_LOOP_LAZYIV:
3480 case CXt_LOOP_LAZYSV:
3485 gotoprobe = OpSIBLING(cx->blk_oldcop);
3491 gotoprobe = OpSIBLING(cx->blk_oldcop);
3494 gotoprobe = PL_main_root;
3497 gotoprobe = CvROOT(cx->blk_sub.cv);
3498 pseudo_block = cBOOL(CxMULTICALL(cx));
3502 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3504 /* diag_listed_as: Can't "%s" out of a "defer" block */
3505 DIE(aTHX_ "Can't \"%s\" out of a \"%s\" block", "goto", S_defer_blockname(cx));
3508 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3509 CxTYPE(cx), (long) ix);
3510 gotoprobe = PL_main_root;
3516 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3517 enterops, enterops + GOTO_DEPTH);
3520 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3521 sibl1->op_type == OP_UNSTACK &&
3522 (sibl2 = OpSIBLING(sibl1)))
3524 retop = dofindlabel(sibl2,
3525 label, label_len, label_flags, enterops,
3526 enterops + GOTO_DEPTH);
3532 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3533 PL_lastgotoprobe = gotoprobe;
3536 DIE(aTHX_ "Can't find label %" UTF8f,
3537 UTF8fARG(label_flags, label_len, label));
3539 /* if we're leaving an eval, check before we pop any frames
3540 that we're not going to punt, otherwise the error
3543 if (leaving_eval && *enterops && enterops[1]) {
3545 for (i = 1; enterops[i]; i++)
3546 S_check_op_type(aTHX_ enterops[i]);
3549 if (*enterops && enterops[1]) {
3550 I32 i = enterops[1] != UNENTERABLE
3551 && enterops[1]->op_type == OP_ENTER && in_block
3555 deprecate_fatal_in(WARN_DEPRECATED__GOTO_CONSTRUCT,
3557 "Use of \"goto\" to jump into a construct");
3560 /* pop unwanted frames */
3562 if (ix < cxstack_ix) {
3564 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3570 /* push wanted frames */
3572 if (*enterops && enterops[1]) {
3573 OP * const oldop = PL_op;
3574 ix = enterops[1] != UNENTERABLE
3575 && enterops[1]->op_type == OP_ENTER && in_block
3578 for (; enterops[ix]; ix++) {
3579 PL_op = enterops[ix];
3580 S_check_op_type(aTHX_ PL_op);
3581 DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n",
3583 PL_op->op_ppaddr(aTHX);
3591 if (!retop) retop = PL_main_start;
3593 PL_restartop = retop;
3594 PL_do_undump = TRUE;
3598 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3599 PL_do_undump = FALSE;
3607 PP_wrapped(pp_exit, 1, 0)
3615 anum = 0; (void)POPs;
3621 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3624 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3627 PL_exit_flags |= PERL_EXIT_EXPECTED;
3629 PUSHs(&PL_sv_undef);
3636 S_save_lines(pTHX_ AV *array, SV *sv)
3638 const char *s = SvPVX_const(sv);
3639 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3642 PERL_ARGS_ASSERT_SAVE_LINES;
3644 while (s && s < send) {
3646 SV * const tmpstr = newSV_type(SVt_PVMG);
3648 t = (const char *)memchr(s, '\n', send - s);
3654 sv_setpvn_fresh(tmpstr, s, t - s);
3655 av_store(array, line++, tmpstr);
3663 Interpose, for the current op and RUNOPS loop,
3665 - a new JMPENV stack catch frame, and
3666 - an inner RUNOPS loop to run all the remaining ops following the
3669 Then handle any exceptions raised while in that loop.
3670 For a caught eval at this level, re-enter the loop with the specified
3671 restart op (i.e. the op following the OP_LEAVETRY etc); otherwise re-throw
3674 docatch() is intended to be used like this:
3679 return docatch(Perl_pp_entertry);
3681 ... rest of function ...
3682 return PL_op->op_next;
3685 If a new catch frame isn't needed, the op behaves normally. Otherwise it
3686 calls docatch(), which recursively calls pp_entertry(), this time with
3687 CATCH_GET() false, so the rest of the body of the entertry is run. Then
3688 docatch() calls CALLRUNOPS() which executes all the ops following the
3689 entertry. When the loop finally finishes, control returns to docatch(),
3690 which pops the JMPENV and returns to the parent pp_entertry(), which
3691 itself immediately returns. Note that *all* subsequent ops are run within
3692 the inner RUNOPS loop, not just the body of the eval. For example, in
3694 sub TIEARRAY { eval {1}; my $x }
3697 at the point the 'my' is executed, the C stack will look something like:
3700 #9 perl_run() # JMPENV_PUSH level 1 here
3702 #7 Perl_runops_standard() # main RUNOPS loop
3705 #4 Perl_runops_standard() # unguarded RUNOPS loop: no new JMPENV
3706 #3 Perl_pp_entertry()
3707 #2 S_docatch() # JMPENV_PUSH level 2 here
3708 #1 Perl_runops_standard() # docatch()'s RUNOPs loop
3711 Basically, any section of the perl core which starts a RUNOPS loop may
3712 make a promise that it will catch any exceptions and restart the loop if
3713 necessary. If it's not prepared to do that (like call_sv() isn't), then
3714 it sets CATCH_GET() to true, so that any later eval-like code knows to
3715 set up a new handler and loop (via docatch()).
3717 See L<perlinterp/"Exception handing"> for further details.
3723 S_docatch(pTHX_ Perl_ppaddr_t firstpp)
3726 OP * const oldop = PL_op;
3734 case 0: /* normal flow-of-control return from JMPENV_PUSH */
3736 /* re-run the current op, this time executing the full body of the
3738 PL_op = firstpp(aTHX);
3745 case 3: /* an exception raised within an eval */
3746 if (PL_restartjmpenv == PL_top_env) {
3747 /* die caught by an inner eval - continue inner loop */
3751 PL_restartjmpenv = NULL;
3752 PL_op = PL_restartop;
3761 JMPENV_JUMP(ret); /* re-throw the exception */
3762 NOT_REACHED; /* NOTREACHED */
3771 =for apidoc find_runcv
3773 Locate the CV corresponding to the currently executing sub or eval.
3774 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3775 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3776 entered. (This allows debuggers to eval in the scope of the breakpoint
3777 rather than in the scope of the debugger itself.)
3783 Perl_find_runcv(pTHX_ U32 *db_seqp)
3785 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3788 /* If this becomes part of the API, it might need a better name. */
3790 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3797 PL_curcop == &PL_compiling
3799 : PL_curcop->cop_seq;
3801 for (si = PL_curstackinfo; si; si = si->si_prev) {
3803 for (ix = si->si_cxix; ix >= 0; ix--) {
3804 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3806 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3807 cv = cx->blk_sub.cv;
3808 /* skip DB:: code */
3809 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3810 *db_seqp = cx->blk_oldcop->cop_seq;
3813 if (cx->cx_type & CXp_SUB_RE)
3816 else if (CxTYPE(cx) == CXt_EVAL && !CxEVALBLOCK(cx))
3817 cv = cx->blk_eval.cv;
3820 case FIND_RUNCV_padid_eq:
3822 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3825 case FIND_RUNCV_level_eq:
3826 if (level++ != arg) continue;
3834 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3840 * Run yyparse() in a setjmp wrapper. Returns:
3841 * 0: yyparse() successful
3842 * 1: yyparse() failed
3845 * This is used to trap Perl_croak() calls that are executed
3846 * during the compilation process and before the code has been
3847 * completely compiled. It is expected to be called from
3848 * doeval_compile() only. The parameter 'caller_op' is
3849 * only used in DEBUGGING to validate the logic is working
3852 * See also try_run_unitcheck().
3856 S_try_yyparse(pTHX_ int gramtype, OP *caller_op)
3858 /* if we die during compilation PL_restartop and PL_restartjmpenv
3859 * will be set by Perl_die_unwind(). We need to restore their values
3860 * if that happens as they are intended for the case where the code
3861 * compiles and dies during execution, not where it dies during
3862 * compilation. PL_restartop and caller_op->op_next should be the
3863 * same anyway, and when compilation fails then caller_op->op_next is
3864 * used as the next op after the compile.
3866 JMPENV *restartjmpenv = PL_restartjmpenv;
3867 OP *restartop = PL_restartop;
3870 PERL_UNUSED_ARG(caller_op); /* only used in debugging builds */
3872 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3876 ret = yyparse(gramtype) ? 1 : 0;
3879 /* yyparse() died and we trapped the error. We need to restore
3880 * the old PL_restartjmpenv and PL_restartop values. */
3881 assert(PL_restartop == caller_op->op_next); /* we expect these to match */
3882 PL_restartjmpenv = restartjmpenv;
3883 PL_restartop = restartop;
3888 NOT_REACHED; /* NOTREACHED */
3894 /* S_try_run_unitcheck()
3896 * Run PL_unitcheckav in a setjmp wrapper via call_list.
3898 * 0: unitcheck blocks ran without error
3899 * 3: a unitcheck block died
3901 * This is used to trap Perl_croak() calls that are executed
3902 * during UNITCHECK blocks executed after the compilation
3903 * process has completed but before the code itself has been
3904 * executed via the normal run loops. It is expected to be called
3905 * from doeval_compile() only. The parameter 'caller_op' is
3906 * only used in DEBUGGING to validate the logic is working
3909 * See also try_yyparse().
3912 S_try_run_unitcheck(pTHX_ OP* caller_op)
3914 /* if we die during compilation PL_restartop and PL_restartjmpenv
3915 * will be set by Perl_die_unwind(). We need to restore their values
3916 * if that happens as they are intended for the case where the code
3917 * compiles and dies during execution, not where it dies during
3918 * compilation. UNITCHECK runs after compilation completes, and
3919 * if it dies we will execute the PL_restartop anyway via the
3920 * failed compilation code path. PL_restartop and caller_op->op_next
3921 * should be the same anyway, and when compilation fails then
3922 * caller_op->op_next is used as the next op after the compile.
3924 JMPENV *restartjmpenv = PL_restartjmpenv;
3925 OP *restartop = PL_restartop;
3928 PERL_UNUSED_ARG(caller_op); /* only used in debugging builds */
3930 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3934 call_list(PL_scopestack_ix, PL_unitcheckav);
3937 /* call_list died */
3938 /* call_list() died and we trapped the error. We should restore
3939 * the old PL_restartjmpenv and PL_restartop values, as they are
3940 * used only in the case where the code was actually run.
3941 * The assert validates that we will still execute the PL_restartop.
3943 assert(PL_restartop == caller_op->op_next); /* we expect these to match */
3944 PL_restartjmpenv = restartjmpenv;
3945 PL_restartop = restartop;
3950 NOT_REACHED; /* NOTREACHED */
3956 /* Compile a require/do or an eval ''.
3958 * outside is the lexically enclosing CV (if any) that invoked us.
3959 * seq is the current COP scope value.
3960 * hh is the saved hints hash, if any.
3962 * Returns a bool indicating whether the compile was successful; if so,
3963 * PL_eval_start contains the first op of the compiled code; otherwise,
3966 * This function is called from two places: pp_require and pp_entereval.
3967 * These can be distinguished by whether PL_op is entereval.
3971 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3973 OP * const saveop = PL_op;
3974 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3975 COP * const oldcurcop = PL_curcop;
3976 bool in_require = (saveop->op_type == OP_REQUIRE);
3980 PL_in_eval = (in_require
3981 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3983 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3984 ? EVAL_RE_REPARSING : 0)));
3986 PUSHMARK(PL_stack_sp);
3988 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3990 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3991 CX_CUR()->blk_eval.cv = evalcv;
3992 CX_CUR()->blk_gimme = gimme;
3994 CvOUTSIDE_SEQ(evalcv) = seq;
3995 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3997 /* set up a scratch pad */
3999 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
4000 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
4003 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
4005 /* make sure we compile in the right package */
4007 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
4008 SAVEGENERICSV(PL_curstash);
4009 PL_curstash = (HV *)CopSTASH(PL_curcop);
4010 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
4012 SvREFCNT_inc_simple_void(PL_curstash);
4013 save_item(PL_curstname);
4014 sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash));
4017 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
4018 SAVESPTR(PL_beginav);
4019 PL_beginav = newAV();
4020 SAVEFREESV(PL_beginav);
4021 SAVESPTR(PL_unitcheckav);
4022 PL_unitcheckav = newAV();
4023 SAVEFREESV(PL_unitcheckav);
4026 ENTER_with_name("evalcomp");
4027 SAVESPTR(PL_compcv);
4030 /* try to compile it */
4032 PL_eval_root = NULL;
4033 PL_curcop = &PL_compiling;
4034 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
4035 PL_in_eval |= EVAL_KEEPERR;
4041 PL_hints = HINTS_DEFAULT;
4042 PL_prevailing_version = 0;
4043 hv_clear(GvHV(PL_hintgv));
4047 PL_hints = saveop->op_private & OPpEVAL_COPHH
4048 ? oldcurcop->cop_hints : (U32)saveop->op_targ;
4050 /* making 'use re eval' not be in scope when compiling the
4051 * qr/mabye_has_runtime_code_block/ ensures that we don't get
4052 * infinite recursion when S_has_runtime_code() gives a false
4053 * positive: the second time round, HINT_RE_EVAL isn't set so we
4054 * don't bother calling S_has_runtime_code() */
4055 if (PL_in_eval & EVAL_RE_REPARSING)
4056 PL_hints &= ~HINT_RE_EVAL;
4059 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
4060 SvREFCNT_dec(GvHV(PL_hintgv));
4061 GvHV(PL_hintgv) = hh;
4062 FETCHFEATUREBITSHH(hh);
4065 SAVECOMPILEWARNINGS();
4067 if (PL_dowarn & G_WARN_ALL_ON)
4068 PL_compiling.cop_warnings = pWARN_ALL ;
4069 else if (PL_dowarn & G_WARN_ALL_OFF)
4070 PL_compiling.cop_warnings = pWARN_NONE ;
4072 PL_compiling.cop_warnings = pWARN_STD ;
4075 PL_compiling.cop_warnings =
4076 DUP_WARNINGS(oldcurcop->cop_warnings);
4077 cophh_free(CopHINTHASH_get(&PL_compiling));
4078 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
4079 /* The label, if present, is the first entry on the chain. So rather
4080 than writing a blank label in front of it (which involves an
4081 allocation), just use the next entry in the chain. */
4082 PL_compiling.cop_hints_hash
4083 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
4084 /* Check the assumption that this removed the label. */
4085 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
4088 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
4091 CALL_BLOCK_HOOKS(bhk_eval, saveop);
4093 /* we should never be CATCH_GET true here, as our immediate callers should
4094 * always handle that case. */
4096 /* compile the code */
4099 yystatus = (!in_require)
4100 ? S_try_yyparse(aTHX_ GRAMPROG, saveop)
4101 : yyparse(GRAMPROG);
4103 if (yystatus || PL_parser->error_count || !PL_eval_root) {
4108 if (yystatus != 3) {
4109 /* note that if yystatus == 3, then the require/eval died during
4110 * compilation, so the EVAL CX block has already been popped, and
4111 * various vars restored. This block applies similar steps after
4112 * the other "failed to compile" cases in yyparse, eg, where
4113 * yystatus=1, "failed, but did not die". */
4116 invoke_exception_hook(ERRSV,FALSE);
4118 op_free(PL_eval_root);
4119 PL_eval_root = NULL;
4121 rpp_popfree_to(PL_stack_base + POPMARK); /* pop original mark */
4123 assert(CxTYPE(cx) == CXt_EVAL);
4124 /* If we are in an eval we need to make sure that $SIG{__DIE__}
4125 * handler is invoked so we simulate that part of the
4126 * Perl_die_unwind() process. In a require we will croak
4127 * so it will happen there. */
4128 /* pop the CXt_EVAL, and if was a require, croak */
4129 S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
4133 /* die_unwind() re-croaks when in require, having popped the
4134 * require EVAL context. So we should never catch a require
4136 assert(!in_require);
4139 if (!*(SvPV_nolen_const(errsv)))
4140 sv_setpvs(errsv, "Compilation error");
4142 if (gimme == G_SCALAR) {
4143 if (yystatus == 3) {
4144 /* die_unwind already pushed undef in scalar context */
4145 assert(*PL_stack_sp == &PL_sv_undef);
4148 rpp_xpush_1(&PL_sv_undef);
4154 /* Compilation successful. Now clean up */
4156 LEAVE_with_name("evalcomp");
4158 CopLINE_set(&PL_compiling, 0);
4159 SAVEFREEOP(PL_eval_root);
4160 cv_forget_slab(evalcv);
4162 DEBUG_x(dump_eval());
4164 /* Register with debugger: */
4165 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
4166 CV * const cv = get_cvs("DB::postponed", 0);
4168 PUSHMARK(PL_stack_sp);
4169 rpp_xpush_1(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4170 call_sv(MUTABLE_SV(cv), G_DISCARD);
4174 if (PL_unitcheckav && av_count(PL_unitcheckav)>0) {
4175 OP *es = PL_eval_start;
4176 /* TODO: are we sure we shouldn't do S_try_run_unitcheck()
4177 * when `in_require` is true? */
4179 call_list(PL_scopestack_ix, PL_unitcheckav);
4181 else if (S_try_run_unitcheck(aTHX_ saveop)) {
4182 /* there was an error! */
4188 if (!*(SvPV_nolen_const(errsv))) {
4189 /* This happens when using:
4190 * eval qq# UNITCHECK { die "\x00"; } #;
4192 sv_setpvs(errsv, "Unit check error");
4195 if (gimme != G_LIST)
4196 rpp_xpush_1(&PL_sv_undef);
4202 CvDEPTH(evalcv) = 1;
4203 rpp_popfree_to(PL_stack_base + POPMARK); /* pop original mark */
4204 PL_op = saveop; /* The caller may need it. */
4205 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
4211 /* Return NULL if the file doesn't exist or isn't a file;
4212 * else return PerlIO_openn().
4216 S_check_type_and_open(pTHX_ SV *name)
4221 const char *p = SvPV_const(name, len);
4224 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
4226 /* checking here captures a reasonable error message when
4227 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
4228 * user gets a confusing message about looking for the .pmc file
4229 * rather than for the .pm file so do the check in S_doopen_pm when
4230 * PMC is on instead of here. S_doopen_pm calls this func.
4231 * This check prevents a \0 in @INC causing problems.
4233 #ifdef PERL_DISABLE_PMC
4234 if (!IS_SAFE_PATHNAME(p, len, "require"))
4238 /* on Win32 stat is expensive (it does an open() and close() twice and
4239 a couple other IO calls), the open will fail with a dir on its own with
4240 errno EACCES, so only do a stat to separate a dir from a real EACCES
4241 caused by user perms */
4243 st_rc = PerlLIO_stat(p, &st);
4249 if(S_ISBLK(st.st_mode)) {
4253 else if(S_ISDIR(st.st_mode)) {
4262 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
4264 /* EACCES stops the INC search early in pp_require to implement
4265 feature RT #113422 */
4266 if(!retio && errno == EACCES) { /* exists but probably a directory */
4268 st_rc = PerlLIO_stat(p, &st);
4270 if(S_ISDIR(st.st_mode))
4272 else if(S_ISBLK(st.st_mode))
4283 /* doopen_pm(): return the equivalent of PerlIO_openn() on the given name,
4284 * but first check for bad names (\0) and non-files.
4285 * Also if the filename ends in .pm and unless PERL_DISABLE_PMC,
4286 * try loading Foo.pmc first.
4288 #ifndef PERL_DISABLE_PMC
4290 S_doopen_pm(pTHX_ SV *name)
4293 const char *p = SvPV_const(name, namelen);
4295 PERL_ARGS_ASSERT_DOOPEN_PM;
4297 /* check the name before trying for the .pmc name to avoid the
4298 * warning referring to the .pmc which the user probably doesn't
4299 * know or care about
4301 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
4304 if (memENDPs(p, namelen, ".pm")) {
4305 SV *const pmcsv = sv_newmortal();
4308 SvSetSV_nosteal(pmcsv,name);
4309 sv_catpvs(pmcsv, "c");
4311 pmcio = check_type_and_open(pmcsv);
4315 return check_type_and_open(name);
4318 # define doopen_pm(name) check_type_and_open(name)
4319 #endif /* !PERL_DISABLE_PMC */
4321 /* require doesn't search in @INC for absolute names, or when the name is
4322 explicitly relative the current directory: i.e. ./, ../ */
4323 PERL_STATIC_INLINE bool
4324 S_path_is_searchable(const char *name)
4326 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
4328 if (PERL_FILE_IS_ABSOLUTE(name)
4330 || (*name == '.' && ((name[1] == '/' ||
4331 (name[1] == '.' && name[2] == '/'))
4332 || (name[1] == '\\' ||
4333 ( name[1] == '.' && name[2] == '\\')))
4336 || (*name == '.' && (name[1] == '/' ||
4337 (name[1] == '.' && name[2] == '/')))
4348 /* implement 'require 5.010001' */
4351 S_require_version(pTHX_ SV *sv)
4353 sv = sv_2mortal(new_version(sv));
4356 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
4357 upg_version(PL_patchlevel, TRUE);
4358 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
4359 if ( vcmp(sv,PL_patchlevel) <= 0 )
4360 DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
4361 SVfARG(sv_2mortal(vnormal(sv))),
4362 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
4366 if ( vcmp(sv,PL_patchlevel) > 0 ) {
4369 SV * const req = SvRV(sv);
4370 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
4372 /* get the left hand term */
4373 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
4375 first = SvIV(*av_fetch(lav,0,0));
4376 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
4377 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
4378 || av_count(lav) > 2 /* FP with > 3 digits */
4379 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
4381 DIE(aTHX_ "Perl %" SVf " required--this is only "
4382 "%" SVf ", stopped",
4383 SVfARG(sv_2mortal(vnormal(req))),
4384 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
4387 else { /* probably 'use 5.10' or 'use 5.8' */
4391 if (av_count(lav) > 1)
4392 second = SvIV(*av_fetch(lav,1,0));
4394 second /= second >= 600 ? 100 : 10;
4395 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
4396 (int)first, (int)second);
4397 upg_version(hintsv, TRUE);
4399 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)"
4400 "--this is only %" SVf ", stopped",
4401 SVfARG(sv_2mortal(vnormal(req))),
4402 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
4403 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
4409 *++PL_stack_sp = &PL_sv_yes;
4414 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
4415 * The first form will have already been converted at compile time to
4417 * sv is still on the stack at this point. */
4420 S_require_file(pTHX_ SV *sv)
4428 int vms_unixname = 0;
4431 /* tryname is the actual pathname (with @INC prefix) which was loaded.
4432 * It's stored as a value in %INC, and used for error messages */
4433 const char *tryname = NULL;
4434 SV *namesv = NULL; /* SV equivalent of tryname */
4435 const U8 gimme = GIMME_V;
4436 int filter_has_file = 0;
4437 PerlIO *tryrsfp = NULL;
4438 SV *filter_cache = NULL;
4439 SV *filter_state = NULL;
4440 SV *filter_sub = NULL;
4444 bool path_searchable;
4445 I32 old_savestack_ix;
4446 const bool op_is_require = PL_op->op_type == OP_REQUIRE;
4447 const char *const op_name = op_is_require ? "require" : "do";
4448 SV ** svp_cached = NULL;
4450 assert(op_is_require || PL_op->op_type == OP_DOFILE);
4453 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
4454 name = SvPV_nomg_const(sv, len);
4455 if (!(name && len > 0 && *name))
4456 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
4459 PL_hook__require__before
4460 && SvROK(PL_hook__require__before)
4461 && SvTYPE(SvRV(PL_hook__require__before)) == SVt_PVCV
4463 SV* name_sv = sv_mortalcopy(sv);
4464 SV *post_hook__require__before_sv = NULL;
4466 ENTER_with_name("call_PRE_REQUIRE");
4468 PUSHMARK(PL_stack_sp);
4469 rpp_xpush_1(name_sv); /* always use the object for method calls */
4470 call_sv(PL_hook__require__before, G_SCALAR);
4471 SV *rsv = *PL_stack_sp;
4472 if (SvOK(rsv) && SvROK(rsv) && SvTYPE(SvRV(rsv)) == SVt_PVCV) {
4473 /* the RC++ preserves it across the popping and/or FREETMPS
4475 post_hook__require__before_sv = SvREFCNT_inc_simple_NN(rsv);
4478 if (!sv_streq(name_sv,sv)) {
4479 /* they modified the name argument, so do some sleight of hand */
4480 name = SvPV_nomg_const(name_sv, len);
4481 if (!(name && len > 0 && *name))
4482 DIE(aTHX_ "Missing or undefined argument to %s via %%{^HOOK}{require__before}",
4487 LEAVE_with_name("call_PRE_REQUIRE");
4488 if (post_hook__require__before_sv) {
4489 SV *nsv = newSVsv(sv);
4490 MORTALDESTRUCTOR_SV(post_hook__require__before_sv, nsv);
4491 SvREFCNT_dec_NN(nsv);
4492 SvREFCNT_dec_NN(post_hook__require__before_sv);
4496 PL_hook__require__after
4497 && SvROK(PL_hook__require__after)
4498 && SvTYPE(SvRV(PL_hook__require__after)) == SVt_PVCV
4500 SV *nsv = newSVsv(sv);
4501 MORTALDESTRUCTOR_SV(PL_hook__require__after, nsv);
4502 SvREFCNT_dec_NN(nsv);
4506 /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */
4507 if (op_is_require) {
4508 /* can optimize to only perform one single lookup */
4509 svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0);
4511 (SvGETMAGIC(*svp_cached), SvOK(*svp_cached)))
4513 rpp_replace_1_1(&PL_sv_yes);
4519 if (!IS_SAFE_PATHNAME(name, len, op_name)) {
4520 if (!op_is_require) {
4522 rpp_replace_1_1(&PL_sv_undef);
4525 DIE(aTHX_ "Can't locate %s: %s",
4526 pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
4527 NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
4530 TAINT_PROPER(op_name);
4532 path_searchable = path_is_searchable(name);
4535 /* The key in the %ENV hash is in the syntax of file passed as the argument
4536 * usually this is in UNIX format, but sometimes in VMS format, which
4537 * can result in a module being pulled in more than once.
4538 * To prevent this, the key must be stored in UNIX format if the VMS
4539 * name can be translated to UNIX.
4543 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4545 unixlen = strlen(unixname);
4551 /* if not VMS or VMS name can not be translated to UNIX, pass it
4554 unixname = (char *) name;
4557 if (op_is_require) {
4558 /* reuse the previous hv_fetch result if possible */
4559 SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4561 /* we already did a get magic if this was cached */
4565 rpp_replace_1_1(&PL_sv_yes);
4569 DIE(aTHX_ "Attempt to reload %s aborted.\n"
4570 "Compilation failed in require", unixname);
4573 /*XXX OPf_KIDS should always be true? -dapm 4/2017 */
4574 if (PL_op->op_flags & OPf_KIDS) {
4575 SVOP * const kid = cSVOPx(cUNOP->op_first);
4577 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4578 /* Make sure that a bareword module name (e.g. ::Foo::Bar)
4579 * doesn't map to a naughty pathname like /Foo/Bar.pm.
4580 * Note that the parser will normally detect such errors
4581 * at compile time before we reach here, but
4582 * Perl_load_module() can fake up an identical optree
4583 * without going near the parser, and being able to put
4584 * anything as the bareword. So we include a duplicate set
4585 * of checks here at runtime.
4587 const STRLEN package_len = len - 3;
4588 const char slashdot[2] = {'/', '.'};
4590 const char backslashdot[2] = {'\\', '.'};
4593 /* Disallow *purported* barewords that map to absolute
4594 filenames, filenames relative to the current or parent
4595 directory, or (*nix) hidden filenames. Also sanity check
4596 that the generated filename ends .pm */
4597 if (!path_searchable || len < 3 || name[0] == '.'
4598 || !memEQs(name + package_len, len - package_len, ".pm"))
4599 DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv);
4600 if (memchr(name, 0, package_len)) {
4601 /* diag_listed_as: Bareword in require contains "%s" */
4602 DIE(aTHX_ "Bareword in require contains \"\\0\"");
4604 if (ninstr(name, name + package_len, slashdot,
4605 slashdot + sizeof(slashdot))) {
4606 /* diag_listed_as: Bareword in require contains "%s" */
4607 DIE(aTHX_ "Bareword in require contains \"/.\"");
4610 if (ninstr(name, name + package_len, backslashdot,
4611 backslashdot + sizeof(backslashdot))) {
4612 /* diag_listed_as: Bareword in require contains "%s" */
4613 DIE(aTHX_ "Bareword in require contains \"\\.\"");
4620 PERL_DTRACE_PROBE_FILE_LOADING(unixname);
4622 /* Try to locate and open a file, possibly using @INC */
4624 /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load
4625 * the file directly rather than via @INC ... */
4626 if (!path_searchable) {
4627 /* At this point, name is SvPVX(sv) */
4629 tryrsfp = doopen_pm(sv);
4632 /* ... but if we fail, still search @INC for code references;
4633 * these are applied even on non-searchable paths (except
4634 * if we got EACESS).
4636 * For searchable paths, just search @INC normally
4638 AV *inc_checked = (AV*)sv_2mortal((SV*)newAV());
4639 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
4645 AV *incdir_av = (AV*)sv_2mortal((SV*)newAV());
4646 SV *nsv = sv; /* non const copy we can change if necessary */
4647 namesv = newSV_type(SVt_PV);
4648 AV *inc_ar = GvAVn(PL_incgv);
4649 SSize_t incdir_continue_inc_idx = -1;
4653 (AvFILL(incdir_av)>=0 /* we have INCDIR items pending */
4654 || inc_idx <= AvFILL(inc_ar)); /* @INC entries remain */
4659 /* do we have any pending INCDIR items? */
4660 if (AvFILL(incdir_av)>=0) {
4661 /* yep, shift it out */
4662 dirsv = av_shift(incdir_av);
4663 if (AvFILL(incdir_av)<0) {
4664 /* incdir is now empty, continue from where
4665 * we left off after we process this entry */
4666 inc_idx = incdir_continue_inc_idx;
4669 dirsv = *av_fetch(inc_ar, inc_idx, TRUE);
4672 if (SvGMAGICAL(dirsv)) {
4674 dirsv = newSVsv_nomg(dirsv);
4676 /* on the other hand, since we aren't copying we do need
4678 SvREFCNT_inc(dirsv);
4683 av_push(inc_checked, dirsv);
4689 UV diruv = PTR2UV(SvRV(dirsv));
4691 if (SvTYPE(SvRV(loader)) == SVt_PVAV
4692 && !SvOBJECT(SvRV(loader)))
4694 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
4695 if (SvGMAGICAL(loader)) {
4697 SV *l = sv_newmortal();
4698 sv_setsv_nomg(l, loader);
4703 if (SvPADTMP(nsv)) {
4704 nsv = sv_newmortal();
4705 SvSetSV_nosteal(nsv,sv);
4708 const char *method = NULL;
4709 bool is_incdir = FALSE;
4710 SV * inc_idx_sv = save_scalar(PL_incgv);
4711 sv_setiv(inc_idx_sv,inc_idx);
4712 if (sv_isobject(loader)) {
4713 /* if it is an object and it has an INC method, then
4716 HV *pkg = SvSTASH(SvRV(loader));
4717 GV * gv = gv_fetchmethod_pvn_flags(pkg, "INC", 3, GV_AUTOLOAD);
4718 if (gv && isGV(gv)) {
4721 /* no point to autoload here, it would have been found above */
4722 gv = gv_fetchmethod_pvn_flags(pkg, "INCDIR", 6, 0);
4723 if (gv && isGV(gv)) {
4728 /* But if we have no method, check if this is a
4729 * coderef, if it is then we treat it as an
4730 * unblessed coderef would be treated: we
4731 * execute it. If it is some other and it is in
4732 * an array ref wrapper, then really we don't
4733 * know what to do with it, (why use the
4734 * wrapper?) and we throw an exception to help
4735 * debug. If it is not in a wrapper assume it
4736 * has an overload and treat it as a string.
4737 * Maybe in the future we can detect if it does
4738 * have overloading and throw an error if not.
4741 if (SvTYPE(SvRV(loader)) != SVt_PVCV) {
4742 if (amagic_applies(loader,string_amg,AMGf_unary))
4743 goto treat_as_string;
4745 croak("Can't locate object method \"INC\", nor"
4746 " \"INCDIR\" nor string overload via"
4747 " package %" HvNAMEf_QUOTEDPREFIX " %s"
4751 : "in object in ARRAY hook"
4758 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
4760 tryname = SvPVX_const(namesv);
4763 ENTER_with_name("call_INC_hook");
4765 PUSHMARK(PL_stack_sp);
4766 /* add the args array for method calls */
4767 bool add_dirsv = (method && (loader != dirsv));
4768 rpp_extend(2 + add_dirsv);
4770 /* always use the object for method calls */
4771 method ? loader : dirsv,
4777 count = call_method(method, G_LIST|G_EVAL);
4779 count = call_sv(loader, G_LIST|G_EVAL);
4785 SV **base = PL_stack_sp - count + 1;
4788 /* push the stringified returned items into the
4789 * incdir_av array for processing immediately
4790 * afterwards. we deliberately stringify or copy
4791 * "special" arguments, so that overload logic for
4792 * instance applies, but so that the end result is
4793 * stable. We speficially do *not* support returning
4794 * coderefs from an INCDIR call. */
4802 char *pv = SvPV(arg,l);
4803 arg = newSVpvn(pv,l);
4805 else if (SvGMAGICAL(arg)) {
4806 arg = newSVsv_nomg(arg);
4811 av_push(incdir_av, arg);
4813 /* We copy $INC into incdir_continue_inc_idx
4814 * so that when we finish processing the items
4815 * we just inserted into incdir_av we can continue
4816 * as though we had just finished executing the INCDIR
4817 * hook. We honour $INC here just like we would for
4818 * an INC hook, the hook might have rewritten @INC
4819 * at the same time as returning something to us.
4821 inc_idx_sv = GvSVn(PL_incgv);
4822 incdir_continue_inc_idx = SvOK(inc_idx_sv)
4823 ? SvIV(inc_idx_sv) : -1;
4830 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
4831 && !isGV_with_GP(SvRV(arg))) {
4832 filter_cache = SvRV(arg);
4839 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
4843 if (isGV_with_GP(arg)) {
4844 IO * const io = GvIO((const GV *)arg);
4849 tryrsfp = IoIFP(io);
4850 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
4851 PerlIO_close(IoOFP(io));
4862 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
4864 SvREFCNT_inc_simple_void_NN(filter_sub);
4867 filter_state = base[i];
4868 SvREFCNT_inc_simple_void(filter_state);
4872 if (!tryrsfp && (filter_cache || filter_sub)) {
4873 tryrsfp = PerlIO_open(BIT_BUCKET,
4877 rpp_popfree_to(base - 1);
4880 if (SvTRUE(errsv) && !SvROK(errsv)) {
4882 char *pv= SvPV(errsv,l);
4883 /* Heuristic to tell if this error message
4884 * includes the standard line number info:
4885 * check if the line ends in digit dot newline.
4886 * If it does then we add some extra info so
4887 * its obvious this is coming from a hook.
4888 * If it is a user generated error we try to
4889 * leave it alone. l>12 is to ensure the
4890 * other checks are in string, but also
4891 * accounts for "at ... line 1.\n" to a
4892 * certain extent. Really we should check
4893 * further, but this is good enough for back
4896 if (l>=12 && pv[l-1] == '\n' && pv[l-2] == '.' && isDIGIT(pv[l-3]))
4897 sv_catpvf(errsv, "%s %s hook died--halting @INC search",
4898 method ? method : "INC",
4899 method ? "method" : "sub");
4904 /* FREETMPS may free our filter_cache */
4905 SvREFCNT_inc_simple_void(filter_cache);
4908 Let the hook override which @INC entry we visit
4909 next by setting $INC to a different value than it
4910 was before we called the hook. If they have
4911 completely rewritten the array they might want us
4912 to start traversing from the beginning, which is
4913 represented by -1. We use undef as an equivalent of
4914 -1. This can't be used as a way to call a hook
4915 twice, as we still dedupe.
4916 We have to do this before we LEAVE, as we localized
4917 $INC before we called the hook.
4919 inc_idx_sv = GvSVn(PL_incgv);
4920 inc_idx = SvOK(inc_idx_sv) ? SvIV(inc_idx_sv) : -1;
4923 LEAVE_with_name("call_INC_hook");
4926 It is possible that @INC has been replaced and that inc_ar
4927 now points at a freed AV. So we have to refresh it from
4930 inc_ar = GvAVn(PL_incgv);
4932 /* Now re-mortalize it. */
4933 sv_2mortal(filter_cache);
4935 /* Adjust file name if the hook has set an %INC entry.
4936 This needs to happen after the FREETMPS above. */
4937 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
4938 /* we have to make sure that the value is not undef
4939 * or the empty string, if it is then we should not
4940 * set tryname to it as this will break error messages.
4942 * This might happen if an @INC hook evals the module
4943 * which was required in the first place and which
4944 * triggered the @INC hook, and that eval dies.
4945 * See https://github.com/Perl/perl5/issues/20535
4947 if (svp && SvOK(*svp)) {
4949 const char *tmp_pv = SvPV_const(*svp,len);
4950 /* we also guard against the deliberate empty string.
4951 * We do not guard against '0', if people want to set their
4952 * file name to 0 that is up to them. */
4962 filter_has_file = 0;
4963 filter_cache = NULL;
4965 SvREFCNT_dec_NN(filter_state);
4966 filter_state = NULL;
4969 SvREFCNT_dec_NN(filter_sub);
4975 if (path_searchable) {
4976 /* match against a plain @INC element (non-searchable
4977 * paths are only matched against refs in @INC) */
4981 dir = SvPV_nomg_const(dirsv, dirlen);
4987 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
4991 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4994 sv_setpv(namesv, unixdir);
4995 sv_catpv(namesv, unixname);
4997 /* The equivalent of
4998 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4999 but without the need to parse the format string, or
5000 call strlen on either pointer, and with the correct
5001 allocation up front. */
5003 char *tmp = SvGROW(namesv, dirlen + len + 2);
5005 memcpy(tmp, dir, dirlen);
5008 /* Avoid '<dir>//<file>' */
5009 if (!dirlen || *(tmp-1) != '/') {
5012 /* So SvCUR_set reports the correct length below */
5016 /* name came from an SV, so it will have a '\0' at the
5017 end that we can copy as part of this memcpy(). */
5018 memcpy(tmp, name, len + 1);
5020 SvCUR_set(namesv, dirlen + len + 1);
5024 TAINT_PROPER(op_name);
5025 tryname = SvPVX_const(namesv);
5026 tryrsfp = doopen_pm(namesv);
5028 if (tryname[0] == '.' && tryname[1] == '/') {
5030 while (*++tryname == '/') {}
5034 else if (errno == EMFILE || errno == EACCES) {
5035 /* no point in trying other paths if out of handles;
5036 * on the other hand, if we couldn't open one of the
5037 * files, then going on with the search could lead to
5038 * unexpected results; see perl #113422
5047 /* at this point we've ether opened a file (tryrsfp) or set errno */
5049 saved_errno = errno; /* sv_2mortal can realloc things */
5052 /* we failed; croak if require() or return undef if do() */
5053 if (op_is_require) {
5054 if(saved_errno == EMFILE || saved_errno == EACCES) {
5055 /* diag_listed_as: Can't locate %s */
5056 DIE(aTHX_ "Can't locate %s: %s: %s",
5057 name, tryname, Strerror(saved_errno));
5059 if (path_searchable) { /* did we lookup @INC? */
5061 SV *const msg = newSVpvs_flags("", SVs_TEMP);
5062 SV *const inc = newSVpvs_flags("", SVs_TEMP);
5063 for (i = 0; i <= AvFILL(inc_checked); i++) {
5064 SV **svp= av_fetch(inc_checked, i, TRUE);
5065 if (!svp || !*svp) continue;
5066 sv_catpvs(inc, " ");
5067 sv_catsv(inc, *svp);
5069 if (memENDPs(name, len, ".pm")) {
5070 const char *e = name + len - (sizeof(".pm") - 1);
5072 bool utf8 = cBOOL(SvUTF8(sv));
5074 /* if the filename, when converted from "Foo/Bar.pm"
5075 * form back to Foo::Bar form, makes a valid
5076 * package name (i.e. parseable by C<require
5077 * Foo::Bar>), then emit a hint.
5079 * this loop is modelled after the one in
5083 if (utf8 && isIDFIRST_utf8_safe(c, e)) {
5085 while (c < e && isIDCONT_utf8_safe(
5086 (const U8*) c, (const U8*) e))
5089 else if (isWORDCHAR_A(*c)) {
5090 while (c < e && isWORDCHAR_A(*c))
5099 if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
5100 sv_catpvs(msg, " (you may need to install the ");
5101 for (c = name; c < e; c++) {
5103 sv_catpvs(msg, "::");
5106 sv_catpvn(msg, c, 1);
5109 sv_catpvs(msg, " module)");
5112 else if (memENDs(name, len, ".h")) {
5113 sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
5115 else if (memENDs(name, len, ".ph")) {
5116 sv_catpvs(msg, " (did you run h2ph?)");
5119 /* diag_listed_as: Can't locate %s */
5121 "Can't locate %s in @INC%" SVf " (@INC entries checked:%" SVf ")",
5125 DIE(aTHX_ "Can't locate %s", name);
5128 #ifdef DEFAULT_INC_EXCLUDES_DOT
5132 /* the complication is to match the logic from doopen_pm() so
5133 * we don't treat do "sda1" as a previously successful "do".
5135 bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED__DOT_IN_INC)
5136 && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode)
5137 && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL;
5143 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED__DOT_IN_INC),
5144 "do \"%s\" failed, '.' is no longer in @INC; "
5145 "did you mean do \"./%s\"?",
5150 rpp_replace_1_1(&PL_sv_undef);
5155 SETERRNO(0, SS_NORMAL);
5157 rpp_popfree_1(); /* finished with sv now */
5159 /* Update %INC. Assume success here to prevent recursive requirement. */
5160 /* name is never assigned to again, so len is still strlen(name) */
5161 /* Check whether a hook in @INC has already filled %INC */
5163 (void)hv_store(GvHVn(PL_incgv),
5164 unixname, unixlen, newSVpv(tryname,0),0);
5166 /* store the hook in the sv, note we have to *copy* hook_sv,
5167 * we don't want modifications to it to change @INC - see GH #20577
5169 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
5171 (void)hv_store(GvHVn(PL_incgv),
5172 unixname, unixlen, newSVsv(hook_sv), 0 );
5175 /* Now parse the file */
5177 old_savestack_ix = PL_savestack_ix;
5178 SAVECOPFILE_FREE(&PL_compiling);
5179 CopFILE_set(&PL_compiling, tryname);
5180 lex_start(NULL, tryrsfp, 0);
5182 if (filter_sub || filter_cache) {
5183 /* We can use the SvPV of the filter PVIO itself as our cache, rather
5184 than hanging another SV from it. In turn, filter_add() optionally
5185 takes the SV to use as the filter (or creates a new SV if passed
5186 NULL), so simply pass in whatever value filter_cache has. */
5187 SV * const fc = filter_cache ? newSV_type(SVt_NULL) : NULL;
5189 if (fc) sv_copypv(fc, filter_cache);
5190 datasv = filter_add(S_run_user_filter, fc);
5191 IoLINES(datasv) = filter_has_file;
5192 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
5193 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
5196 /* switch to eval mode */
5198 cx = cx_pushblock(CXt_EVAL, gimme, PL_stack_sp, old_savestack_ix);
5199 cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
5201 SAVECOPLINE(&PL_compiling);
5202 CopLINE_set(&PL_compiling, 0);
5204 if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
5207 op = PL_op->op_next;
5209 PERL_DTRACE_PROBE_FILE_LOADED(unixname);
5215 /* also used for: pp_dofile() */
5219 /* If a suitable JMPENV catch frame isn't present, call docatch(),
5221 * - add such a frame, and
5222 * - start a new RUNOPS loop, which will (as the first op to run),
5223 * recursively call this pp function again.
5224 * The main body of this function is then executed by the inner call.
5227 return docatch(Perl_pp_require);
5230 SV *sv = *PL_stack_sp;
5232 /* these tail-called subs are responsible for popping sv off the
5234 return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
5235 ? S_require_version(aTHX_ sv)
5236 : S_require_file(aTHX_ sv);
5241 /* This is a op added to hold the hints hash for
5242 pp_entereval. The hash can be modified by the code
5243 being eval'ed, so we return a copy instead. */
5248 rpp_push_1_norc(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
5259 char tbuf[TYPE_DIGITS(long) + 12];
5267 I32 old_savestack_ix;
5269 /* If a suitable JMPENV catch frame isn't present, call docatch(),
5271 * - add such a frame, and
5272 * - start a new RUNOPS loop, which will (as the first op to run),
5273 * recursively call this pp function again.
5274 * The main body of this function is then executed by the inner call.
5277 return docatch(Perl_pp_entereval);
5282 was = PL_breakable_sub_gen;
5283 saved_delete = FALSE;
5287 bytes = PL_op->op_private & OPpEVAL_BYTES;
5289 if (PL_op->op_private & OPpEVAL_HAS_HH) {
5290 saved_hh = MUTABLE_HV(rpp_pop_1_norc());
5292 else if (PL_hints & HINT_LOCALIZE_HH || (
5293 PL_op->op_private & OPpEVAL_COPHH
5294 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
5296 saved_hh = cop_hints_2hv(PL_curcop, 0);
5297 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
5301 /* make sure we've got a plain PV (no overload etc) before testing
5302 * for taint. Making a copy here is probably overkill, but better
5303 * safe than sorry */
5305 const char * const p = SvPV_const(sv, len);
5307 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
5308 lex_flags |= LEX_START_COPIED;
5310 if (bytes && SvUTF8(sv))
5311 SvPVbyte_force(sv, len);
5313 else if (bytes && SvUTF8(sv)) {
5314 /* Don't modify someone else's scalar */
5317 (void)sv_2mortal(sv);
5318 SvPVbyte_force(sv,len);
5319 lex_flags |= LEX_START_COPIED;
5322 TAINT_IF(SvTAINTED(sv));
5323 TAINT_PROPER("eval");
5325 old_savestack_ix = PL_savestack_ix;
5327 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
5328 ? LEX_IGNORE_UTF8_HINTS
5329 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
5333 rpp_popfree_1(); /* can free sv now */
5335 /* switch to eval mode */
5337 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
5338 SV * const temp_sv = sv_newmortal();
5339 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" LINE_Tf "]",
5340 (unsigned long)++PL_evalseq,
5341 CopFILE(PL_curcop), CopLINE(PL_curcop));
5342 tmpbuf = SvPVX(temp_sv);
5343 len = SvCUR(temp_sv);
5346 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
5347 SAVECOPFILE_FREE(&PL_compiling);
5348 CopFILE_set(&PL_compiling, tmpbuf+2);
5349 SAVECOPLINE(&PL_compiling);
5350 CopLINE_set(&PL_compiling, 1);
5351 /* special case: an eval '' executed within the DB package gets lexically
5352 * placed in the first non-DB CV rather than the current CV - this
5353 * allows the debugger to execute code, find lexicals etc, in the
5354 * scope of the code being debugged. Passing &seq gets find_runcv
5355 * to do the dirty work for us */
5356 runcv = find_runcv(&seq);
5359 cx = cx_pushblock((CXt_EVAL|CXp_REAL),
5360 gimme, PL_stack_sp, old_savestack_ix);
5361 cx_pusheval(cx, PL_op->op_next, NULL);
5363 /* prepare to compile string */
5365 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
5366 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
5368 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
5369 deleting the eval's FILEGV from the stash before gv_check() runs
5370 (i.e. before run-time proper). To work around the coredump that
5371 ensues, we always turn GvMULTI_on for any globals that were
5372 introduced within evals. See force_ident(). GSAR 96-10-12 */
5373 char *const safestr = savepvn(tmpbuf, len);
5374 SAVEDELETE(PL_defstash, safestr, len);
5375 saved_delete = TRUE;
5378 if (doeval_compile(gimme, runcv, seq, saved_hh)) {
5379 if (was != PL_breakable_sub_gen /* Some subs defined here. */
5380 ? PERLDB_LINE_OR_SAVESRC
5381 : PERLDB_SAVESRC_NOSUBS) {
5382 /* Retain the filegv we created. */
5383 } else if (!saved_delete) {
5384 char *const safestr = savepvn(tmpbuf, len);
5385 SAVEDELETE(PL_defstash, safestr, len);
5387 return PL_eval_start;
5389 /* We have already left the scope set up earlier thanks to the LEAVE
5390 in doeval_compile(). */
5391 if (was != PL_breakable_sub_gen /* Some subs defined here. */
5392 ? PERLDB_LINE_OR_SAVESRC
5393 : PERLDB_SAVESRC_INVALID) {
5394 /* Retain the filegv we created. */
5395 } else if (!saved_delete) {
5396 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
5398 if (PL_op->op_private & OPpEVAL_EVALSV)
5399 /* signal compiletime failure to our eval_sv() caller */
5400 *++PL_stack_sp = NULL;
5401 return PL_op->op_next;
5406 /* also tail-called by pp_return */
5415 bool override_return = FALSE; /* is feature 'module_true' in effect? */
5422 assert(CxTYPE(cx) == CXt_EVAL);
5424 oldsp = PL_stack_base + cx->blk_oldsp;
5425 gimme = cx->blk_gimme;
5427 bool is_require= CxOLD_OP_TYPE(cx) == OP_REQUIRE;
5429 /* We are in an require. Check if use feature 'module_true' is enabled,
5430 * and if so later on correct any returns from the require. */
5432 /* we might be called for an OP_LEAVEEVAL or OP_RETURN opcode
5433 * and the parse tree will look different for either case.
5434 * so find the right op to check later */
5435 if (OP_TYPE_IS_OR_WAS(PL_op, OP_RETURN)) {
5436 if (PL_op->op_flags & OPf_SPECIAL)
5437 override_return = true;
5439 else if ((PL_op->op_flags & OPf_KIDS) && OP_TYPE_IS_OR_WAS(PL_op, OP_LEAVEEVAL)){
5440 COP *old_pl_curcop = PL_curcop;
5441 OP *check = cUNOPx(PL_op)->op_first;
5443 /* ok, we found something to check, we need to scan through
5444 * it and find the last OP_NEXTSTATE it contains and then read the
5445 * feature state out of the COP data it contains.
5448 if (!OP_TYPE_IS(check,OP_STUB)) {
5449 const OP *kid = cLISTOPx(check)->op_first;
5450 const OP *last_state = NULL;
5452 for (; kid; kid = OpSIBLING(kid)) {
5454 OP_TYPE_IS_OR_WAS(kid, OP_NEXTSTATE)
5455 || OP_TYPE_IS_OR_WAS(kid, OP_DBSTATE)
5461 PL_curcop = cCOPx(last_state);
5462 if (FEATURE_MODULE_TRUE_IS_ENABLED) {
5463 override_return = TRUE;
5466 NOT_REACHED; /* NOTREACHED */
5470 NOT_REACHED; /* NOTREACHED */
5472 PL_curcop = old_pl_curcop;
5476 /* we might override this later if 'module_true' is enabled */
5478 && !(gimme == G_SCALAR
5479 ? SvTRUE_NN(*PL_stack_sp)
5480 : PL_stack_sp > oldsp);
5482 if (gimme == G_VOID) {
5483 rpp_popfree_to(oldsp);
5484 /* free now to avoid late-called destructors clobbering $@ */
5488 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
5490 /* the cx_popeval does a leavescope, which frees the optree associated
5491 * with eval, which if it frees the nextstate associated with
5492 * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
5493 * regex when running under 'use re Debug' because it needs PL_curcop
5494 * to get the current hints. So restore it early.
5496 PL_curcop = cx->blk_oldcop;
5498 /* grab this value before cx_popeval restores the old PL_in_eval */
5499 keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
5500 retop = cx->blk_eval.retop;
5501 evalcv = cx->blk_eval.cv;
5503 assert(CvDEPTH(evalcv) == 1);
5505 CvDEPTH(evalcv) = 0;
5507 if (override_return) {
5508 /* make sure that we use a standard return when feature 'module_load'
5509 * is enabled. Returns from require are problematic (consider what happens
5510 * when it is called twice) */
5511 if (gimme == G_SCALAR) {
5512 /* this following is an optimization of POPs()/PUSHs().
5513 * and does the same thing with less bookkeeping */
5514 *PL_stack_sp = &PL_sv_yes;
5516 assert(gimme == G_VOID || gimme == G_SCALAR);
5520 /* pop the CXt_EVAL, and if a require failed, croak */
5521 S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
5529 /* Ops that implement try/catch syntax
5530 * Note the asymmetry here:
5531 * pp_entertrycatch does two pushblocks
5532 * pp_leavetrycatch pops only the outer one; the inner one is popped by
5533 * pp_poptry or by stack-unwind of die within the try block
5536 PP(pp_entertrycatch)
5539 const U8 gimme = GIMME_V;
5541 /* If a suitable JMPENV catch frame isn't present, call docatch(),
5543 * - add such a frame, and
5544 * - start a new RUNOPS loop, which will (as the first op to run),
5545 * recursively call this pp function again.
5546 * The main body of this function is then executed by the inner call.
5549 return docatch(Perl_pp_entertrycatch);
5553 Perl_pp_enter(aTHX); /* performs cx_pushblock(CXt_BLOCK, ...) */
5555 save_scalar(PL_errgv);
5558 cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK|CXp_TRY), gimme,
5559 PL_stack_sp, PL_savestack_ix);
5560 cx_pushtry(cx, cLOGOP->op_other);
5562 PL_in_eval = EVAL_INEVAL;
5567 PP(pp_leavetrycatch)
5569 /* leavetrycatch is leave */
5570 return Perl_pp_leave(aTHX);
5575 /* poptry is leavetry */
5576 return Perl_pp_leavetry(aTHX);
5583 save_clearsv(&(PAD_SVl(PL_op->op_targ)));
5584 sv_setsv(TARG, ERRSV);
5587 return cLOGOP->op_other;
5590 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
5591 close to the related Perl_create_eval_scope. */
5593 Perl_delete_eval_scope(pTHX)
5604 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
5605 also needed by Perl_fold_constants. */
5607 Perl_create_eval_scope(pTHX_ OP *retop, SV **sp, U32 flags)
5610 const U8 gimme = GIMME_V;
5612 PERL_ARGS_ASSERT_CREATE_EVAL_SCOPE;
5614 cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK), gimme,
5615 sp, PL_savestack_ix);
5616 cx_pusheval(cx, retop, NULL);
5618 PL_in_eval = EVAL_INEVAL;
5619 if (flags & G_KEEPERR)
5620 PL_in_eval |= EVAL_KEEPERR;
5623 if (flags & G_FAKINGEVAL) {
5624 PL_eval_root = PL_op; /* Only needed so that goto works right. */
5630 OP *retop = cLOGOP->op_other->op_next;
5632 /* If a suitable JMPENV catch frame isn't present, call docatch(),
5634 * - add such a frame, and
5635 * - start a new RUNOPS loop, which will (as the first op to run),
5636 * recursively call this pp function again.
5637 * The main body of this function is then executed by the inner call.
5640 return docatch(Perl_pp_entertry);
5644 create_eval_scope(retop, PL_stack_sp, 0);
5646 return PL_op->op_next;
5650 /* also tail-called by pp_return */
5662 assert(CxTYPE(cx) == CXt_EVAL);
5663 oldsp = PL_stack_base + cx->blk_oldsp;
5664 gimme = cx->blk_gimme;
5666 if (gimme == G_VOID) {
5667 rpp_popfree_to(oldsp);
5668 /* free now to avoid late-called destructors clobbering $@ */
5672 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5676 retop = CxTRY(cx) ? PL_op->op_next : cx->blk_eval.retop;
5686 const U8 gimme = GIMME_V;
5689 assert(!PL_op->op_targ); /* used to be set for lexical $_ */
5690 GvSV(PL_defgv) = rpp_pop_1_norc();
5692 cx = cx_pushblock(CXt_GIVEN, gimme, PL_stack_sp, PL_savestack_ix);
5693 cx_pushgiven(cx, origsv);
5703 PERL_UNUSED_CONTEXT;
5706 assert(CxTYPE(cx) == CXt_GIVEN);
5707 oldsp = PL_stack_base + cx->blk_oldsp;
5708 gimme = cx->blk_gimme;
5710 if (gimme == G_VOID)
5711 rpp_popfree_to(oldsp);
5713 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5723 /* Helper routines used by pp_smartmatch */
5725 S_make_matcher(pTHX_ REGEXP *re)
5727 PMOP *matcher = cPMOPx(newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED));
5729 PERL_ARGS_ASSERT_MAKE_MATCHER;
5731 PM_SETRE(matcher, ReREFCNT_inc(re));
5733 SAVEFREEOP((OP *) matcher);
5734 ENTER_with_name("matcher"); SAVETMPS;
5740 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
5744 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
5746 PL_op = (OP *) matcher;
5748 (void) Perl_pp_match(aTHX);
5749 result = SvTRUEx(*PL_stack_sp);
5755 S_destroy_matcher(pTHX_ PMOP *matcher)
5757 PERL_ARGS_ASSERT_DESTROY_MATCHER;
5758 PERL_UNUSED_ARG(matcher);
5761 LEAVE_with_name("matcher");
5765 /* Do a smart match */
5768 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
5769 return do_smartmatch(NULL, NULL, 0);
5773 /* This version of do_smartmatch() implements the
5774 * table of smart matches that is found in perlsyn.
5777 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
5779 bool object_on_left = FALSE;
5780 SV *e = PL_stack_sp[0]; /* e is for 'expression' */
5781 SV *d = PL_stack_sp[-1]; /* d is for 'default', as in PL_defgv */
5783 /* Take care only to invoke mg_get() once for each argument.
5784 * Currently we do this by copying the SV if it's magical. */
5786 if (!copied && SvGMAGICAL(d))
5787 d = sv_mortalcopy(d);
5794 e = sv_mortalcopy(e);
5796 /* First of all, handle overload magic of the rightmost argument */
5799 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
5800 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
5802 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
5804 rpp_replace_2_1(tmpsv);
5807 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
5812 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
5819 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
5820 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
5821 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
5823 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
5824 object_on_left = TRUE;
5827 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
5828 if (object_on_left) {
5829 goto sm_any_sub; /* Treat objects like scalars */
5831 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5832 /* Test sub truth for each key */
5834 bool andedresults = TRUE;
5835 HV *hv = (HV*) SvRV(d);
5836 I32 numkeys = hv_iterinit(hv);
5837 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
5840 while ( (he = hv_iternext(hv)) ) {
5841 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
5842 ENTER_with_name("smartmatch_hash_key_test");
5844 PUSHMARK(PL_stack_sp);
5845 rpp_xpush_1(hv_iterkeysv(he));
5846 (void)call_sv(e, G_SCALAR);
5847 andedresults = SvTRUEx(PL_stack_sp[0]) && andedresults;
5850 LEAVE_with_name("smartmatch_hash_key_test");
5857 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5858 /* Test sub truth for each element */
5860 bool andedresults = TRUE;
5861 AV *av = (AV*) SvRV(d);
5862 const Size_t len = av_count(av);
5863 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
5866 for (i = 0; i < len; ++i) {
5867 SV * const * const svp = av_fetch(av, i, FALSE);
5868 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
5869 ENTER_with_name("smartmatch_array_elem_test");
5871 PUSHMARK(PL_stack_sp);
5874 (void)call_sv(e, G_SCALAR);
5875 andedresults = SvTRUEx(PL_stack_sp[0]) && andedresults;
5878 LEAVE_with_name("smartmatch_array_elem_test");
5887 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
5888 ENTER_with_name("smartmatch_coderef");
5889 PUSHMARK(PL_stack_sp);
5891 (void)call_sv(e, G_SCALAR);
5892 LEAVE_with_name("smartmatch_coderef");
5893 SV *retsv = *PL_stack_sp--;
5894 rpp_replace_2_1(retsv);
5895 #ifdef PERL_RC_STACK
5896 SvREFCNT_dec(retsv);
5902 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
5903 if (object_on_left) {
5904 goto sm_any_hash; /* Treat objects like scalars */
5906 else if (!SvOK(d)) {
5907 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
5910 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5911 /* Check that the key-sets are identical */
5913 HV *other_hv = MUTABLE_HV(SvRV(d));
5916 U32 this_key_count = 0,
5917 other_key_count = 0;
5918 HV *hv = MUTABLE_HV(SvRV(e));
5920 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
5921 /* Tied hashes don't know how many keys they have. */
5922 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
5923 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
5927 HV * const temp = other_hv;
5933 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
5937 /* The hashes have the same number of keys, so it suffices
5938 to check that one is a subset of the other. */
5939 (void) hv_iterinit(hv);
5940 while ( (he = hv_iternext(hv)) ) {
5941 SV *key = hv_iterkeysv(he);
5943 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
5946 if(!hv_exists_ent(other_hv, key, 0)) {
5947 (void) hv_iterinit(hv); /* reset iterator */
5953 (void) hv_iterinit(other_hv);
5954 while ( hv_iternext(other_hv) )
5958 other_key_count = HvUSEDKEYS(other_hv);
5960 if (this_key_count != other_key_count)
5965 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5966 AV * const other_av = MUTABLE_AV(SvRV(d));
5967 const Size_t other_len = av_count(other_av);
5969 HV *hv = MUTABLE_HV(SvRV(e));
5971 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
5972 for (i = 0; i < other_len; ++i) {
5973 SV ** const svp = av_fetch(other_av, i, FALSE);
5974 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
5975 if (svp) { /* ??? When can this not happen? */
5976 if (hv_exists_ent(hv, *svp, 0))
5982 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
5983 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
5986 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
5988 HV *hv = MUTABLE_HV(SvRV(e));
5990 (void) hv_iterinit(hv);
5991 while ( (he = hv_iternext(hv)) ) {
5992 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
5993 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
5994 (void) hv_iterinit(hv);
5995 destroy_matcher(matcher);
5999 destroy_matcher(matcher);
6005 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
6006 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
6013 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
6014 if (object_on_left) {
6015 goto sm_any_array; /* Treat objects like scalars */
6017 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
6018 AV * const other_av = MUTABLE_AV(SvRV(e));
6019 const Size_t other_len = av_count(other_av);
6022 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
6023 for (i = 0; i < other_len; ++i) {
6024 SV ** const svp = av_fetch(other_av, i, FALSE);
6026 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
6027 if (svp) { /* ??? When can this not happen? */
6028 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
6034 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
6035 AV *other_av = MUTABLE_AV(SvRV(d));
6036 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
6037 if (av_count(MUTABLE_AV(SvRV(e))) != av_count(other_av))
6041 const Size_t other_len = av_count(other_av);
6043 if (NULL == seen_this) {
6044 seen_this = (HV*)newSV_type_mortal(SVt_PVHV);
6046 if (NULL == seen_other) {
6047 seen_other = (HV*)newSV_type_mortal(SVt_PVHV);
6049 for(i = 0; i < other_len; ++i) {
6050 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
6051 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
6053 if (!this_elem || !other_elem) {
6054 if ((this_elem && SvOK(*this_elem))
6055 || (other_elem && SvOK(*other_elem)))
6058 else if (hv_exists_ent(seen_this,
6059 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
6060 hv_exists_ent(seen_other,
6061 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
6063 if (*this_elem != *other_elem)
6067 (void)hv_store_ent(seen_this,
6068 sv_2mortal(newSViv(PTR2IV(*this_elem))),
6070 (void)hv_store_ent(seen_other,
6071 sv_2mortal(newSViv(PTR2IV(*other_elem))),
6073 rpp_xpush_2(*other_elem, *this_elem);
6074 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
6075 (void) do_smartmatch(seen_this, seen_other, 0);
6076 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
6078 bool ok = SvTRUEx(PL_stack_sp[0]);
6087 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
6088 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
6091 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
6092 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
6095 for(i = 0; i < this_len; ++i) {
6096 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
6097 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
6098 if (svp && matcher_matches_sv(matcher, *svp)) {
6099 destroy_matcher(matcher);
6103 destroy_matcher(matcher);
6107 else if (!SvOK(d)) {
6108 /* undef ~~ array */
6109 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
6112 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
6113 for (i = 0; i < this_len; ++i) {
6114 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
6115 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
6116 if (!svp || !SvOK(*svp))
6125 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
6127 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
6128 for (i = 0; i < this_len; ++i) {
6129 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
6133 rpp_xpush_2(d, *svp);
6134 /* infinite recursion isn't supposed to happen here */
6135 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
6136 (void) do_smartmatch(NULL, NULL, 1);
6137 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
6138 bool ok = SvTRUEx(PL_stack_sp[0]);
6148 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
6149 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
6150 SV *t = d; d = e; e = t;
6151 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
6154 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
6155 SV *t = d; d = e; e = t;
6156 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
6157 goto sm_regex_array;
6160 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
6163 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
6164 result = matcher_matches_sv(matcher, d);
6165 destroy_matcher(matcher);
6173 /* See if there is overload magic on left */
6174 else if (object_on_left && SvAMAGIC(d)) {
6176 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
6177 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
6178 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
6180 rpp_replace_2_1(tmpsv);
6184 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
6187 else if (!SvOK(d)) {
6188 /* undef ~~ scalar ; we already know that the scalar is SvOK */
6189 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
6194 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
6195 DEBUG_M(if (SvNIOK(e))
6196 Perl_deb(aTHX_ " applying rule Any-Num\n");
6198 Perl_deb(aTHX_ " applying rule Num-numish\n");
6200 /* numeric comparison */
6202 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
6203 (void) Perl_pp_i_eq(aTHX);
6205 (void) Perl_pp_eq(aTHX);
6206 bool ok = SvTRUEx(PL_stack_sp[0]);
6214 /* As a last resort, use string comparison */
6215 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
6219 bool ok = SvTRUEx(PL_stack_sp[0]);
6228 rpp_replace_2_1(&PL_sv_no);
6232 rpp_replace_2_1(&PL_sv_yes);
6240 const U8 gimme = GIMME_V;
6242 /* This is essentially an optimization: if the match
6243 fails, we don't want to push a context and then
6244 pop it again right away, so we skip straight
6245 to the op that follows the leavewhen.
6247 if (!(PL_op->op_flags & OPf_SPECIAL)) { /* SPECIAL implies no condition */
6248 bool tr = SvTRUEx(*PL_stack_sp);
6251 if (gimme == G_SCALAR)
6252 *++PL_stack_sp = &PL_sv_undef;
6253 return cLOGOP->op_other->op_next;
6257 cx = cx_pushblock(CXt_WHEN, gimme, PL_stack_sp, PL_savestack_ix);
6271 assert(CxTYPE(cx) == CXt_WHEN);
6272 gimme = cx->blk_gimme;
6274 cxix = dopoptogivenfor(cxstack_ix);
6276 /* diag_listed_as: Can't "when" outside a topicalizer */
6277 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
6278 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
6280 oldsp = PL_stack_base + cx->blk_oldsp;
6281 if (gimme == G_VOID)
6282 rpp_popfree_to(oldsp);
6284 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
6286 /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
6287 assert(cxix < cxstack_ix);
6290 cx = &cxstack[cxix];
6292 if (CxFOREACH(cx)) {
6293 /* emulate pp_next. Note that any stack(s) cleanup will be
6294 * done by the pp_unstack which op_nextop should point to */
6297 PL_curcop = cx->blk_oldcop;
6298 return cx->blk_loop.my_op->op_nextop;
6302 assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
6303 return cx->blk_givwhen.leave_op;
6313 cxix = dopoptowhen(cxstack_ix);
6315 DIE(aTHX_ "Can't \"continue\" outside a when block");
6317 if (cxix < cxstack_ix)
6321 assert(CxTYPE(cx) == CXt_WHEN);
6322 rpp_popfree_to(PL_stack_base + cx->blk_oldsp);
6326 nextop = cx->blk_givwhen.leave_op->op_next;
6337 cxix = dopoptogivenfor(cxstack_ix);
6339 DIE(aTHX_ "Can't \"break\" outside a given block");
6341 cx = &cxstack[cxix];
6343 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
6345 if (cxix < cxstack_ix)
6348 /* Restore the sp at the time we entered the given block */
6350 rpp_popfree_to(PL_stack_base + cx->blk_oldsp);
6352 return cx->blk_givwhen.leave_op;
6356 _invoke_defer_block(pTHX_ U8 type, void *_arg)
6358 OP *start = (OP *)_arg;
6360 I32 was_cxstack_ix = cxstack_ix;
6363 cx_pushblock(type, G_VOID, PL_stack_sp, PL_savestack_ix);
6379 assert(CxTYPE(cx) == CXt_DEFER);
6381 /* since we're called during a scope cleanup (including after
6382 * a croak), theere's no guarantee thr stack is currently
6384 #ifdef PERL_RC_STACK
6385 if (rpp_stack_is_rc())
6386 rpp_popfree_to(PL_stack_base + cx->blk_oldsp);
6389 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
6397 assert(cxstack_ix == was_cxstack_ix);
6401 invoke_defer_block(pTHX_ void *_arg)
6403 _invoke_defer_block(aTHX_ CXt_DEFER, _arg);
6407 invoke_finally_block(pTHX_ void *_arg)
6409 _invoke_defer_block(aTHX_ CXt_DEFER|CXp_FINALLY, _arg);
6414 if(PL_op->op_private & OPpDEFER_FINALLY)
6415 SAVEDESTRUCTOR_X(invoke_finally_block, cLOGOP->op_other);
6417 SAVEDESTRUCTOR_X(invoke_defer_block, cLOGOP->op_other);
6423 S_doparseform(pTHX_ SV *sv)
6426 char *s = SvPV(sv, len);
6428 char *base = NULL; /* start of current field */
6429 I32 skipspaces = 0; /* number of contiguous spaces seen */
6430 bool noblank = FALSE; /* ~ or ~~ seen on this line */
6431 bool repeat = FALSE; /* ~~ seen on this line */
6432 bool postspace = FALSE; /* a text field may need right padding */
6435 U32 *linepc = NULL; /* position of last FF_LINEMARK */
6437 bool ischop; /* it's a ^ rather than a @ */
6438 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
6439 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
6443 PERL_ARGS_ASSERT_DOPARSEFORM;
6446 Perl_croak(aTHX_ "Null picture in formline");
6448 if (SvTYPE(sv) >= SVt_PVMG) {
6449 /* This might, of course, still return NULL. */
6450 mg = mg_find(sv, PERL_MAGIC_fm);
6452 sv_upgrade(sv, SVt_PVMG);
6456 /* still the same as previously-compiled string? */
6457 SV *old = mg->mg_obj;
6458 if ( ! (cBOOL(SvUTF8(old)) ^ cBOOL(SvUTF8(sv)))
6459 && len == SvCUR(old)
6460 && strnEQ(SvPVX(old), s, len)
6462 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
6466 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
6467 Safefree(mg->mg_ptr);
6473 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
6474 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
6477 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
6478 s = SvPV(sv_copy, len); /* work on the copy, not the original */
6482 /* estimate the buffer size needed */
6483 for (base = s; s <= send; s++) {
6484 if (*s == '\n' || *s == '@' || *s == '^')
6490 Newx(fops, maxops, U32);
6495 *fpc++ = FF_LINEMARK;
6496 noblank = repeat = FALSE;
6514 case ' ': case '\t':
6530 *fpc++ = FF_LITERAL;
6538 *fpc++ = (U32)skipspaces;
6542 *fpc++ = FF_NEWLINE;
6546 arg = fpc - linepc + 1;
6553 *fpc++ = FF_LINEMARK;
6554 noblank = repeat = FALSE;
6563 ischop = s[-1] == '^';
6569 arg = (s - base) - 1;
6571 *fpc++ = FF_LITERAL;
6577 if (*s == '*') { /* @* or ^* */
6579 *fpc++ = 2; /* skip the @* or ^* */
6581 *fpc++ = FF_LINESNGL;
6584 *fpc++ = FF_LINEGLOB;
6586 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
6587 arg = ischop ? FORM_NUM_BLANK : 0;
6592 const char * const f = ++s;
6595 arg |= FORM_NUM_POINT + (s - f);
6597 *fpc++ = s - base; /* fieldsize for FETCH */
6598 *fpc++ = FF_DECIMAL;
6600 unchopnum |= ! ischop;
6602 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
6603 arg = ischop ? FORM_NUM_BLANK : 0;
6605 s++; /* skip the '0' first */
6609 const char * const f = ++s;
6612 arg |= FORM_NUM_POINT + (s - f);
6614 *fpc++ = s - base; /* fieldsize for FETCH */
6615 *fpc++ = FF_0DECIMAL;
6617 unchopnum |= ! ischop;
6619 else { /* text field */
6621 bool ismore = FALSE;
6624 while (*++s == '>') ;
6625 prespace = FF_SPACE;
6627 else if (*s == '|') {
6628 while (*++s == '|') ;
6629 prespace = FF_HALFSPACE;
6634 while (*++s == '<') ;
6637 if (*s == '.' && s[1] == '.' && s[2] == '.') {
6641 *fpc++ = s - base; /* fieldsize for FETCH */
6643 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
6646 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
6660 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
6663 mg->mg_ptr = (char *) fops;
6664 mg->mg_len = arg * sizeof(U32);
6665 mg->mg_obj = sv_copy;
6666 mg->mg_flags |= MGf_REFCOUNTED;
6668 if (unchopnum && repeat)
6669 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
6676 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
6678 /* Can value be printed in fldsize chars, using %*.*f ? */
6682 int intsize = fldsize - (value < 0 ? 1 : 0);
6684 if (frcsize & FORM_NUM_POINT)
6686 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
6689 while (intsize--) pwr *= 10.0;
6690 while (frcsize--) eps /= 10.0;
6693 if (value + eps >= pwr)
6696 if (value - eps <= -pwr)
6703 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
6705 SV * const datasv = FILTER_DATA(idx);
6706 const int filter_has_file = IoLINES(datasv);
6707 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
6708 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
6713 char *prune_from = NULL;
6714 bool read_from_cache = FALSE;
6718 PERL_ARGS_ASSERT_RUN_USER_FILTER;
6720 assert(maxlen >= 0);
6723 /* I was having segfault trouble under Linux 2.2.5 after a
6724 parse error occurred. (Had to hack around it with a test
6725 for PL_parser->error_count == 0.) Solaris doesn't segfault --
6726 not sure where the trouble is yet. XXX */
6729 SV *const cache = datasv;
6732 const char *cache_p = SvPV(cache, cache_len);
6736 /* Running in block mode and we have some cached data already.
6738 if (cache_len >= umaxlen) {
6739 /* In fact, so much data we don't even need to call
6744 const char *const first_nl =
6745 (const char *)memchr(cache_p, '\n', cache_len);
6747 take = first_nl + 1 - cache_p;
6751 sv_catpvn(buf_sv, cache_p, take);
6752 sv_chop(cache, cache_p + take);
6753 /* Definitely not EOF */
6757 sv_catsv(buf_sv, cache);
6759 umaxlen -= cache_len;
6762 read_from_cache = TRUE;
6766 /* Filter API says that the filter appends to the contents of the buffer.
6767 Usually the buffer is "", so the details don't matter. But if it's not,
6768 then clearly what it contains is already filtered by this filter, so we
6769 don't want to pass it in a second time.
6770 I'm going to use a mortal in case the upstream filter croaks. */
6771 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
6772 ? newSV_type_mortal(SVt_PV) : buf_sv;
6773 SvUPGRADE(upstream, SVt_PV);
6775 if (filter_has_file) {
6776 status = FILTER_READ(idx+1, upstream, 0);
6779 if (filter_sub && status >= 0) {
6783 ENTER_with_name("call_filter_sub");
6788 DEFSV_set(upstream);
6792 PUSHs(filter_state);
6795 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
6805 SV * const errsv = ERRSV;
6806 if (SvTRUE_NN(errsv))
6807 err = newSVsv(errsv);
6813 LEAVE_with_name("call_filter_sub");
6816 if (SvGMAGICAL(upstream)) {
6818 if (upstream == buf_sv) mg_free(buf_sv);
6820 if (SvIsCOW(upstream)) sv_force_normal(upstream);
6821 if(!err && SvOK(upstream)) {
6822 got_p = SvPV_nomg(upstream, got_len);
6824 if (got_len > umaxlen) {
6825 prune_from = got_p + umaxlen;
6828 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
6829 if (first_nl && first_nl + 1 < got_p + got_len) {
6830 /* There's a second line here... */
6831 prune_from = first_nl + 1;
6835 if (!err && prune_from) {
6836 /* Oh. Too long. Stuff some in our cache. */
6837 STRLEN cached_len = got_p + got_len - prune_from;
6838 SV *const cache = datasv;
6841 /* Cache should be empty. */
6842 assert(!SvCUR(cache));
6845 sv_setpvn(cache, prune_from, cached_len);
6846 /* If you ask for block mode, you may well split UTF-8 characters.
6847 "If it breaks, you get to keep both parts"
6848 (Your code is broken if you don't put them back together again
6849 before something notices.) */
6850 if (SvUTF8(upstream)) {
6853 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
6855 /* Cannot just use sv_setpvn, as that could free the buffer
6856 before we have a chance to assign it. */
6857 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
6858 got_len - cached_len);
6860 /* Can't yet be EOF */
6865 /* If they are at EOF but buf_sv has something in it, then they may never
6866 have touched the SV upstream, so it may be undefined. If we naively
6867 concatenate it then we get a warning about use of uninitialised value.
6869 if (!err && upstream != buf_sv &&
6871 sv_catsv_nomg(buf_sv, upstream);
6873 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
6876 IoLINES(datasv) = 0;
6878 SvREFCNT_dec(filter_state);
6879 IoTOP_GV(datasv) = NULL;
6882 SvREFCNT_dec(filter_sub);
6883 IoBOTTOM_GV(datasv) = NULL;
6885 filter_del(S_run_user_filter);
6891 if (status == 0 && read_from_cache) {
6892 /* If we read some data from the cache (and by getting here it implies
6893 that we emptied the cache) then we aren't yet at EOF, and mustn't
6894 report that to our caller. */
6901 * ex: set ts=8 sts=4 sw=4 et: