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 https://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_NN(args - 1);
199 /* s/.../expr/e is executed in order as if written as
202 * while (pp_substcont()) {
206 * Only on the second and later calls to pp_substcont() is there a scalar
207 * on the stack holding the value of expr.
209 * Note that pp_subst() leaves its original 0-2 args on the stack to
210 * avoid them being prematurely freed. It is pp_substcont()'s
211 * responsibility to pop them after the last iteration.
216 PERL_CONTEXT *cx = CX_CUR();
217 PMOP * const pm = cPMOPx(cLOGOP->op_other);
218 SV * const dstr = cx->sb_dstr;
221 char *orig = cx->sb_orig;
222 REGEXP * const rx = cx->sb_rx;
224 REGEXP *old = PM_GETRE(pm);
231 PM_SETRE(pm,ReREFCNT_inc(rx));
234 rxres_restore(&cx->sb_rxres, rx);
236 if (cx->sb_iters++) {
237 /* second+ time round. Result is on stack */
238 const SSize_t saviters = cx->sb_iters;
239 if (cx->sb_iters > cx->sb_maxiters)
240 DIE(aTHX_ "Substitution loop");
242 SvGETMAGIC(*PL_stack_sp); /* possibly clear taint on $1 etc: #67962 */
244 /* See "how taint works": pp_subst() in pp_hot.c */
245 sv_catsv_nomg(dstr, *PL_stack_sp);
247 if (UNLIKELY(TAINT_get))
248 cx->sb_rxtainted |= SUBST_TAINT_REPL;
249 if (CxONCE(cx) || s < orig ||
250 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
251 (s == m), cx->sb_targ, NULL,
252 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
254 /* no more iterations. Push return value etc */
255 SV *targ = cx->sb_targ;
258 assert(cx->sb_strend >= s);
259 if(cx->sb_strend > s) {
260 if (DO_UTF8(dstr) && !SvUTF8(targ))
261 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
263 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
265 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
266 cx->sb_rxtainted |= SUBST_TAINT_PAT;
268 if (pm->op_pmflags & PMf_NONDESTRUCT) {
270 /* From here on down we're using the copy, and leaving the
271 original untouched. */
275 SV_CHECK_THINKFIRST_COW_DROP(targ);
276 if (isGV(targ)) Perl_croak_no_modify();
278 SvPV_set(targ, SvPVX(dstr));
279 SvCUR_set(targ, SvCUR(dstr));
280 SvLEN_set(targ, SvLEN(dstr));
283 SvPV_set(dstr, NULL);
286 retval = sv_newmortal();
287 sv_setiv(retval, saviters - 1);
289 (void)SvPOK_only_UTF8(targ);
292 /* pop the original args (if any) to pp_subst(),
293 * then push the result */
294 if (pm->op_pmflags & PMf_CONST)
295 rpp_popfree_1_NN(); /* pop replacement string */
296 if (pm->op_flags & OPf_STACKED)
297 rpp_replace_1_1_NN(retval); /* pop LHS of =~ */
301 /* update the taint state of various variables in
302 * preparation for final exit.
303 * See "how taint works": pp_subst() in pp_hot.c */
305 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
306 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
307 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
309 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
311 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
312 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
314 SvTAINTED_on(retval); /* taint return value */
315 /* needed for mg_set below */
317 cBOOL(cx->sb_rxtainted &
318 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
321 /* sv_magic(), when adding magic (e.g.taint magic), also
322 * recalculates any pos() magic, converting any byte offset
323 * to utf8 offset. Make sure pos() is reset before this
324 * happens rather than using the now invalid value (since
325 * we've just replaced targ's pvx buffer with the
326 * potentially shorter dstr buffer). Normally (i.e. in
327 * non-taint cases), pos() gets removed a few lines later
328 * with the SvSETMAGIC().
332 mg = mg_find_mglob(targ);
334 MgBYTEPOS_set(mg, targ, SvPVX(targ), -1);
340 /* PL_tainted must be correctly set for this mg_set */
350 NOT_REACHED; /* NOTREACHED */
352 cx->sb_iters = saviters;
355 /* First iteration. The substitution expression hasn;'t been executed
358 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
361 assert(!RX_SUBOFFSET(rx));
362 cx->sb_orig = orig = RX_SUBBEG(rx);
364 cx->sb_strend = s + (cx->sb_strend - m);
366 cx->sb_m = m = RX_OFFS_START(rx,0) + orig;
368 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
369 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
371 sv_catpvn_nomg(dstr, s, m-s);
373 cx->sb_s = RX_OFFS_END(rx,0) + orig;
374 { /* Update the pos() information. */
376 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
379 /* the string being matched against may no longer be a string,
380 * e.g. $_=0; s/.../$_++/ge */
383 SvPV_force_nomg_nolen(sv);
385 if (!(mg = mg_find_mglob(sv))) {
386 mg = sv_magicext_mglob(sv);
388 MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
391 (void)ReREFCNT_inc(rx);
392 /* update the taint state of various variables in preparation
393 * for calling the code block.
394 * See "how taint works": pp_subst() in pp_hot.c */
396 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
397 cx->sb_rxtainted |= SUBST_TAINT_PAT;
399 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
400 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
401 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
403 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
405 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
406 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
407 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
408 ? cx->sb_dstr : cx->sb_targ);
411 rxres_save(&cx->sb_rxres, rx);
413 return pm->op_pmstashstartu.op_pmreplstart;
418 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
423 PERL_ARGS_ASSERT_RXRES_SAVE;
426 /* deal with regexp_paren_pair items */
427 if (!p || p[1] < RX_NPARENS(rx)) {
429 i = 7 + (RX_NPARENS(rx)+1) * 2;
431 i = 6 + (RX_NPARENS(rx)+1) * 2;
440 /* what (if anything) to free on croak */
441 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
442 RX_MATCH_COPIED_off(rx);
443 *p++ = RX_NPARENS(rx);
446 *p++ = PTR2UV(RX_SAVED_COPY(rx));
447 RX_SAVED_COPY(rx) = NULL;
450 *p++ = PTR2UV(RX_SUBBEG(rx));
451 *p++ = (UV)RX_SUBLEN(rx);
452 *p++ = (UV)RX_SUBOFFSET(rx);
453 *p++ = (UV)RX_SUBCOFFSET(rx);
454 for (i = 0; i <= RX_NPARENS(rx); ++i) {
455 *p++ = (UV)RX_OFFSp(rx)[i].start;
456 *p++ = (UV)RX_OFFSp(rx)[i].end;
461 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
466 PERL_ARGS_ASSERT_RXRES_RESTORE;
469 RX_MATCH_COPY_FREE(rx);
470 RX_MATCH_COPIED_set(rx, *p);
472 RX_NPARENS(rx) = *p++;
475 if (RX_SAVED_COPY(rx))
476 SvREFCNT_dec (RX_SAVED_COPY(rx));
477 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
481 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
482 RX_SUBLEN(rx) = (SSize_t)(*p++);
483 RX_SUBOFFSET(rx) = (Size_t)*p++;
484 RX_SUBCOFFSET(rx) = (SSize_t)*p++;
485 for (i = 0; i <= RX_NPARENS(rx); ++i) {
486 RX_OFFSp(rx)[i].start = (SSize_t)(*p++);
487 RX_OFFSp(rx)[i].end = (SSize_t)(*p++);
492 S_rxres_free(pTHX_ void **rsp)
494 UV * const p = (UV*)*rsp;
496 PERL_ARGS_ASSERT_RXRES_FREE;
500 void *tmp = INT2PTR(char*,*p);
503 U32 i = 9 + p[1] * 2;
505 U32 i = 8 + p[1] * 2;
510 SvREFCNT_dec (INT2PTR(SV*,p[2]));
513 PoisonFree(p, i, sizeof(UV));
522 #define FORM_NUM_BLANK (1<<30)
523 #define FORM_NUM_POINT (1<<29)
525 PP_wrapped(pp_formline, 0, 1)
527 dSP; dMARK; dORIGMARK;
528 SV * const tmpForm = *++MARK;
529 SV *formsv; /* contains text of original format */
530 U32 *fpc; /* format ops program counter */
531 char *t; /* current append position in target string */
532 const char *f; /* current position in format string */
534 SV *sv = NULL; /* current item */
535 const char *item = NULL;/* string value of current item */
536 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
537 I32 itembytes = 0; /* as itemsize, but length in bytes */
538 I32 fieldsize = 0; /* width of current field */
539 I32 lines = 0; /* number of lines that have been output */
540 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
541 const char *chophere = NULL; /* where to chop current item */
542 STRLEN linemark = 0; /* pos of start of line in output */
544 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
545 STRLEN len; /* length of current sv */
546 STRLEN linemax; /* estimate of output size in bytes */
547 bool item_is_utf8 = FALSE;
548 bool targ_is_utf8 = FALSE;
551 U8 *source; /* source of bytes to append */
552 STRLEN to_copy; /* how may bytes to append */
553 char trans; /* what chars to translate */
554 bool copied_form = FALSE; /* have we duplicated the form? */
556 mg = doparseform(tmpForm);
558 fpc = (U32*)mg->mg_ptr;
559 /* the actual string the format was compiled from.
560 * with overload etc, this may not match tmpForm */
564 SvPV_force(PL_formtarget, len);
565 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
566 SvTAINTED_on(PL_formtarget);
567 if (DO_UTF8(PL_formtarget))
569 /* this is an initial estimate of how much output buffer space
570 * to allocate. It may be exceeded later */
571 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
572 t = SvGROW(PL_formtarget, len + linemax + 1);
573 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
575 f = SvPV_const(formsv, len);
579 const char *name = "???";
582 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
583 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
584 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
585 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
586 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
588 case FF_CHECKNL: name = "CHECKNL"; break;
589 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
590 case FF_SPACE: name = "SPACE"; break;
591 case FF_HALFSPACE: name = "HALFSPACE"; break;
592 case FF_ITEM: name = "ITEM"; break;
593 case FF_CHOP: name = "CHOP"; break;
594 case FF_LINEGLOB: name = "LINEGLOB"; break;
595 case FF_NEWLINE: name = "NEWLINE"; break;
596 case FF_MORE: name = "MORE"; break;
597 case FF_LINEMARK: name = "LINEMARK"; break;
598 case FF_END: name = "END"; break;
599 case FF_0DECIMAL: name = "0DECIMAL"; break;
600 case FF_LINESNGL: name = "LINESNGL"; break;
603 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
605 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
608 case FF_LINEMARK: /* start (or end) of a line */
609 linemark = t - SvPVX(PL_formtarget);
614 case FF_LITERAL: /* append <arg> literal chars */
619 item_is_utf8 = (targ_is_utf8)
620 ? cBOOL(DO_UTF8(formsv))
621 : cBOOL(SvUTF8(formsv));
624 case FF_SKIP: /* skip <arg> chars in format */
628 case FF_FETCH: /* get next item and set field size to <arg> */
637 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
640 SvTAINTED_on(PL_formtarget);
643 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
645 const char *s = item = SvPV_const(sv, len);
646 const char *send = s + len;
649 item_is_utf8 = DO_UTF8(sv);
661 if (itemsize == fieldsize)
664 itembytes = s - item;
669 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
671 const char *s = item = SvPV_const(sv, len);
672 const char *send = s + len;
676 item_is_utf8 = DO_UTF8(sv);
678 /* look for a legal split position */
686 /* provisional split point */
690 /* we delay testing fieldsize until after we've
691 * processed the possible split char directly
692 * following the last field char; so if fieldsize=3
693 * and item="a b cdef", we consume "a b", not "a".
694 * Ditto further down.
696 if (size == fieldsize)
700 if (size == fieldsize)
702 if (strchr(PL_chopset, *s)) {
703 /* provisional split point */
704 /* for a non-space split char, we include
705 * the split char; hence the '+1' */
719 if (!chophere || s == send) {
723 itembytes = chophere - item;
728 case FF_SPACE: /* append padding space (diff of field, item size) */
729 arg = fieldsize - itemsize;
737 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
738 arg = fieldsize - itemsize;
747 case FF_ITEM: /* append a text item, while blanking ctrl chars */
753 case FF_CHOP: /* (for ^*) chop the current item */
754 if (sv != &PL_sv_no) {
755 const char *s = chophere;
757 ((sv == tmpForm || SvSMAGICAL(sv))
758 || (SvGMAGICAL(tmpForm) && !sv_only_taint_gmagic(tmpForm))) ) {
759 /* sv and tmpForm are either the same SV, or magic might allow modification
760 of tmpForm when sv is modified, so copy */
761 SV *newformsv = sv_mortalcopy(formsv);
764 f = SvPV_nolen(newformsv) + (f - SvPV_nolen(formsv));
765 Newx(new_compiled, mg->mg_len / sizeof(U32), U32);
766 memcpy(new_compiled, mg->mg_ptr, mg->mg_len);
767 SAVEFREEPV(new_compiled);
768 fpc = new_compiled + (fpc - (U32*)mg->mg_ptr);
780 /* tied, overloaded or similar strangeness.
781 * Do it the hard way */
782 sv_setpvn(sv, s, len - (s-item));
788 case FF_LINESNGL: /* process ^* */
792 case FF_LINEGLOB: /* process @* */
794 const bool oneline = fpc[-1] == FF_LINESNGL;
795 const char *s = item = SvPV_const(sv, len);
796 const char *const send = s + len;
798 item_is_utf8 = DO_UTF8(sv);
809 to_copy = s - item - 1;
823 /* append to_copy bytes from source to PL_formstring.
824 * item_is_utf8 implies source is utf8.
825 * if trans, translate certain characters during the copy */
830 SvCUR_set(PL_formtarget,
831 t - SvPVX_const(PL_formtarget));
833 if (targ_is_utf8 && !item_is_utf8) {
834 source = tmp = bytes_to_utf8(source, &to_copy);
837 if (item_is_utf8 && !targ_is_utf8) {
839 /* Upgrade targ to UTF8, and then we reduce it to
840 a problem we have a simple solution for.
841 Don't need get magic. */
842 sv_utf8_upgrade_nomg(PL_formtarget);
844 /* re-calculate linemark */
845 s = (U8*)SvPVX(PL_formtarget);
846 /* the bytes we initially allocated to append the
847 * whole line may have been gobbled up during the
848 * upgrade, so allocate a whole new line's worth
852 s += UTF8_SAFE_SKIP(s,
853 (U8 *) SvEND(PL_formtarget));
854 linemark = s - (U8*)SvPVX(PL_formtarget);
856 /* Easy. They agree. */
857 assert (item_is_utf8 == targ_is_utf8);
860 /* @* and ^* are the only things that can exceed
861 * the linemax, so grow by the output size, plus
862 * a whole new form's worth in case of any further
864 grow = linemax + to_copy;
866 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
867 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
869 Copy(source, t, to_copy, char);
871 /* blank out ~ or control chars, depending on trans.
872 * works on bytes not chars, so relies on not
873 * matching utf8 continuation bytes */
875 U8 *send = s + to_copy;
878 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
885 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
891 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
894 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
897 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
900 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
902 /* If the field is marked with ^ and the value is undefined,
904 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
912 /* overflow evidence */
913 if (num_overflow(value, fieldsize, arg)) {
919 /* Formats aren't yet marked for locales, so assume "yes". */
921 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
923 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
927 if (!quadmath_format_valid(fmt))
928 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
929 WITH_LC_NUMERIC_SET_TO_NEEDED(
930 len = quadmath_snprintf(t, max, fmt, (int) fieldsize,
934 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", fmt);
937 /* we generate fmt ourselves so it is safe */
938 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
939 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
940 GCC_DIAG_RESTORE_STMT;
942 PERL_MY_SNPRINTF_POST_GUARD(len, max);
947 case FF_NEWLINE: /* delete trailing spaces, then append \n */
949 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
954 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
957 if (arg) { /* repeat until fields exhausted? */
963 t = SvPVX(PL_formtarget) + linemark;
968 case FF_MORE: /* replace long end of string with '...' */
970 const char *s = chophere;
971 const char *send = item + len;
973 while (isSPACE(*s) && (s < send))
978 arg = fieldsize - itemsize;
985 if (strBEGINs(s1," ")) {
986 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
996 case FF_END: /* tidy up, then return */
998 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
1000 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1002 SvUTF8_on(PL_formtarget);
1003 FmLINES(PL_formtarget) += lines;
1005 if (fpc[-1] == FF_BLANK)
1006 RETURNOP(cLISTOP->op_first);
1013 /* also used for: pp_mapstart() */
1016 /* See the code comments at the start of pp_grepwhile() and
1017 * pp_mapwhile() for an explanation of how the stack is used
1018 * during a grep or map.
1023 if (PL_stack_base + TOPMARK == PL_stack_sp) {
1025 if (GIMME_V == G_SCALAR) {
1027 *++PL_stack_sp = &PL_sv_zero;
1029 return PL_op->op_next->op_next;
1031 svp = PL_stack_base + TOPMARK + 1;
1032 PUSHMARK(svp); /* push dst */
1033 PUSHMARK(svp); /* push src */
1034 ENTER_with_name("grep"); /* enter outer scope */
1038 ENTER_with_name("grep_item"); /* enter inner scope */
1041 src = PL_stack_base[TOPMARK];
1042 if (SvPADTMP(src)) {
1043 SV *newsrc = sv_mortalcopy(src);
1045 PL_stack_base[TOPMARK] = newsrc;
1046 #ifdef PERL_RC_STACK
1047 SvREFCNT_inc_simple_void_NN(newsrc);
1055 if (PL_op->op_type == OP_MAPSTART)
1056 PUSHMARK(PL_stack_sp); /* push top */
1057 return cLOGOPx(PL_op->op_next)->op_other;
1060 /* pp_grepwhile() lives in pp_hot.c */
1064 /* Understanding the stack during a map.
1066 * 'map expr, args' is implemented in the form of
1068 * grepstart; // which handles map too
1074 * The stack examples below are in the form of 'perl -Ds' output,
1075 * where any stack element indexed by PL_markstack_ptr[i] has a star
1076 * just to the right of it. In addition, the corresponding i value
1077 * is displayed under the indexed stack element.
1079 * On entry to mapwhile, the stack looks like this:
1081 * => * A1..An X1 * X2..Xn C * R1..Rn * E1..En
1082 * [-3] [-2] [-1] [0]
1085 * A1..An Accumulated results from all previous iterations of expr
1086 * X1..Xn Random garbage
1087 * C The current (just processed) arg, still aliased to $_.
1088 * R1..Rn The args remaining to be processed.
1089 * E1..En the (list) result of the just-executed map expression.
1091 * Note that it is easiest to think of stack marks [-1] and [-2] as both
1092 * being one too high, and so it would make more sense to have had the
1095 * => * A1..An * X1..Xn * C R1..Rn * E1..En
1096 * [-3] [-2] [-1] [0]
1098 * where the stack is divided neatly into 4 groups:
1099 * - accumulated results
1100 * - discards and/or holes proactively created for later result storage
1101 * - being, or yet to be, processed,
1102 * - results of last expr
1103 * But off-by-one is the way it is currently, and it works as long as
1104 * we keep it consistent and bear it in mind.
1106 * pp_mapwhile() does the following:
1108 * - If there isn't enough space in the X1..Xn zone to insert the
1109 * expression results, grow the stack and shift up everything above C.
1110 * - move E1..En to just above An
1111 * - at the same time, manipulate the tmps stack so that temporaries
1112 * from executing expr can be freed without prematurely freeing
1114 * - if on last iteration, pop all the marks, reset the stack pointer
1115 * and update the return args based on caller context.
1116 * - else alias $_ to the next arg.
1120 const U8 gimme = GIMME_V;
1121 SSize_t items = (PL_stack_sp - PL_stack_base) - TOPMARK; /* how many new items */
1127 #ifdef PERL_RC_STACK
1128 /* for ref-counted stack, we need to account for the currently-aliased
1129 * stack element, as it might (or might not) get over-written when
1130 * copying values from the expr to the end of the accumulated results
1131 * section of the list. By RC--ing and zeroing out the stack entry, we
1132 * ensure consistent handling.
1134 dst = PL_stack_base + PL_markstack_ptr[-1];
1135 SvREFCNT_dec_NN(*dst);
1139 /* first, move source pointer to the next item in the source list */
1140 ++PL_markstack_ptr[-1];
1142 /* if there are new items, push them into the destination list */
1143 if (items && gimme != G_VOID) {
1144 /* might need to make room back there first */
1145 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1146 /* XXX this implementation is very pessimal because the stack
1147 * is repeatedly extended for every set of items. Is possible
1148 * to do this without any stack extension or copying at all
1149 * by maintaining a separate list over which the map iterates
1150 * (like foreach does). --gsar */
1152 /* everything in the stack after the destination list moves
1153 * towards the end the stack by the amount of room needed */
1154 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1156 /* items to shift up (accounting for the moved source pointer) */
1157 count = (PL_stack_sp - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1159 /* This optimization is by Ben Tilly and it does
1160 * things differently from what Sarathy (gsar)
1161 * is describing. The downside of this optimization is
1162 * that leaves "holes" (uninitialized and hopefully unused areas)
1163 * to the Perl stack, but on the other hand this
1164 * shouldn't be a problem. If Sarathy's idea gets
1165 * implemented, this optimization should become
1166 * irrelevant. --jhi */
1168 shift = count; /* Avoid shifting too often --Ben Tilly */
1172 PL_stack_sp += shift;
1174 PL_markstack_ptr[-1] += shift;
1175 *PL_markstack_ptr += shift;
1178 #ifdef PERL_RC_STACK
1179 /* zero out the hole just created, so that on a
1180 * reference-counted stack, so that the just-shifted SVs
1181 * aren't counted twice.
1183 Zero(src+1, (dst-src), SV*);
1186 /* copy the new items down to the destination list */
1187 PL_markstack_ptr[-2] += items;
1188 dst = PL_stack_base + PL_markstack_ptr[-2] - 1;
1189 if (gimme == G_LIST) {
1190 /* add returned items to the collection (making mortal copies
1191 * if necessary), then clear the current temps stack frame
1192 * *except* for those items. We do this splicing the items
1193 * into the start of the tmps frame (so some items may be on
1194 * the tmps stack twice), then moving PL_tmps_floor above
1195 * them, then freeing the frame. That way, the only tmps that
1196 * accumulate over iterations are the return values for map.
1197 * We have to do to this way so that everything gets correctly
1198 * freed if we die during the map.
1202 /* make space for the slice */
1203 EXTEND_MORTAL(items);
1204 tmpsbase = PL_tmps_floor + 1;
1205 Move(PL_tmps_stack + tmpsbase,
1206 PL_tmps_stack + tmpsbase + items,
1207 PL_tmps_ix - PL_tmps_floor,
1209 PL_tmps_ix += items;
1212 #ifdef PERL_RC_STACK
1213 SV *sv = *PL_stack_sp;
1214 assert(!*dst); /* not overwriting ptrs to refcnted SVs */
1216 sv = sv_mortalcopy(sv);
1217 /* NB - don't really need the mortalising above.
1218 * A simple copy would suffice */
1220 SvREFCNT_inc_simple_void_NN(sv);
1229 SV *sv = *PL_stack_sp--;
1231 sv = sv_mortalcopy(sv);
1234 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1236 /* clear the stack frame except for the items */
1237 PL_tmps_floor += items;
1239 /* FREETMPS may have cleared the TEMP flag on some of the items */
1242 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1245 /* scalar context: we don't care about which values map returns
1246 * (we use undef here). And so we certainly don't want to do mortal
1247 * copies of meaningless values. */
1248 *(dst - items + 1) = &PL_sv_undef;
1249 rpp_popfree_to(PL_stack_sp - items);
1255 assert(gimme == G_VOID);
1256 rpp_popfree_to(PL_stack_sp - items);
1260 LEAVE_with_name("grep_item"); /* exit inner scope */
1263 if (PL_markstack_ptr[-1] > TOPMARK) {
1265 (void)POPMARK; /* pop top */
1266 LEAVE_with_name("grep"); /* exit outer scope */
1267 (void)POPMARK; /* pop src */
1268 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1269 (void)POPMARK; /* pop dst */
1270 SV **svp = PL_stack_base + POPMARK; /* pop original mark */
1271 if (gimme == G_LIST)
1273 rpp_popfree_to(svp);
1274 if (gimme == G_SCALAR) {
1277 /* XXX is the extend necessary? */
1285 ENTER_with_name("grep_item"); /* enter inner scope */
1288 /* set $_ to the new source item */
1289 src = PL_stack_base[PL_markstack_ptr[-1]];
1290 if (SvPADTMP(src)) {
1291 SV *newsrc = sv_mortalcopy(src);
1292 PL_stack_base[PL_markstack_ptr[-1]] = newsrc;
1293 #ifdef PERL_RC_STACK
1294 SvREFCNT_inc_simple_void_NN(newsrc);
1299 if (SvPADTMP(src)) {
1300 src = sv_mortalcopy(src);
1305 return cLOGOP->op_other;
1314 if (GIMME_V == G_LIST)
1317 if (SvTRUE_NN(targ))
1318 return cLOGOP->op_other;
1324 PP_wrapped(pp_flip,((GIMME_V == G_LIST) ? 0 : 1), 0)
1328 if (GIMME_V == G_LIST) {
1329 RETURNOP(cLOGOPx(cUNOP->op_first)->op_other);
1333 SV * const targ = PAD_SV(PL_op->op_targ);
1336 if (PL_op->op_private & OPpFLIP_LINENUM) {
1337 if (GvIO(PL_last_in_gv)) {
1338 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1341 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1343 flip = SvIV(sv) == SvIV(GvSV(gv));
1346 flip = SvTRUE_NN(sv);
1349 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1350 if (PL_op->op_flags & OPf_SPECIAL) {
1358 RETURNOP(cLOGOPx(cUNOP->op_first)->op_other);
1368 /* This code tries to decide if "$left .. $right" should use the
1369 magical string increment, or if the range is numeric. Initially,
1370 an exception was made for *any* string beginning with "0" (see
1371 [#18165], AMS 20021031), but now that is only applied when the
1372 string's length is also >1 - see the rules now documented in
1375 #define RANGE_IS_NUMERIC(left,right) ( \
1376 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1377 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1378 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1379 looks_like_number(left)) && SvPOKp(left) \
1380 && !(*SvPVX_const(left) == '0' && SvCUR(left)>1 ) )) \
1381 && (!SvOK(right) || looks_like_number(right))))
1384 PP_wrapped(pp_flop, (GIMME_V == G_LIST) ? 2 : 1, 0)
1388 if (GIMME_V == G_LIST) {
1394 if (RANGE_IS_NUMERIC(left,right)) {
1396 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1397 (SvOK(right) && (SvIOK(right)
1398 ? SvIsUV(right) && SvUV(right) > IV_MAX
1399 : SvNV_nomg(right) > (NV) IV_MAX)))
1400 DIE(aTHX_ "Range iterator outside integer range");
1401 i = SvIV_nomg(left);
1402 j = SvIV_nomg(right);
1404 /* Dance carefully around signed max. */
1405 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1408 /* The wraparound of signed integers is undefined
1409 * behavior, but here we aim for count >=1, and
1410 * negative count is just wrong. */
1412 #if IVSIZE > Size_t_size
1419 Perl_croak(aTHX_ "Out of memory during list extend");
1426 SV * const sv = sv_2mortal(newSViv(i));
1428 if (n) /* avoid incrementing above IV_MAX */
1434 const char * const lpv = SvPV_nomg_const(left, llen);
1435 const char * const tmps = SvPV_nomg_const(right, len);
1437 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1438 if (DO_UTF8(right) && IN_UNI_8_BIT)
1439 len = sv_len_utf8_nomg(right);
1440 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1442 if (strEQ(SvPVX_const(sv),tmps))
1444 sv = sv_2mortal(newSVsv(sv));
1451 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1455 if (PL_op->op_private & OPpFLIP_LINENUM) {
1456 if (GvIO(PL_last_in_gv)) {
1457 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1460 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1461 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1465 flop = SvTRUE_NN(sv);
1469 sv_setiv(PAD_SV(cUNOPx(cUNOP->op_first)->op_first->op_targ), 0);
1470 sv_catpvs(targ, "E0");
1481 static const char * const context_name[] = {
1483 NULL, /* CXt_WHEN never actually needs "block" */
1484 NULL, /* CXt_BLOCK never actually needs "block" */
1485 NULL, /* CXt_GIVEN never actually needs "block" */
1486 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1487 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1488 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1489 NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1490 NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1499 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1503 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1505 for (i = cxstack_ix; i >= 0; i--) {
1506 const PERL_CONTEXT * const cx = &cxstack[i];
1507 switch (CxTYPE(cx)) {
1516 /* diag_listed_as: Exiting subroutine via %s */
1517 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1518 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1519 if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1522 case CXt_LOOP_PLAIN:
1523 case CXt_LOOP_LAZYIV:
1524 case CXt_LOOP_LAZYSV:
1528 STRLEN cx_label_len = 0;
1529 U32 cx_label_flags = 0;
1530 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1532 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1535 (const U8*)cx_label, cx_label_len,
1536 (const U8*)label, len) == 0)
1538 (const U8*)label, len,
1539 (const U8*)cx_label, cx_label_len) == 0)
1540 : (len == cx_label_len && ((cx_label == label)
1541 || memEQ(cx_label, label, len))) )) {
1542 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1543 (long)i, cx_label));
1546 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1555 =for apidoc_section $callback
1556 =for apidoc dowantarray
1558 Implements the deprecated L<perlapi/C<GIMME>>.
1564 Perl_dowantarray(pTHX)
1566 const U8 gimme = block_gimme();
1567 return (gimme == G_VOID) ? G_SCALAR : gimme;
1570 /* note that this function has mostly been superseded by Perl_gimme_V */
1573 Perl_block_gimme(pTHX)
1575 const I32 cxix = dopopto_cursub();
1580 gimme = (cxstack[cxix].blk_gimme & G_WANT);
1582 Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1587 =for apidoc is_lvalue_sub
1589 Returns non-zero if the sub calling this function is being called in an lvalue
1590 context. Returns 0 otherwise.
1596 Perl_is_lvalue_sub(pTHX)
1598 const I32 cxix = dopopto_cursub();
1599 assert(cxix >= 0); /* We should only be called from inside subs */
1601 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1602 return CxLVAL(cxstack + cxix);
1607 /* only used by cx_pushsub() */
1609 Perl_was_lvalue_sub(pTHX)
1611 const I32 cxix = dopoptosub(cxstack_ix-1);
1612 assert(cxix >= 0); /* We should only be called from inside subs */
1614 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1615 return CxLVAL(cxstack + cxix);
1621 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1625 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1627 PERL_UNUSED_CONTEXT;
1630 for (i = startingblock; i >= 0; i--) {
1631 const PERL_CONTEXT * const cx = &cxstk[i];
1632 switch (CxTYPE(cx)) {
1636 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1637 * twice; the first for the normal foo() call, and the second
1638 * for a faked up re-entry into the sub to execute the
1639 * code block. Hide this faked entry from the world. */
1640 if (cx->cx_type & CXp_SUB_RE_FAKE)
1642 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1648 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1652 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1660 S_dopoptoeval(pTHX_ I32 startingblock)
1663 for (i = startingblock; i >= 0; i--) {
1664 const PERL_CONTEXT *cx = &cxstack[i];
1665 switch (CxTYPE(cx)) {
1669 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1677 S_dopoptoloop(pTHX_ I32 startingblock)
1680 for (i = startingblock; i >= 0; i--) {
1681 const PERL_CONTEXT * const cx = &cxstack[i];
1682 switch (CxTYPE(cx)) {
1691 /* diag_listed_as: Exiting subroutine via %s */
1692 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1693 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1694 if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1697 case CXt_LOOP_PLAIN:
1698 case CXt_LOOP_LAZYIV:
1699 case CXt_LOOP_LAZYSV:
1702 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1709 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1712 S_dopoptogivenfor(pTHX_ I32 startingblock)
1715 for (i = startingblock; i >= 0; i--) {
1716 const PERL_CONTEXT *cx = &cxstack[i];
1717 switch (CxTYPE(cx)) {
1721 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1723 case CXt_LOOP_PLAIN:
1724 assert(!(cx->cx_type & CXp_FOR_DEF));
1726 case CXt_LOOP_LAZYIV:
1727 case CXt_LOOP_LAZYSV:
1730 if (cx->cx_type & CXp_FOR_DEF) {
1731 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1740 S_dopoptowhen(pTHX_ I32 startingblock)
1743 for (i = startingblock; i >= 0; i--) {
1744 const PERL_CONTEXT *cx = &cxstack[i];
1745 switch (CxTYPE(cx)) {
1749 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1756 /* dounwind(): pop all contexts above (but not including) cxix.
1757 * Note that it clears the savestack frame associated with each popped
1758 * context entry, but doesn't free any temps.
1759 * It does a cx_popblock() of the last frame that it pops, and leaves
1760 * cxstack_ix equal to cxix.
1764 Perl_dounwind(pTHX_ I32 cxix)
1766 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1769 while (cxstack_ix > cxix) {
1770 PERL_CONTEXT *cx = CX_CUR();
1772 CX_DEBUG(cx, "UNWIND");
1773 /* Note: we don't need to restore the base context info till the end. */
1777 switch (CxTYPE(cx)) {
1780 /* CXt_SUBST is not a block context type, so skip the
1781 * cx_popblock(cx) below */
1782 if (cxstack_ix == cxix + 1) {
1793 case CXt_LOOP_PLAIN:
1794 case CXt_LOOP_LAZYIV:
1795 case CXt_LOOP_LAZYSV:
1809 /* these two don't have a POPFOO() */
1815 if (cxstack_ix == cxix + 1) {
1824 /* Like rpp_popfree_to(), but takes an offset rather than a pointer,
1825 * and frees everything above ix appropriately, *regardless* of the
1826 * refcountedness of the stack. If necessary it removes any split stack.
1827 * Intended for use during exit() and die() and similar.
1830 Perl_rpp_obliterate_stack_to(pTHX_ I32 ix)
1832 #ifdef PERL_RC_STACK
1833 I32 nonrc_base = PL_curstackinfo->si_stack_nonrc_base;
1835 assert(ix <= PL_stack_sp - PL_stack_base);
1836 assert(nonrc_base <= PL_stack_sp - PL_stack_base + 1);
1838 if (nonrc_base && nonrc_base > ix) {
1839 /* abandon any non-refcounted stuff */
1840 PL_stack_sp = PL_stack_base + nonrc_base - 1;
1841 /* and mark the stack as fully refcounted again */
1842 PL_curstackinfo->si_stack_nonrc_base = 0;
1845 if (rpp_stack_is_rc())
1846 rpp_popfree_to(PL_stack_base + ix);
1848 PL_stack_sp = PL_stack_base + ix;
1850 PL_stack_sp = PL_stack_base + ix;
1857 Perl_qerror(pTHX_ SV *err)
1859 PERL_ARGS_ASSERT_QERROR;
1862 if (PL_in_eval & EVAL_KEEPERR) {
1863 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1867 sv_catsv(ERRSV, err);
1871 sv_catsv(PL_errors, err);
1873 Perl_warn(aTHX_ "%" SVf, SVfARG(err));
1876 ++PL_parser->error_count;
1880 if ( PL_parser && (err == NULL ||
1881 PL_parser->error_count >= PERL_STOP_PARSING_AFTER_N_ERRORS)
1883 const char * const name = OutCopFILE(PL_curcop);
1885 U8 raw_error_count = PERL_PARSE_ERROR_COUNT(PL_parser->error_count);
1892 abort_execution(errsv, name);
1895 if (raw_error_count >= PERL_STOP_PARSING_AFTER_N_ERRORS) {
1897 Perl_croak(aTHX_ "%" SVf "%s has too many errors.\n",
1898 SVfARG(errsv), name);
1900 Perl_croak(aTHX_ "%s has too many errors.\n", name);
1907 /* pop a CXt_EVAL context and in addition, if it was a require then
1909 * 0: do nothing extra;
1910 * 1: undef $INC{$name}; croak "$name did not return a true value";
1911 * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1915 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1917 SV *namesv = NULL; /* init to avoid dumb compiler warning */
1921 do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1923 /* keep namesv alive after cx_popeval() */
1924 namesv = cx->blk_eval.old_namesv;
1925 cx->blk_eval.old_namesv = NULL;
1934 HV *inc_hv = GvHVn(PL_incgv);
1937 (void)hv_delete_ent(inc_hv, namesv, G_DISCARD, 0);
1938 fmt = "%" SVf " did not return a true value";
1942 (void)hv_store_ent(inc_hv, namesv, &PL_sv_undef, 0);
1943 fmt = "%" SVf "Compilation failed in require";
1945 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1948 Perl_croak(aTHX_ fmt, SVfARG(errsv));
1953 /* die_unwind(): this is the final destination for the various croak()
1954 * functions. If we're in an eval, unwind the context and other stacks
1955 * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1956 * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1957 * to is a require the exception will be rethrown, as requires don't
1958 * actually trap exceptions.
1962 Perl_die_unwind(pTHX_ SV *msv)
1965 U8 in_eval = PL_in_eval;
1966 PERL_ARGS_ASSERT_DIE_UNWIND;
1971 /* We need to keep this SV alive through all the stack unwinding
1972 * and FREETMPSing below, while ensuing that it doesn't leak
1973 * if we call out to something which then dies (e.g. sub STORE{die}
1974 * when unlocalising a tied var). So we do a dance with
1975 * mortalising and SAVEFREEing.
1977 if (PL_phase == PERL_PHASE_DESTRUCT) {
1978 exceptsv = sv_mortalcopy(exceptsv);
1980 exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1984 * Historically, perl used to set ERRSV ($@) early in the die
1985 * process and rely on it not getting clobbered during unwinding.
1986 * That sucked, because it was liable to get clobbered, so the
1987 * setting of ERRSV used to emit the exception from eval{} has
1988 * been moved to much later, after unwinding (see just before
1989 * JMPENV_JUMP below). However, some modules were relying on the
1990 * early setting, by examining $@ during unwinding to use it as
1991 * a flag indicating whether the current unwinding was caused by
1992 * an exception. It was never a reliable flag for that purpose,
1993 * being totally open to false positives even without actual
1994 * clobberage, but was useful enough for production code to
1995 * semantically rely on it.
1997 * We'd like to have a proper introspective interface that
1998 * explicitly describes the reason for whatever unwinding
1999 * operations are currently in progress, so that those modules
2000 * work reliably and $@ isn't further overloaded. But we don't
2001 * have one yet. In its absence, as a stopgap measure, ERRSV is
2002 * now *additionally* set here, before unwinding, to serve as the
2003 * (unreliable) flag that it used to.
2005 * This behaviour is temporary, and should be removed when a
2006 * proper way to detect exceptional unwinding has been developed.
2007 * As of 2010-12, the authors of modules relying on the hack
2008 * are aware of the issue, because the modules failed on
2009 * perls 5.13.{1..7} which had late setting of $@ without this
2010 * early-setting hack.
2012 if (!(in_eval & EVAL_KEEPERR)) {
2013 /* remove any read-only/magic from the SV, so we don't
2014 get infinite recursion when setting ERRSV */
2016 sv_setsv_flags(ERRSV, exceptsv,
2017 (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
2020 if (in_eval & EVAL_KEEPERR) {
2021 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
2025 while ((cxix = dopoptoeval(cxstack_ix)) < 0
2026 && PL_curstackinfo->si_prev)
2029 rpp_obliterate_stack_to(0);
2036 JMPENV *restartjmpenv;
2039 if (cxix < cxstack_ix)
2043 assert(CxTYPE(cx) == CXt_EVAL);
2045 rpp_obliterate_stack_to(cx->blk_oldsp);
2047 /* return false to the caller of eval */
2048 gimme = cx->blk_gimme;
2049 if (gimme == G_SCALAR)
2050 rpp_xpush_IMM(&PL_sv_undef);
2052 restartjmpenv = cx->blk_eval.cur_top_env;
2053 restartop = cx->blk_eval.retop;
2055 /* We need a FREETMPS here to avoid late-called destructors
2056 * clobbering $@ *after* we set it below, e.g.
2057 * sub DESTROY { eval { die "X" } }
2058 * eval { my $x = bless []; die $x = 0, "Y" };
2060 * Here the clearing of the $x ref mortalises the anon array,
2061 * which needs to be freed *before* $& is set to "Y",
2062 * otherwise it gets overwritten with "X".
2064 * However, the FREETMPS will clobber exceptsv, so preserve it
2065 * on the savestack for now.
2067 SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv));
2069 /* now we're about to pop the savestack, so re-mortalise it */
2070 sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
2072 /* Note that unlike pp_entereval, pp_require isn't supposed to
2073 * trap errors. So if we're a require, after we pop the
2074 * CXt_EVAL that pp_require pushed, rethrow the error with
2075 * croak(exceptsv). This is all handled by the call below when
2078 S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
2080 if (!(in_eval & EVAL_KEEPERR)) {
2082 sv_setsv(ERRSV, exceptsv);
2084 PL_restartjmpenv = restartjmpenv;
2085 PL_restartop = restartop;
2087 NOT_REACHED; /* NOTREACHED */
2091 write_to_stderr(exceptsv);
2093 NOT_REACHED; /* NOTREACHED */
2099 SV *left = PL_stack_sp[0];
2100 SV *right = PL_stack_sp[-1];
2101 rpp_replace_2_IMM_NN(SvTRUE_NN(left) != SvTRUE_NN(right)
2110 =for apidoc_section $CV
2112 =for apidoc caller_cx
2114 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
2115 returned C<PERL_CONTEXT> structure can be interrogated to find all the
2116 information returned to Perl by C<caller>. Note that XSUBs don't get a
2117 stack frame, so C<caller_cx(0, NULL)> will return information for the
2118 immediately-surrounding Perl code.
2120 This function skips over the automatic calls to C<&DB::sub> made on the
2121 behalf of the debugger. If the stack frame requested was a sub called by
2122 C<DB::sub>, the return value will be the frame for the call to
2123 C<DB::sub>, since that has the correct line number/etc. for the call
2124 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
2125 frame for the sub call itself.
2130 const PERL_CONTEXT *
2131 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
2133 I32 cxix = dopopto_cursub();
2134 const PERL_CONTEXT *cx;
2135 const PERL_CONTEXT *ccstack = cxstack;
2136 const PERL_SI *top_si = PL_curstackinfo;
2139 /* we may be in a higher stacklevel, so dig down deeper */
2140 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
2141 top_si = top_si->si_prev;
2142 ccstack = top_si->si_cxstack;
2143 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
2147 /* caller() should not report the automatic calls to &DB::sub */
2148 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
2149 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
2153 cxix = dopoptosub_at(ccstack, cxix - 1);
2156 cx = &ccstack[cxix];
2157 if (dbcxp) *dbcxp = cx;
2159 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2160 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
2161 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
2162 field below is defined for any cx. */
2163 /* caller() should not report the automatic calls to &DB::sub */
2164 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2165 cx = &ccstack[dbcxix];
2171 PP_wrapped(pp_caller, MAXARG, 0)
2174 const PERL_CONTEXT *cx;
2175 const PERL_CONTEXT *dbcx;
2177 const HEK *stash_hek;
2179 bool has_arg = MAXARG && TOPs;
2188 cx = caller_cx(count + cBOOL(PL_op->op_private & OPpOFFBYONE), &dbcx);
2190 if (gimme != G_LIST) {
2197 /* populate @DB::args ? */
2198 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
2199 && CopSTASH_eq(PL_curcop, PL_debstash))
2201 /* slot 0 of the pad contains the original @_ */
2202 AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
2203 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2204 cx->blk_sub.olddepth+1]))[0]);
2205 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
2207 Perl_init_dbargs(aTHX);
2209 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
2210 av_extend(PL_dbargs, AvFILLp(ary) + off);
2212 /* Alias elements of @_ to @DB::args */
2213 for (SSize_t i = AvFILLp(ary) + off; i >= 0; i--) {
2214 SV* sv = AvALLOC(ary)[i];
2215 /* for a shifted @_, the elements between AvALLOC and AvARRAY
2216 * point to old SVs which may have been freed or even
2217 * reallocated in the meantime. In the interests of
2218 * reconstructing the original @_ before any shifting, use
2219 * those old values, even at the risk of them being wrong.
2220 * But if the ref count is 0, then don't use it because
2221 * further assigning that value anywhere will panic.
2222 * Of course there's nothing to stop a RC != 0 SV being
2223 * subsequently freed, but hopefully people quickly copy the
2224 * contents of @DB::args before doing anything else.
2226 if (sv && (SvREFCNT(sv) == 0 || SvIS_FREED(sv)))
2228 AvARRAY(PL_dbargs)[i] = sv;
2230 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
2233 CX_DEBUG(cx, "CALLER");
2234 assert(CopSTASH(cx->blk_oldcop));
2235 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
2236 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
2238 if (gimme != G_LIST) {
2241 PUSHs(&PL_sv_undef);
2244 sv_sethek(TARG, stash_hek);
2253 PUSHs(&PL_sv_undef);
2256 sv_sethek(TARG, stash_hek);
2259 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
2260 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
2261 cx->blk_sub.retop, TRUE);
2263 lcop = cx->blk_oldcop;
2264 mPUSHu(CopLINE(lcop));
2267 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2268 /* So is ccstack[dbcxix]. */
2269 if (CvHASGV(dbcx->blk_sub.cv)) {
2270 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
2271 PUSHs(boolSV(CxHASARGS(cx)));
2274 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
2275 PUSHs(boolSV(CxHASARGS(cx)));
2279 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
2282 gimme = cx->blk_gimme;
2283 if (gimme == G_VOID)
2284 PUSHs(&PL_sv_undef);
2286 PUSHs(boolSV((gimme & G_WANT) == G_LIST));
2287 if (CxTYPE(cx) == CXt_EVAL) {
2289 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
2290 SV *cur_text = cx->blk_eval.cur_text;
2291 if (SvCUR(cur_text) >= 2) {
2292 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
2293 SvUTF8(cur_text)|SVs_TEMP));
2296 /* I think this is will always be "", but be sure */
2297 PUSHs(sv_2mortal(newSVsv(cur_text)));
2303 else if (cx->blk_eval.old_namesv) {
2304 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
2307 /* eval BLOCK (try blocks have old_namesv == 0) */
2309 PUSHs(&PL_sv_undef);
2310 PUSHs(&PL_sv_undef);
2314 PUSHs(&PL_sv_undef);
2315 PUSHs(&PL_sv_undef);
2318 mPUSHi(CopHINTS_get(cx->blk_oldcop));
2321 char *old_warnings = cx->blk_oldcop->cop_warnings;
2323 if (old_warnings == pWARN_NONE)
2324 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
2325 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
2326 mask = &PL_sv_undef ;
2327 else if (old_warnings == pWARN_ALL ||
2328 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
2329 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
2332 mask = newSVpvn(old_warnings, RCPV_LEN(old_warnings));
2336 PUSHs(cx->blk_oldcop->cop_hints_hash ?
2337 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2343 PP_wrapped(pp_reset, MAXARG, 0)
2348 if (MAXARG < 1 || (!TOPs && !POPs)) {
2350 tmps = NULL, len = 0;
2353 tmps = SvPVx_const(POPs, len);
2354 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
2359 /* like pp_nextstate, but used instead when the debugger is active */
2363 PL_curcop = (COP*)PL_op;
2364 TAINT_NOT; /* Each statement is presumed innocent */
2365 rpp_popfree_to_NN(PL_stack_base + CX_CUR()->blk_oldsp);
2370 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2371 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2374 const U8 gimme = G_LIST;
2375 GV * const gv = PL_DBgv;
2378 if (gv && isGV_with_GP(gv))
2381 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2382 DIE(aTHX_ "No DB::DB routine defined");
2384 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2385 /* don't do recursive DB::DB call */
2392 /* I suspect that saving the stack position is no longer
2393 * required. It was added in 5.001 by:
2395 * NETaa13155: &DB::DB left trash on the stack.
2396 * From: Thomas Koenig
2397 * Files patched: lib/perl5db.pl pp_ctl.c
2398 * The call by pp_dbstate() to &DB::DB left trash on the
2399 * stack. It now calls DB in list context, and DB returns
2402 * but the details of what bug it fixed are long lost to
2403 * history. SAVESTACK_POS() doesn't work well with stacks
2404 * which may be split into partly reference-counted and partly
2405 * not halves, so skip it and hope it doesn't cause any
2408 #ifndef PERL_RC_STACK
2412 PUSHMARK(PL_stack_sp);
2419 #ifdef PERL_RC_STACK
2420 assert(!PL_curstackinfo->si_stack_nonrc_base);
2422 cx = cx_pushblock(CXt_SUB, gimme, PL_stack_sp, PL_savestack_ix);
2423 cx_pushsub(cx, cv, PL_op->op_next, 0);
2424 /* OP_DBSTATE's op_private holds hint bits rather than
2425 * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2426 * any CxLVAL() flags that have now been mis-calculated */
2431 /* see comment above about SAVESTACK_POS */
2432 #ifndef PERL_RC_STACK
2436 if (CvDEPTH(cv) >= 2)
2437 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2438 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2451 (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2463 assert(CxTYPE(cx) == CXt_BLOCK);
2465 if (PL_op->op_flags & OPf_SPECIAL)
2466 /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */
2467 cx->blk_oldpm = PL_curpm;
2469 oldsp = PL_stack_base + cx->blk_oldsp;
2470 gimme = cx->blk_gimme;
2472 if (gimme == G_VOID)
2473 rpp_popfree_to_NN(oldsp);
2475 leave_adjust_stacks(oldsp, oldsp, gimme,
2476 PL_op->op_private & OPpLVALUE ? 3 : 1);
2486 S_outside_integer(pTHX_ SV *sv)
2489 const NV nv = SvNV_nomg(sv);
2490 if (Perl_isinfnan(nv))
2492 #ifdef NV_PRESERVES_UV
2493 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2496 if (nv <= (NV)IV_MIN)
2499 ((nv > (NV)UV_MAX ||
2500 SvUV_nomg(sv) > (UV)IV_MAX)))
2511 const U8 gimme = GIMME_V;
2512 void *itervarp; /* GV or pad slot of the iteration variable */
2513 SV *itersave; /* the old var in the iterator var slot */
2516 if (PL_op->op_targ) { /* "my" variable */
2517 itervarp = &PAD_SVl(PL_op->op_targ);
2518 itersave = *(SV**)itervarp;
2520 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2521 /* the SV currently in the pad slot is never live during
2522 * iteration (the slot is always aliased to one of the items)
2523 * so it's always stale */
2524 SvPADSTALE_on(itersave);
2526 SvREFCNT_inc_simple_void_NN(itersave);
2527 cxflags = CXp_FOR_PAD;
2530 SV * const sv = *PL_stack_sp;
2531 itervarp = (void *)sv;
2532 if (LIKELY(isGV(sv))) { /* symbol table variable */
2533 itersave = GvSV(sv);
2534 SvREFCNT_inc_simple_void(itersave);
2535 cxflags = CXp_FOR_GV;
2536 if (PL_op->op_private & OPpITER_DEF)
2537 cxflags |= CXp_FOR_DEF;
2539 else { /* LV ref: for \$foo (...) */
2540 assert(SvTYPE(sv) == SVt_PVMG);
2541 assert(SvMAGIC(sv));
2542 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2544 cxflags = CXp_FOR_LVREF;
2546 /* we transfer ownership of 1 ref count of itervarp from the stack
2547 * to the CX entry, so no SvREFCNT_dec() needed */
2548 (void)rpp_pop_1_norc();
2550 /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2551 assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2553 /* Note that this context is initially set as CXt_NULL. Further on
2554 * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2555 * there mustn't be anything in the blk_loop substruct that requires
2556 * freeing or undoing, in case we die in the meantime. And vice-versa.
2558 cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2559 cx_pushloop_for(cx, itervarp, itersave);
2561 if (PL_op->op_flags & OPf_STACKED) {
2562 /* OPf_STACKED implies either a single array: for(@), with a
2563 * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2565 SV *maybe_ary = *PL_stack_sp;
2566 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2568 SV* sv = PL_stack_sp[-1];
2569 SV * const right = maybe_ary;
2570 if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2571 DIE(aTHX_ "Assigned value is not a reference");
2574 if (RANGE_IS_NUMERIC(sv,right)) {
2575 cx->cx_type |= CXt_LOOP_LAZYIV;
2576 if (S_outside_integer(aTHX_ sv) ||
2577 S_outside_integer(aTHX_ right))
2578 DIE(aTHX_ "Range iterator outside integer range");
2579 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2580 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2584 cx->cx_type |= CXt_LOOP_LAZYSV;
2585 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2586 cx->blk_loop.state_u.lazysv.end = right;
2588 /* we transfer ownership of 1 ref count of right from the
2589 * stack to the CX .end entry, so no SvREFCNT_dec() needed */
2590 (void)rpp_pop_1_norc();
2592 rpp_popfree_1_NN(); /* free the (now copied) start SV */
2593 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2594 /* This will do the upgrade to SVt_PV, and warn if the value
2595 is uninitialised. */
2596 (void) SvPV_nolen_const(right);
2597 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2598 to replace !SvOK() with a pointer to "". */
2600 SvREFCNT_dec(right);
2601 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2605 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2606 /* for (@array) {} */
2607 cx->cx_type |= CXt_LOOP_ARY;
2608 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2609 /* we transfer ownership of 1 ref count of the av from the
2610 * stack to the CX .ary entry, so no SvREFCNT_dec() needed */
2611 (void)rpp_pop_1_norc();
2612 cx->blk_loop.state_u.ary.ix =
2613 (PL_op->op_private & OPpITER_REVERSED) ?
2614 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2617 /* rpp_extend(1) not needed in this branch
2618 * because we just popped 1 item */
2620 else { /* iterating over items on the stack */
2621 cx->cx_type |= CXt_LOOP_LIST;
2622 cx->blk_oldsp = PL_stack_sp - PL_stack_base;
2623 cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2624 cx->blk_loop.state_u.stack.ix =
2625 (PL_op->op_private & OPpITER_REVERSED)
2627 : cx->blk_loop.state_u.stack.basesp;
2628 /* pre-extend stack so pp_iter doesn't have to check every time
2629 * it pushes yes/no */
2639 const U8 gimme = GIMME_V;
2641 cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2642 cx_pushloop_plain(cx);
2655 assert(CxTYPE_is_LOOP(cx));
2656 oldsp = PL_stack_base + cx->blk_oldsp;
2657 base = CxTYPE(cx) == CXt_LOOP_LIST
2658 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2660 gimme = cx->blk_gimme;
2662 if (gimme == G_VOID)
2663 rpp_popfree_to_NN(base);
2665 leave_adjust_stacks(oldsp, base, gimme,
2666 PL_op->op_private & OPpLVALUE ? 3 : 1);
2669 cx_poploop(cx); /* Stack values are safe: release loop vars ... */
2677 /* This duplicates most of pp_leavesub, but with additional code to handle
2678 * return args in lvalue context. It was forked from pp_leavesub to
2679 * avoid slowing down that function any further.
2681 * Any changes made to this function may need to be copied to pp_leavesub
2684 * also tail-called by pp_return
2695 assert(CxTYPE(cx) == CXt_SUB);
2697 if (CxMULTICALL(cx)) {
2698 /* entry zero of a stack is always PL_sv_undef, which
2699 * simplifies converting a '()' return into undef in scalar context */
2700 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2704 gimme = cx->blk_gimme;
2705 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2707 if (gimme == G_VOID)
2708 rpp_popfree_to_NN(oldsp);
2710 U8 lval = CxLVAL(cx);
2711 bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2712 const char *what = NULL;
2714 if (gimme == G_SCALAR) {
2716 /* check for bad return arg */
2717 if (oldsp < PL_stack_sp) {
2718 SV *sv = *PL_stack_sp;
2719 if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2721 SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2722 : "a readonly value" : "a temporary";
2727 /* sub:lvalue{} will take us here. */
2732 "Can't return %s from lvalue subroutine", what);
2736 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2738 if (lval & OPpDEREF) {
2739 /* lval_sub()->{...} and similar */
2740 SvGETMAGIC(*PL_stack_sp);
2741 if (!SvOK(*PL_stack_sp)) {
2742 SV *sv = vivify_ref(*PL_stack_sp, CxLVAL(cx) & OPpDEREF);
2743 rpp_replace_1_1_NN(sv);
2748 assert(gimme == G_LIST);
2749 assert (!(lval & OPpDEREF));
2752 /* scan for bad return args */
2754 for (p = PL_stack_sp; p > oldsp; p--) {
2756 /* the PL_sv_undef exception is to allow things like
2757 * this to work, where PL_sv_undef acts as 'skip'
2758 * placeholder on the LHS of list assigns:
2759 * sub foo :lvalue { undef }
2760 * ($a, undef, foo(), $b) = 1..4;
2762 if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2764 /* Might be flattened array after $#array = */
2765 what = SvREADONLY(sv)
2766 ? "a readonly value" : "a temporary";
2772 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2777 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
2779 retop = cx->blk_sub.retop;
2785 static const char *S_defer_blockname(PERL_CONTEXT *cx)
2787 return (cx->cx_type & CXp_FINALLY) ? "finally" : "defer";
2795 I32 cxix = dopopto_cursub();
2797 assert(cxstack_ix >= 0);
2798 if (cxix < cxstack_ix) {
2800 /* Check for defer { return; } */
2801 for(i = cxstack_ix; i > cxix; i--) {
2802 if(CxTYPE(&cxstack[i]) == CXt_DEFER)
2803 /* diag_listed_as: Can't "%s" out of a "defer" block */
2804 /* diag_listed_as: Can't "%s" out of a "finally" block */
2805 Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
2806 "return", S_defer_blockname(&cxstack[i]));
2809 if (!( PL_curstackinfo->si_type == PERLSI_SORT
2810 || ( PL_curstackinfo->si_type == PERLSI_MULTICALL
2811 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2814 DIE(aTHX_ "Can't return outside a subroutine");
2816 * a sort block, which is a CXt_NULL not a CXt_SUB;
2817 * or a /(?{...})/ block.
2818 * Handle specially. */
2819 assert(CxTYPE(&cxstack[0]) == CXt_NULL
2820 || ( CxTYPE(&cxstack[0]) == CXt_SUB
2821 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2822 if (cxstack_ix > 0) {
2823 /* See comment below about context popping. Since we know
2824 * we're scalar and not lvalue, we can preserve the return
2825 * value in a simpler fashion than there. */
2826 SV *sv = *PL_stack_sp;
2827 assert(cxstack[0].blk_gimme == G_SCALAR);
2828 if ( (PL_stack_sp != PL_stack_base)
2829 && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2831 #ifdef PERL_RC_STACK
2832 rpp_replace_at_norc(PL_stack_sp, newSVsv(sv));
2834 *PL_stack_sp = sv_mortalcopy(sv);
2838 /* caller responsible for popping cxstack[0] */
2842 /* There are contexts that need popping. Doing this may free the
2843 * return value(s), so preserve them first: e.g. popping the plain
2844 * loop here would free $x:
2845 * sub f { { my $x = 1; return $x } }
2846 * We may also need to shift the args down; for example,
2847 * for (1,2) { return 3,4 }
2848 * leaves 1,2,3,4 on the stack. Both these actions will be done by
2849 * leave_adjust_stacks(), along with freeing any temps. Note that
2850 * whoever we tail-call (e.g. pp_leaveeval) will also call
2851 * leave_adjust_stacks(); however, the second call is likely to
2852 * just see a bunch of SvTEMPs with a ref count of 1, and so just
2853 * pass them through, rather than copying them again. So this
2854 * isn't as inefficient as it sounds.
2856 cx = &cxstack[cxix];
2857 if (cx->blk_gimme != G_VOID)
2858 leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2860 CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2863 cx = &cxstack[cxix]; /* CX stack may have been realloced */
2866 /* Like in the branch above, we need to handle any extra junk on
2867 * the stack. But because we're not also popping extra contexts, we
2868 * don't have to worry about prematurely freeing args. So we just
2869 * need to do the bare minimum to handle junk, and leave the main
2870 * arg processing in the function we tail call, e.g. pp_leavesub.
2871 * In list context we have to splice out the junk; in scalar
2872 * context we can leave as-is (pp_leavesub will later return the
2873 * top stack element). But for an empty arg list, e.g.
2874 * for (1,2) { return }
2875 * we need to set PL_stack_sp = oldsp so that pp_leavesub knows to
2876 * push &PL_sv_undef onto the stack.
2879 cx = &cxstack[cxix];
2880 oldsp = PL_stack_base + cx->blk_oldsp;
2881 if (oldsp != MARK) {
2882 SSize_t nargs = PL_stack_sp - MARK;
2884 if (cx->blk_gimme == G_LIST) {
2885 /* shift return args to base of call stack frame */
2886 #ifdef PERL_RC_STACK
2887 /* free the items on the stack that will get
2890 for (p = MARK; p > oldsp; p--) {
2896 Move(MARK + 1, oldsp + 1, nargs, SV*);
2897 PL_stack_sp = oldsp + nargs;
2901 rpp_popfree_to_NN(oldsp);
2905 /* fall through to a normal exit */
2906 switch (CxTYPE(cx)) {
2908 return CxEVALBLOCK(cx)
2909 ? Perl_pp_leavetry(aTHX)
2910 : Perl_pp_leaveeval(aTHX);
2912 return CvLVALUE(cx->blk_sub.cv)
2913 ? Perl_pp_leavesublv(aTHX)
2914 : Perl_pp_leavesub(aTHX);
2916 return Perl_pp_leavewrite(aTHX);
2918 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2922 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2924 static PERL_CONTEXT *
2928 if (PL_op->op_flags & OPf_SPECIAL) {
2929 cxix = dopoptoloop(cxstack_ix);
2931 /* diag_listed_as: Can't "last" outside a loop block */
2932 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2941 if (PL_op->op_flags & OPf_STACKED) {
2943 label = SvPV(sv, label_len);
2944 label_flags = SvUTF8(sv);
2947 sv = NULL; /* not needed, but shuts up compiler warn */
2948 label = cPVOP->op_pv;
2949 label_len = strlen(label);
2950 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2953 cxix = dopoptolabel(label, label_len, label_flags);
2955 /* diag_listed_as: Label not found for "last %s" */
2956 Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"",
2958 SVfARG(PL_op->op_flags & OPf_STACKED
2961 : newSVpvn_flags(label,
2963 label_flags | SVs_TEMP)));
2964 if (PL_op->op_flags & OPf_STACKED)
2968 if (cxix < cxstack_ix) {
2970 /* Check for defer { last ... } etc */
2971 for(i = cxstack_ix; i > cxix; i--) {
2972 if(CxTYPE(&cxstack[i]) == CXt_DEFER)
2973 /* diag_listed_as: Can't "%s" out of a "defer" block */
2974 /* diag_listed_as: Can't "%s" out of a "finally" block */
2975 Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
2976 OP_NAME(PL_op), S_defer_blockname(&cxstack[i]));
2980 return &cxstack[cxix];
2989 cx = S_unwind_loop(aTHX);
2991 assert(CxTYPE_is_LOOP(cx));
2992 rpp_popfree_to_NN(PL_stack_base
2993 + (CxTYPE(cx) == CXt_LOOP_LIST
2994 ? cx->blk_loop.state_u.stack.basesp
3000 /* Stack values are safe: */
3002 cx_poploop(cx); /* release loop vars ... */
3004 nextop = cx->blk_loop.my_op->op_lastop->op_next;
3014 /* if not a bare 'next' in the main scope, search for it */
3016 if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
3017 cx = S_unwind_loop(aTHX);
3020 PL_curcop = cx->blk_oldcop;
3022 return (cx)->blk_loop.my_op->op_nextop;
3027 PERL_CONTEXT *cx = S_unwind_loop(aTHX);
3028 OP* redo_op = cx->blk_loop.my_op->op_redoop;
3030 if (redo_op->op_type == OP_ENTER) {
3031 /* pop one less context to avoid $x being freed in while (my $x..) */
3034 assert(CxTYPE(cx) == CXt_BLOCK);
3035 redo_op = redo_op->op_next;
3041 PL_curcop = cx->blk_oldcop;
3046 #define UNENTERABLE (OP *)1
3047 #define GOTO_DEPTH 64
3050 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
3053 static const char* const too_deep = "Target of goto is too deeply nested";
3055 PERL_ARGS_ASSERT_DOFINDLABEL;
3058 Perl_croak(aTHX_ "%s", too_deep);
3059 if (o->op_type == OP_LEAVE ||
3060 o->op_type == OP_SCOPE ||
3061 o->op_type == OP_LEAVELOOP ||
3062 o->op_type == OP_LEAVESUB ||
3063 o->op_type == OP_LEAVETRY ||
3064 o->op_type == OP_LEAVEGIVEN)
3066 *ops++ = cUNOPo->op_first;
3068 else if (oplimit - opstack < GOTO_DEPTH) {
3069 if (o->op_flags & OPf_KIDS
3070 && cUNOPo->op_first->op_type == OP_PUSHMARK) {
3071 *ops++ = UNENTERABLE;
3073 else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type]
3074 && OP_CLASS(o) != OA_LOGOP
3075 && o->op_type != OP_LINESEQ
3076 && o->op_type != OP_SREFGEN
3077 && o->op_type != OP_ENTEREVAL
3078 && o->op_type != OP_GLOB
3079 && o->op_type != OP_RV2CV) {
3080 OP * const kid = cUNOPo->op_first;
3081 if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid))
3082 *ops++ = UNENTERABLE;
3086 Perl_croak(aTHX_ "%s", too_deep);
3088 if (o->op_flags & OPf_KIDS) {
3090 OP * const kid1 = cUNOPo->op_first;
3091 /* First try all the kids at this level, since that's likeliest. */
3092 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3093 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3094 STRLEN kid_label_len;
3095 U32 kid_label_flags;
3096 const char *kid_label = CopLABEL_len_flags(kCOP,
3097 &kid_label_len, &kid_label_flags);
3099 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
3102 (const U8*)kid_label, kid_label_len,
3103 (const U8*)label, len) == 0)
3105 (const U8*)label, len,
3106 (const U8*)kid_label, kid_label_len) == 0)
3107 : ( len == kid_label_len && ((kid_label == label)
3108 || memEQ(kid_label, label, len)))))
3112 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3113 bool first_kid_of_binary = FALSE;
3114 if (kid == PL_lastgotoprobe)
3116 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3119 else if (ops[-1] != UNENTERABLE
3120 && (ops[-1]->op_type == OP_NEXTSTATE ||
3121 ops[-1]->op_type == OP_DBSTATE))
3126 if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) {
3127 first_kid_of_binary = TRUE;
3130 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit))) {
3131 if (kid->op_type == OP_PUSHDEFER)
3132 Perl_croak(aTHX_ "Can't \"goto\" into a \"defer\" block");
3135 if (first_kid_of_binary)
3136 *ops++ = UNENTERABLE;
3145 S_check_op_type(pTHX_ OP * const o)
3147 /* Eventually we may want to stack the needed arguments
3148 * for each op. For now, we punt on the hard ones. */
3149 /* XXX This comment seems to me like wishful thinking. --sprout */
3150 if (o == UNENTERABLE)
3152 "Can't \"goto\" into a binary or list expression");
3153 if (o->op_type == OP_ENTERITER)
3155 "Can't \"goto\" into the middle of a foreach loop");
3156 if (o->op_type == OP_ENTERGIVEN)
3158 "Can't \"goto\" into a \"given\" block");
3161 /* also used for: pp_dump() */
3168 OP *enterops[GOTO_DEPTH];
3169 const char *label = NULL;
3170 STRLEN label_len = 0;
3171 U32 label_flags = 0;
3172 const bool do_dump = (PL_op->op_type == OP_DUMP);
3173 static const char* const must_have_label = "goto must have label";
3175 if (PL_op->op_flags & OPf_STACKED) {
3176 /* goto EXPR or goto &foo */
3178 SV * const sv = *PL_stack_sp;
3181 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
3182 /* This egregious kludge implements goto &subroutine */
3185 CV *cv = MUTABLE_CV(SvRV(sv));
3186 AV *arg = GvAV(PL_defgv);
3189 while (!CvROOT(cv) && !CvXSUB(cv)) {
3190 const GV * const gv = CvGV(cv);
3194 /* autoloaded stub? */
3195 if (cv != GvCV(gv) && (cv = GvCV(gv)))
3197 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
3199 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
3200 if (autogv && (cv = GvCV(autogv)))
3202 tmpstr = sv_newmortal();
3203 gv_efullname3(tmpstr, gv, NULL);
3204 DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
3206 DIE(aTHX_ "Goto undefined subroutine");
3209 cxix = dopopto_cursub();
3211 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
3213 cx = &cxstack[cxix];
3214 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
3215 if (CxTYPE(cx) == CXt_EVAL) {
3217 /* diag_listed_as: Can't goto subroutine from an eval-%s */
3218 DIE(aTHX_ "Can't goto subroutine from an eval-string");
3220 /* diag_listed_as: Can't goto subroutine from an eval-%s */
3221 DIE(aTHX_ "Can't goto subroutine from an eval-block");
3223 else if (CxMULTICALL(cx))
3224 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
3226 /* Check for defer { goto &...; } */
3227 for(ix = cxstack_ix; ix > cxix; ix--) {
3228 if(CxTYPE(&cxstack[ix]) == CXt_DEFER)
3229 /* diag_listed_as: Can't "%s" out of a "defer" block */
3230 Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
3231 "goto", S_defer_blockname(&cxstack[ix]));
3234 /* First do some returnish stuff. */
3236 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
3237 rpp_popfree_1_NN(); /* safe to free original sv now */
3240 if (cxix < cxstack_ix) {
3246 /* protect @_ during save stack unwind. */
3248 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
3250 assert(PL_scopestack_ix == cx->blk_oldscopesp);
3253 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
3254 /* this is part of cx_popsub_args() */
3255 AV* av = MUTABLE_AV(PAD_SVl(0));
3256 assert(AvARRAY(MUTABLE_AV(
3257 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
3258 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
3260 /* we are going to donate the current @_ from the old sub
3261 * to the new sub. This first part of the donation puts a
3262 * new empty AV in the pad[0] slot of the old sub,
3263 * unless pad[0] and @_ differ (e.g. if the old sub did
3264 * local *_ = []); in which case clear the old pad[0]
3265 * array in the usual way */
3267 if (av != arg && !SvMAGICAL(av) && SvREFCNT(av) == 1
3268 #ifndef PERL_RC_STACK
3272 clear_defarray_simple(av);
3274 clear_defarray(av, av == arg);
3277 /* don't restore PL_comppad here. It won't be needed if the
3278 * sub we're going to is non-XS, but restoring it early then
3279 * croaking (e.g. the "Goto undefined subroutine" below)
3280 * means the CX block gets processed again in dounwind,
3281 * but this time with the wrong PL_comppad */
3283 /* A destructor called during LEAVE_SCOPE could have undefined
3284 * our precious cv. See bug #99850. */
3285 if (!CvROOT(cv) && !CvXSUB(cv)) {
3286 const GV * const gv = CvGV(cv);
3288 SV * const tmpstr = sv_newmortal();
3289 gv_efullname3(tmpstr, gv, NULL);
3290 DIE(aTHX_ "Goto undefined subroutine &%" SVf,
3293 DIE(aTHX_ "Goto undefined subroutine");
3296 if (CxTYPE(cx) == CXt_SUB) {
3297 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
3298 /*on XS calls defer freeing the old CV as it could
3299 * prematurely set PL_op to NULL, which could cause
3300 * e..g XS subs using GIMME_V to SEGV */
3302 old_cv = cx->blk_sub.cv;
3304 SvREFCNT_dec_NN(cx->blk_sub.cv);
3307 /* Now do some callish stuff. */
3309 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
3310 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
3316 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
3318 SAVEFREESV(old_cv); /* ditto, deferred freeing of old CV */
3320 /* put GvAV(defgv) back onto stack */
3322 rpp_extend(items + 1); /* @_ could have been extended. */
3326 #ifdef PERL_RC_STACK
3327 assert(AvREAL(arg));
3329 bool r = cBOOL(AvREAL(arg));
3331 for (index=0; index<items; index++)
3335 SV ** const svp = av_fetch(arg, index, 0);
3336 sv = svp ? *svp : NULL;
3338 else sv = AvARRAY(arg)[index];
3340 #ifdef PERL_RC_STACK
3344 : newSVavdefelem(arg, index, 1)
3349 ? (r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv)
3350 : sv_2mortal(newSVavdefelem(arg, index, 1))
3356 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
3357 /* Restore old @_ */
3358 CX_POP_SAVEARRAY(cx);
3361 retop = cx->blk_sub.retop;
3362 PL_comppad = cx->blk_sub.prevcomppad;
3363 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
3365 /* Make a temporary a copy of the current GOTO op on the C
3366 * stack, but with a modified gimme (we can't modify the
3367 * real GOTO op as that's not thread-safe). This allows XS
3368 * users of GIMME_V to get the correct calling context,
3369 * even though there is no longer a CXt_SUB frame to
3370 * provide that information.
3372 Copy(PL_op, &fake_goto_op, 1, UNOP);
3373 fake_goto_op.op_flags =
3374 (fake_goto_op.op_flags & ~OPf_WANT)
3375 | (cx->blk_gimme & G_WANT);
3376 PL_op = (OP*)&fake_goto_op;
3378 /* XS subs don't have a CXt_SUB, so pop it;
3379 * this is a cx_popblock(), less all the stuff we already did
3380 * for cx_topblock() earlier */
3381 PL_curcop = cx->blk_oldcop;
3382 /* this is cx_popsub, less all the stuff we already did */
3383 PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
3387 /* Push a mark for the start of arglist */
3394 PADLIST * const padlist = CvPADLIST(cv);
3396 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
3398 /* partial unrolled cx_pushsub(): */
3400 cx->blk_sub.cv = cv;
3401 cx->blk_sub.olddepth = CvDEPTH(cv);
3404 SvREFCNT_inc_simple_void_NN(cv);
3405 if (CvDEPTH(cv) > 1) {
3406 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
3407 sub_crush_depth(cv);
3408 pad_push(padlist, CvDEPTH(cv));
3410 PL_curcop = cx->blk_oldcop;
3411 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
3415 /* second half of donating @_ from the old sub to the
3416 * new sub: abandon the original pad[0] AV in the
3417 * new sub, and replace it with the donated @_.
3418 * pad[0] takes ownership of the extra refcount
3419 * we gave arg earlier */
3421 SvREFCNT_dec(PAD_SVl(0));
3422 PAD_SVl(0) = (SV *)arg;
3423 SvREFCNT_inc_simple_void_NN(arg);
3426 /* GvAV(PL_defgv) might have been modified on scope
3427 exit, so point it at arg again. */
3428 if (arg != GvAV(PL_defgv)) {
3429 AV * const av = GvAV(PL_defgv);
3430 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
3435 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
3436 Perl_get_db_sub(aTHX_ NULL, cv);
3438 CV * const gotocv = get_cvs("DB::goto", 0);
3440 PUSHMARK( PL_stack_sp );
3441 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
3446 retop = CvSTART(cv);
3452 /* avoid premature free of label before popping it off stack */
3453 SvREFCNT_inc_NN(sv);
3456 label = SvPV_nomg_const(sv, label_len);
3457 label_flags = SvUTF8(sv);
3460 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
3461 /* goto LABEL or dump LABEL */
3462 label = cPVOP->op_pv;
3463 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
3464 label_len = strlen(label);
3466 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
3471 OP *gotoprobe = NULL;
3472 bool leaving_eval = FALSE;
3473 bool in_block = FALSE;
3474 bool pseudo_block = FALSE;
3475 PERL_CONTEXT *last_eval_cx = NULL;
3479 PL_lastgotoprobe = NULL;
3481 for (ix = cxstack_ix; ix >= 0; ix--) {
3483 switch (CxTYPE(cx)) {
3485 leaving_eval = TRUE;
3486 if (!CxEVALBLOCK(cx)) {
3487 gotoprobe = (last_eval_cx ?
3488 last_eval_cx->blk_eval.old_eval_root :
3493 /* else fall through */
3494 case CXt_LOOP_PLAIN:
3495 case CXt_LOOP_LAZYIV:
3496 case CXt_LOOP_LAZYSV:
3501 gotoprobe = OpSIBLING(cx->blk_oldcop);
3507 gotoprobe = OpSIBLING(cx->blk_oldcop);
3510 gotoprobe = PL_main_root;
3513 gotoprobe = CvROOT(cx->blk_sub.cv);
3514 pseudo_block = cBOOL(CxMULTICALL(cx));
3518 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3520 /* diag_listed_as: Can't "%s" out of a "defer" block */
3521 DIE(aTHX_ "Can't \"%s\" out of a \"%s\" block", "goto", S_defer_blockname(cx));
3524 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3525 CxTYPE(cx), (long) ix);
3526 gotoprobe = PL_main_root;
3532 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3533 enterops, enterops + GOTO_DEPTH);
3536 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3537 sibl1->op_type == OP_UNSTACK &&
3538 (sibl2 = OpSIBLING(sibl1)))
3540 retop = dofindlabel(sibl2,
3541 label, label_len, label_flags, enterops,
3542 enterops + GOTO_DEPTH);
3548 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3549 PL_lastgotoprobe = gotoprobe;
3552 DIE(aTHX_ "Can't find label %" UTF8f,
3553 UTF8fARG(label_flags, label_len, label));
3555 /* if we're leaving an eval, check before we pop any frames
3556 that we're not going to punt, otherwise the error
3559 if (leaving_eval && *enterops && enterops[1]) {
3561 for (i = 1; enterops[i]; i++)
3562 S_check_op_type(aTHX_ enterops[i]);
3565 if (*enterops && enterops[1]) {
3566 I32 i = enterops[1] != UNENTERABLE
3567 && enterops[1]->op_type == OP_ENTER && in_block
3571 deprecate_fatal_in(WARN_DEPRECATED__GOTO_CONSTRUCT,
3573 "Use of \"goto\" to jump into a construct");
3576 /* pop unwanted frames */
3578 if (ix < cxstack_ix) {
3580 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3586 /* push wanted frames */
3588 if (*enterops && enterops[1]) {
3589 OP * const oldop = PL_op;
3590 ix = enterops[1] != UNENTERABLE
3591 && enterops[1]->op_type == OP_ENTER && in_block
3594 for (; enterops[ix]; ix++) {
3595 PL_op = enterops[ix];
3596 S_check_op_type(aTHX_ PL_op);
3597 DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n",
3599 PL_op->op_ppaddr(aTHX);
3607 if (!retop) retop = PL_main_start;
3609 PL_restartop = retop;
3610 PL_do_undump = TRUE;
3614 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3615 PL_do_undump = FALSE;
3623 PP_wrapped(pp_exit, 1, 0)
3631 anum = 0; (void)POPs;
3637 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3640 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3643 PL_exit_flags |= PERL_EXIT_EXPECTED;
3645 PUSHs(&PL_sv_undef);
3652 S_save_lines(pTHX_ AV *array, SV *sv)
3654 const char *s = SvPVX_const(sv);
3655 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3658 PERL_ARGS_ASSERT_SAVE_LINES;
3660 while (s && s < send) {
3662 SV * const tmpstr = newSV_type(SVt_PVMG);
3664 t = (const char *)memchr(s, '\n', send - s);
3670 sv_setpvn_fresh(tmpstr, s, t - s);
3671 av_store(array, line++, tmpstr);
3679 Interpose, for the current op and RUNOPS loop,
3681 - a new JMPENV stack catch frame, and
3682 - an inner RUNOPS loop to run all the remaining ops following the
3685 Then handle any exceptions raised while in that loop.
3686 For a caught eval at this level, re-enter the loop with the specified
3687 restart op (i.e. the op following the OP_LEAVETRY etc); otherwise re-throw
3690 docatch() is intended to be used like this:
3695 return docatch(Perl_pp_entertry);
3697 ... rest of function ...
3698 return PL_op->op_next;
3701 If a new catch frame isn't needed, the op behaves normally. Otherwise it
3702 calls docatch(), which recursively calls pp_entertry(), this time with
3703 CATCH_GET() false, so the rest of the body of the entertry is run. Then
3704 docatch() calls CALLRUNOPS() which executes all the ops following the
3705 entertry. When the loop finally finishes, control returns to docatch(),
3706 which pops the JMPENV and returns to the parent pp_entertry(), which
3707 itself immediately returns. Note that *all* subsequent ops are run within
3708 the inner RUNOPS loop, not just the body of the eval. For example, in
3710 sub TIEARRAY { eval {1}; my $x }
3713 at the point the 'my' is executed, the C stack will look something like:
3716 #9 perl_run() # JMPENV_PUSH level 1 here
3718 #7 Perl_runops_standard() # main RUNOPS loop
3721 #4 Perl_runops_standard() # unguarded RUNOPS loop: no new JMPENV
3722 #3 Perl_pp_entertry()
3723 #2 S_docatch() # JMPENV_PUSH level 2 here
3724 #1 Perl_runops_standard() # docatch()'s RUNOPs loop
3727 Basically, any section of the perl core which starts a RUNOPS loop may
3728 make a promise that it will catch any exceptions and restart the loop if
3729 necessary. If it's not prepared to do that (like call_sv() isn't), then
3730 it sets CATCH_GET() to true, so that any later eval-like code knows to
3731 set up a new handler and loop (via docatch()).
3733 See L<perlinterp/"Exception handing"> for further details.
3739 S_docatch(pTHX_ Perl_ppaddr_t firstpp)
3742 OP * const oldop = PL_op;
3750 case 0: /* normal flow-of-control return from JMPENV_PUSH */
3752 /* re-run the current op, this time executing the full body of the
3754 PL_op = firstpp(aTHX);
3761 case 3: /* an exception raised within an eval */
3762 if (PL_restartjmpenv == PL_top_env) {
3763 /* die caught by an inner eval - continue inner loop */
3767 PL_restartjmpenv = NULL;
3768 PL_op = PL_restartop;
3777 JMPENV_JUMP(ret); /* re-throw the exception */
3778 NOT_REACHED; /* NOTREACHED */
3787 =for apidoc find_runcv
3789 Locate the CV corresponding to the currently executing sub or eval.
3790 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3791 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3792 entered. (This allows debuggers to eval in the scope of the breakpoint
3793 rather than in the scope of the debugger itself.)
3799 Perl_find_runcv(pTHX_ U32 *db_seqp)
3801 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3804 /* If this becomes part of the API, it might need a better name. */
3806 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3813 PL_curcop == &PL_compiling
3815 : PL_curcop->cop_seq;
3817 for (si = PL_curstackinfo; si; si = si->si_prev) {
3819 for (ix = si->si_cxix; ix >= 0; ix--) {
3820 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3822 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3823 cv = cx->blk_sub.cv;
3824 /* skip DB:: code */
3825 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3826 *db_seqp = cx->blk_oldcop->cop_seq;
3829 if (cx->cx_type & CXp_SUB_RE)
3832 else if (CxTYPE(cx) == CXt_EVAL && !CxEVALBLOCK(cx))
3833 cv = cx->blk_eval.cv;
3836 case FIND_RUNCV_padid_eq:
3838 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3841 case FIND_RUNCV_level_eq:
3842 if (level++ != arg) continue;
3850 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3856 * Run yyparse() in a setjmp wrapper. Returns:
3857 * 0: yyparse() successful
3858 * 1: yyparse() failed
3861 * This is used to trap Perl_croak() calls that are executed
3862 * during the compilation process and before the code has been
3863 * completely compiled. It is expected to be called from
3864 * doeval_compile() only. The parameter 'caller_op' is
3865 * only used in DEBUGGING to validate the logic is working
3868 * See also try_run_unitcheck().
3872 S_try_yyparse(pTHX_ int gramtype, OP *caller_op)
3874 /* if we die during compilation PL_restartop and PL_restartjmpenv
3875 * will be set by Perl_die_unwind(). We need to restore their values
3876 * if that happens as they are intended for the case where the code
3877 * compiles and dies during execution, not where it dies during
3878 * compilation. PL_restartop and caller_op->op_next should be the
3879 * same anyway, and when compilation fails then caller_op->op_next is
3880 * used as the next op after the compile.
3882 JMPENV *restartjmpenv = PL_restartjmpenv;
3883 OP *restartop = PL_restartop;
3886 PERL_UNUSED_ARG(caller_op); /* only used in debugging builds */
3888 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3892 ret = yyparse(gramtype) ? 1 : 0;
3895 /* yyparse() died and we trapped the error. We need to restore
3896 * the old PL_restartjmpenv and PL_restartop values. */
3897 assert(PL_restartop == caller_op->op_next); /* we expect these to match */
3898 PL_restartjmpenv = restartjmpenv;
3899 PL_restartop = restartop;
3904 NOT_REACHED; /* NOTREACHED */
3910 /* S_try_run_unitcheck()
3912 * Run PL_unitcheckav in a setjmp wrapper via call_list.
3914 * 0: unitcheck blocks ran without error
3915 * 3: a unitcheck block died
3917 * This is used to trap Perl_croak() calls that are executed
3918 * during UNITCHECK blocks executed after the compilation
3919 * process has completed but before the code itself has been
3920 * executed via the normal run loops. It is expected to be called
3921 * from doeval_compile() only. The parameter 'caller_op' is
3922 * only used in DEBUGGING to validate the logic is working
3925 * See also try_yyparse().
3928 S_try_run_unitcheck(pTHX_ OP* caller_op)
3930 /* if we die during compilation PL_restartop and PL_restartjmpenv
3931 * will be set by Perl_die_unwind(). We need to restore their values
3932 * if that happens as they are intended for the case where the code
3933 * compiles and dies during execution, not where it dies during
3934 * compilation. UNITCHECK runs after compilation completes, and
3935 * if it dies we will execute the PL_restartop anyway via the
3936 * failed compilation code path. PL_restartop and caller_op->op_next
3937 * should be the same anyway, and when compilation fails then
3938 * caller_op->op_next is used as the next op after the compile.
3940 JMPENV *restartjmpenv = PL_restartjmpenv;
3941 OP *restartop = PL_restartop;
3944 PERL_UNUSED_ARG(caller_op); /* only used in debugging builds */
3946 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3950 call_list(PL_scopestack_ix, PL_unitcheckav);
3953 /* call_list died */
3954 /* call_list() died and we trapped the error. We should restore
3955 * the old PL_restartjmpenv and PL_restartop values, as they are
3956 * used only in the case where the code was actually run.
3957 * The assert validates that we will still execute the PL_restartop.
3959 assert(PL_restartop == caller_op->op_next); /* we expect these to match */
3960 PL_restartjmpenv = restartjmpenv;
3961 PL_restartop = restartop;
3966 NOT_REACHED; /* NOTREACHED */
3972 /* Compile a require/do or an eval ''.
3974 * outside is the lexically enclosing CV (if any) that invoked us.
3975 * seq is the current COP scope value.
3976 * hh is the saved hints hash, if any.
3978 * Returns a bool indicating whether the compile was successful; if so,
3979 * PL_eval_start contains the first op of the compiled code; otherwise,
3982 * This function is called from two places: pp_require and pp_entereval.
3983 * These can be distinguished by whether PL_op is entereval.
3987 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3989 OP * const saveop = PL_op;
3990 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3991 COP * const oldcurcop = PL_curcop;
3992 bool in_require = (saveop->op_type == OP_REQUIRE);
3996 PL_in_eval = (in_require
3997 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3999 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
4000 ? EVAL_RE_REPARSING : 0)));
4002 PUSHMARK(PL_stack_sp);
4004 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
4006 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4007 CX_CUR()->blk_eval.cv = evalcv;
4008 CX_CUR()->blk_gimme = gimme;
4010 CvOUTSIDE_SEQ(evalcv) = seq;
4011 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
4013 /* set up a scratch pad */
4015 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
4016 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
4019 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
4021 /* make sure we compile in the right package */
4023 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
4024 SAVEGENERICSV(PL_curstash);
4025 PL_curstash = (HV *)CopSTASH(PL_curcop);
4026 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
4028 SvREFCNT_inc_simple_void(PL_curstash);
4029 save_item(PL_curstname);
4030 sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash));
4033 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
4034 SAVESPTR(PL_beginav);
4035 PL_beginav = newAV();
4036 SAVEFREESV(PL_beginav);
4037 SAVESPTR(PL_unitcheckav);
4038 PL_unitcheckav = newAV();
4039 SAVEFREESV(PL_unitcheckav);
4042 ENTER_with_name("evalcomp");
4043 SAVESPTR(PL_compcv);
4046 /* try to compile it */
4048 PL_eval_root = NULL;
4049 PL_curcop = &PL_compiling;
4050 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
4051 PL_in_eval |= EVAL_KEEPERR;
4057 PL_hints = HINTS_DEFAULT;
4058 PL_prevailing_version = 0;
4059 hv_clear(GvHV(PL_hintgv));
4063 PL_hints = saveop->op_private & OPpEVAL_COPHH
4064 ? oldcurcop->cop_hints : (U32)saveop->op_targ;
4066 /* making 'use re eval' not be in scope when compiling the
4067 * qr/mabye_has_runtime_code_block/ ensures that we don't get
4068 * infinite recursion when S_has_runtime_code() gives a false
4069 * positive: the second time round, HINT_RE_EVAL isn't set so we
4070 * don't bother calling S_has_runtime_code() */
4071 if (PL_in_eval & EVAL_RE_REPARSING)
4072 PL_hints &= ~HINT_RE_EVAL;
4075 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
4076 SvREFCNT_dec(GvHV(PL_hintgv));
4077 GvHV(PL_hintgv) = hh;
4078 FETCHFEATUREBITSHH(hh);
4081 SAVECOMPILEWARNINGS();
4083 if (PL_dowarn & G_WARN_ALL_ON)
4084 PL_compiling.cop_warnings = pWARN_ALL ;
4085 else if (PL_dowarn & G_WARN_ALL_OFF)
4086 PL_compiling.cop_warnings = pWARN_NONE ;
4088 PL_compiling.cop_warnings = pWARN_STD ;
4091 PL_compiling.cop_warnings =
4092 DUP_WARNINGS(oldcurcop->cop_warnings);
4093 cophh_free(CopHINTHASH_get(&PL_compiling));
4094 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
4095 /* The label, if present, is the first entry on the chain. So rather
4096 than writing a blank label in front of it (which involves an
4097 allocation), just use the next entry in the chain. */
4098 PL_compiling.cop_hints_hash
4099 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
4100 /* Check the assumption that this removed the label. */
4101 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
4104 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
4107 CALL_BLOCK_HOOKS(bhk_eval, saveop);
4109 /* we should never be CATCH_GET true here, as our immediate callers should
4110 * always handle that case. */
4112 /* compile the code */
4115 yystatus = (!in_require)
4116 ? S_try_yyparse(aTHX_ GRAMPROG, saveop)
4117 : yyparse(GRAMPROG);
4119 if (yystatus || PL_parser->error_count || !PL_eval_root) {
4124 if (yystatus != 3) {
4125 /* note that if yystatus == 3, then the require/eval died during
4126 * compilation, so the EVAL CX block has already been popped, and
4127 * various vars restored. This block applies similar steps after
4128 * the other "failed to compile" cases in yyparse, eg, where
4129 * yystatus=1, "failed, but did not die". */
4132 invoke_exception_hook(ERRSV,FALSE);
4134 op_free(PL_eval_root);
4135 PL_eval_root = NULL;
4137 rpp_popfree_to(PL_stack_base + POPMARK); /* pop original mark */
4139 assert(CxTYPE(cx) == CXt_EVAL);
4140 /* If we are in an eval we need to make sure that $SIG{__DIE__}
4141 * handler is invoked so we simulate that part of the
4142 * Perl_die_unwind() process. In a require we will croak
4143 * so it will happen there. */
4144 /* pop the CXt_EVAL, and if was a require, croak */
4145 S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
4149 /* die_unwind() re-croaks when in require, having popped the
4150 * require EVAL context. So we should never catch a require
4152 assert(!in_require);
4155 if (!*(SvPV_nolen_const(errsv)))
4156 sv_setpvs(errsv, "Compilation error");
4158 if (gimme == G_SCALAR) {
4159 if (yystatus == 3) {
4160 /* die_unwind already pushed undef in scalar context */
4161 assert(*PL_stack_sp == &PL_sv_undef);
4164 rpp_xpush_1(&PL_sv_undef);
4170 /* Compilation successful. Now clean up */
4172 LEAVE_with_name("evalcomp");
4174 CopLINE_set(&PL_compiling, 0);
4175 SAVEFREEOP(PL_eval_root);
4176 cv_forget_slab(evalcv);
4178 DEBUG_x(dump_eval());
4180 /* Register with debugger: */
4181 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
4182 CV * const cv = get_cvs("DB::postponed", 0);
4184 PUSHMARK(PL_stack_sp);
4185 rpp_xpush_1(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4186 call_sv(MUTABLE_SV(cv), G_DISCARD);
4190 if (PL_unitcheckav && av_count(PL_unitcheckav)>0) {
4191 OP *es = PL_eval_start;
4192 /* TODO: are we sure we shouldn't do S_try_run_unitcheck()
4193 * when `in_require` is true? */
4195 call_list(PL_scopestack_ix, PL_unitcheckav);
4197 else if (S_try_run_unitcheck(aTHX_ saveop)) {
4198 /* there was an error! */
4204 if (!*(SvPV_nolen_const(errsv))) {
4205 /* This happens when using:
4206 * eval qq# UNITCHECK { die "\x00"; } #;
4208 sv_setpvs(errsv, "Unit check error");
4211 if (gimme != G_LIST)
4212 rpp_xpush_1(&PL_sv_undef);
4218 CvDEPTH(evalcv) = 1;
4219 rpp_popfree_to_NN(PL_stack_base + POPMARK); /* pop original mark */
4220 PL_op = saveop; /* The caller may need it. */
4221 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
4227 /* Return NULL if the file doesn't exist or isn't a file;
4228 * else return PerlIO_openn().
4232 S_check_type_and_open(pTHX_ SV *name)
4237 const char *p = SvPV_const(name, len);
4240 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
4242 /* checking here captures a reasonable error message when
4243 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
4244 * user gets a confusing message about looking for the .pmc file
4245 * rather than for the .pm file so do the check in S_doopen_pm when
4246 * PMC is on instead of here. S_doopen_pm calls this func.
4247 * This check prevents a \0 in @INC causing problems.
4249 #ifdef PERL_DISABLE_PMC
4250 if (!IS_SAFE_PATHNAME(p, len, "require"))
4254 /* on Win32 stat is expensive (it does an open() and close() twice and
4255 a couple other IO calls), the open will fail with a dir on its own with
4256 errno EACCES, so only do a stat to separate a dir from a real EACCES
4257 caused by user perms */
4259 st_rc = PerlLIO_stat(p, &st);
4265 if(S_ISBLK(st.st_mode)) {
4269 else if(S_ISDIR(st.st_mode)) {
4278 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
4280 /* EACCES stops the INC search early in pp_require to implement
4281 feature RT #113422 */
4282 if(!retio && errno == EACCES) { /* exists but probably a directory */
4284 st_rc = PerlLIO_stat(p, &st);
4286 if(S_ISDIR(st.st_mode))
4288 else if(S_ISBLK(st.st_mode))
4299 /* doopen_pm(): return the equivalent of PerlIO_openn() on the given name,
4300 * but first check for bad names (\0) and non-files.
4301 * Also if the filename ends in .pm and unless PERL_DISABLE_PMC,
4302 * try loading Foo.pmc first.
4304 #ifndef PERL_DISABLE_PMC
4306 S_doopen_pm(pTHX_ SV *name)
4309 const char *p = SvPV_const(name, namelen);
4311 PERL_ARGS_ASSERT_DOOPEN_PM;
4313 /* check the name before trying for the .pmc name to avoid the
4314 * warning referring to the .pmc which the user probably doesn't
4315 * know or care about
4317 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
4320 if (memENDPs(p, namelen, ".pm")) {
4321 SV *const pmcsv = sv_newmortal();
4324 SvSetSV_nosteal(pmcsv,name);
4325 sv_catpvs(pmcsv, "c");
4327 pmcio = check_type_and_open(pmcsv);
4331 return check_type_and_open(name);
4334 # define doopen_pm(name) check_type_and_open(name)
4335 #endif /* !PERL_DISABLE_PMC */
4337 /* require doesn't search in @INC for absolute names, or when the name is
4338 explicitly relative the current directory: i.e. ./, ../ */
4339 PERL_STATIC_INLINE bool
4340 S_path_is_searchable(const char *name)
4342 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
4344 if (PERL_FILE_IS_ABSOLUTE(name)
4346 || (*name == '.' && ((name[1] == '/' ||
4347 (name[1] == '.' && name[2] == '/'))
4348 || (name[1] == '\\' ||
4349 ( name[1] == '.' && name[2] == '\\')))
4352 || (*name == '.' && (name[1] == '/' ||
4353 (name[1] == '.' && name[2] == '/')))
4364 /* implement 'require 5.010001' */
4367 S_require_version(pTHX_ SV *sv)
4369 sv = sv_2mortal(new_version(sv));
4372 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
4373 upg_version(PL_patchlevel, TRUE);
4374 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
4375 if ( vcmp(sv,PL_patchlevel) <= 0 )
4376 DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
4377 SVfARG(sv_2mortal(vnormal(sv))),
4378 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
4382 if ( vcmp(sv,PL_patchlevel) > 0 ) {
4385 SV * const req = SvRV(sv);
4386 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
4388 /* get the left hand term */
4389 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
4391 first = SvIV(*av_fetch(lav,0,0));
4392 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
4393 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
4394 || av_count(lav) > 2 /* FP with > 3 digits */
4395 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
4397 DIE(aTHX_ "Perl %" SVf " required--this is only "
4398 "%" SVf ", stopped",
4399 SVfARG(sv_2mortal(vnormal(req))),
4400 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
4403 else { /* probably 'use 5.10' or 'use 5.8' */
4407 if (av_count(lav) > 1)
4408 second = SvIV(*av_fetch(lav,1,0));
4410 second /= second >= 600 ? 100 : 10;
4411 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
4412 (int)first, (int)second);
4413 upg_version(hintsv, TRUE);
4415 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)"
4416 "--this is only %" SVf ", stopped",
4417 SVfARG(sv_2mortal(vnormal(req))),
4418 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
4419 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
4425 rpp_push_IMM(&PL_sv_yes);
4430 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
4431 * The first form will have already been converted at compile time to
4433 * sv is still on the stack at this point. */
4436 S_require_file(pTHX_ SV *sv)
4444 int vms_unixname = 0;
4447 /* tryname is the actual pathname (with @INC prefix) which was loaded.
4448 * It's stored as a value in %INC, and used for error messages */
4449 const char *tryname = NULL;
4450 SV *namesv = NULL; /* SV equivalent of tryname */
4451 const U8 gimme = GIMME_V;
4452 int filter_has_file = 0;
4453 PerlIO *tryrsfp = NULL;
4454 SV *filter_cache = NULL;
4455 SV *filter_state = NULL;
4456 SV *filter_sub = NULL;
4460 bool path_searchable;
4461 I32 old_savestack_ix;
4462 const bool op_is_require = PL_op->op_type == OP_REQUIRE;
4463 const char *const op_name = op_is_require ? "require" : "do";
4464 SV ** svp_cached = NULL;
4466 assert(op_is_require || PL_op->op_type == OP_DOFILE);
4469 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
4470 name = SvPV_nomg_const(sv, len);
4471 if (!(name && len > 0 && *name))
4472 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
4475 PL_hook__require__before
4476 && SvROK(PL_hook__require__before)
4477 && SvTYPE(SvRV(PL_hook__require__before)) == SVt_PVCV
4479 SV* name_sv = sv_mortalcopy(sv);
4480 SV *post_hook__require__before_sv = NULL;
4482 ENTER_with_name("call_PRE_REQUIRE");
4484 PUSHMARK(PL_stack_sp);
4485 rpp_xpush_1(name_sv); /* always use the object for method calls */
4486 call_sv(PL_hook__require__before, G_SCALAR);
4487 SV *rsv = *PL_stack_sp;
4488 if (SvOK(rsv) && SvROK(rsv) && SvTYPE(SvRV(rsv)) == SVt_PVCV) {
4489 /* the RC++ preserves it across the popping and/or FREETMPS
4491 post_hook__require__before_sv = SvREFCNT_inc_simple_NN(rsv);
4494 if (!sv_streq(name_sv,sv)) {
4495 /* they modified the name argument, so do some sleight of hand */
4496 name = SvPV_nomg_const(name_sv, len);
4497 if (!(name && len > 0 && *name))
4498 DIE(aTHX_ "Missing or undefined argument to %s via %%{^HOOK}{require__before}",
4503 LEAVE_with_name("call_PRE_REQUIRE");
4504 if (post_hook__require__before_sv) {
4505 SV *nsv = newSVsv(sv);
4506 MORTALDESTRUCTOR_SV(post_hook__require__before_sv, nsv);
4507 SvREFCNT_dec_NN(nsv);
4508 SvREFCNT_dec_NN(post_hook__require__before_sv);
4512 PL_hook__require__after
4513 && SvROK(PL_hook__require__after)
4514 && SvTYPE(SvRV(PL_hook__require__after)) == SVt_PVCV
4516 SV *nsv = newSVsv(sv);
4517 MORTALDESTRUCTOR_SV(PL_hook__require__after, nsv);
4518 SvREFCNT_dec_NN(nsv);
4522 /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */
4523 if (op_is_require) {
4524 /* can optimize to only perform one single lookup */
4525 svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0);
4527 (SvGETMAGIC(*svp_cached), SvOK(*svp_cached)))
4529 rpp_replace_1_IMM_NN(&PL_sv_yes);
4535 if (!IS_SAFE_PATHNAME(name, len, op_name)) {
4536 if (!op_is_require) {
4538 rpp_replace_1_IMM_NN(&PL_sv_undef);
4541 DIE(aTHX_ "Can't locate %s: %s",
4542 pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
4543 NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
4546 TAINT_PROPER(op_name);
4548 path_searchable = path_is_searchable(name);
4551 /* The key in the %ENV hash is in the syntax of file passed as the argument
4552 * usually this is in UNIX format, but sometimes in VMS format, which
4553 * can result in a module being pulled in more than once.
4554 * To prevent this, the key must be stored in UNIX format if the VMS
4555 * name can be translated to UNIX.
4559 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4561 unixlen = strlen(unixname);
4567 /* if not VMS or VMS name can not be translated to UNIX, pass it
4570 unixname = (char *) name;
4573 if (op_is_require) {
4574 /* reuse the previous hv_fetch result if possible */
4575 SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4577 /* we already did a get magic if this was cached */
4581 rpp_replace_1_IMM_NN(&PL_sv_yes);
4585 DIE(aTHX_ "Attempt to reload %s aborted.\n"
4586 "Compilation failed in require", unixname);
4589 /*XXX OPf_KIDS should always be true? -dapm 4/2017 */
4590 if (PL_op->op_flags & OPf_KIDS) {
4591 SVOP * const kid = cSVOPx(cUNOP->op_first);
4593 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4594 /* Make sure that a bareword module name (e.g. ::Foo::Bar)
4595 * doesn't map to a naughty pathname like /Foo/Bar.pm.
4596 * Note that the parser will normally detect such errors
4597 * at compile time before we reach here, but
4598 * Perl_load_module() can fake up an identical optree
4599 * without going near the parser, and being able to put
4600 * anything as the bareword. So we include a duplicate set
4601 * of checks here at runtime.
4603 const STRLEN package_len = len - 3;
4604 const char slashdot[2] = {'/', '.'};
4606 const char backslashdot[2] = {'\\', '.'};
4609 /* Disallow *purported* barewords that map to absolute
4610 filenames, filenames relative to the current or parent
4611 directory, or (*nix) hidden filenames. Also sanity check
4612 that the generated filename ends .pm */
4613 if (!path_searchable || len < 3 || name[0] == '.'
4614 || !memEQs(name + package_len, len - package_len, ".pm"))
4615 DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv);
4616 if (memchr(name, 0, package_len)) {
4617 /* diag_listed_as: Bareword in require contains "%s" */
4618 DIE(aTHX_ "Bareword in require contains \"\\0\"");
4620 if (ninstr(name, name + package_len, slashdot,
4621 slashdot + sizeof(slashdot))) {
4622 /* diag_listed_as: Bareword in require contains "%s" */
4623 DIE(aTHX_ "Bareword in require contains \"/.\"");
4626 if (ninstr(name, name + package_len, backslashdot,
4627 backslashdot + sizeof(backslashdot))) {
4628 /* diag_listed_as: Bareword in require contains "%s" */
4629 DIE(aTHX_ "Bareword in require contains \"\\.\"");
4636 PERL_DTRACE_PROBE_FILE_LOADING(unixname);
4638 /* Try to locate and open a file, possibly using @INC */
4640 /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load
4641 * the file directly rather than via @INC ... */
4642 if (!path_searchable) {
4643 /* At this point, name is SvPVX(sv) */
4645 tryrsfp = doopen_pm(sv);
4648 /* ... but if we fail, still search @INC for code references;
4649 * these are applied even on non-searchable paths (except
4650 * if we got EACESS).
4652 * For searchable paths, just search @INC normally
4654 AV *inc_checked = (AV*)sv_2mortal((SV*)newAV());
4655 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
4661 AV *incdir_av = (AV*)sv_2mortal((SV*)newAV());
4662 SV *nsv = sv; /* non const copy we can change if necessary */
4663 namesv = newSV_type(SVt_PV);
4664 AV *inc_ar = GvAVn(PL_incgv);
4665 SSize_t incdir_continue_inc_idx = -1;
4669 (AvFILL(incdir_av)>=0 /* we have INCDIR items pending */
4670 || inc_idx <= AvFILL(inc_ar)); /* @INC entries remain */
4675 /* do we have any pending INCDIR items? */
4676 if (AvFILL(incdir_av)>=0) {
4677 /* yep, shift it out */
4678 dirsv = av_shift(incdir_av);
4679 if (AvFILL(incdir_av)<0) {
4680 /* incdir is now empty, continue from where
4681 * we left off after we process this entry */
4682 inc_idx = incdir_continue_inc_idx;
4685 dirsv = *av_fetch(inc_ar, inc_idx, TRUE);
4688 if (SvGMAGICAL(dirsv)) {
4690 dirsv = newSVsv_nomg(dirsv);
4692 /* on the other hand, since we aren't copying we do need
4694 SvREFCNT_inc(dirsv);
4699 av_push(inc_checked, dirsv);
4705 UV diruv = PTR2UV(SvRV(dirsv));
4707 if (SvTYPE(SvRV(loader)) == SVt_PVAV
4708 && !SvOBJECT(SvRV(loader)))
4710 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
4711 if (SvGMAGICAL(loader)) {
4713 SV *l = sv_newmortal();
4714 sv_setsv_nomg(l, loader);
4719 if (SvPADTMP(nsv)) {
4720 nsv = sv_newmortal();
4721 SvSetSV_nosteal(nsv,sv);
4724 const char *method = NULL;
4725 bool is_incdir = FALSE;
4726 SV * inc_idx_sv = save_scalar(PL_incgv);
4727 sv_setiv(inc_idx_sv,inc_idx);
4728 if (sv_isobject(loader)) {
4729 /* if it is an object and it has an INC method, then
4732 HV *pkg = SvSTASH(SvRV(loader));
4733 GV * gv = gv_fetchmethod_pvn_flags(pkg, "INC", 3, GV_AUTOLOAD);
4734 if (gv && isGV(gv)) {
4737 /* no point to autoload here, it would have been found above */
4738 gv = gv_fetchmethod_pvn_flags(pkg, "INCDIR", 6, 0);
4739 if (gv && isGV(gv)) {
4744 /* But if we have no method, check if this is a
4745 * coderef, if it is then we treat it as an
4746 * unblessed coderef would be treated: we
4747 * execute it. If it is some other and it is in
4748 * an array ref wrapper, then really we don't
4749 * know what to do with it, (why use the
4750 * wrapper?) and we throw an exception to help
4751 * debug. If it is not in a wrapper assume it
4752 * has an overload and treat it as a string.
4753 * Maybe in the future we can detect if it does
4754 * have overloading and throw an error if not.
4757 if (SvTYPE(SvRV(loader)) != SVt_PVCV) {
4758 if (amagic_applies(loader,string_amg,AMGf_unary))
4759 goto treat_as_string;
4761 croak("Can't locate object method \"INC\", nor"
4762 " \"INCDIR\" nor string overload via"
4763 " package %" HvNAMEf_QUOTEDPREFIX " %s"
4767 : "in object in ARRAY hook"
4774 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
4776 tryname = SvPVX_const(namesv);
4779 ENTER_with_name("call_INC_hook");
4781 PUSHMARK(PL_stack_sp);
4782 /* add the args array for method calls */
4783 bool add_dirsv = (method && (loader != dirsv));
4784 rpp_extend(2 + add_dirsv);
4786 /* always use the object for method calls */
4787 method ? loader : dirsv,
4793 count = call_method(method, G_LIST|G_EVAL);
4795 count = call_sv(loader, G_LIST|G_EVAL);
4801 SV **base = PL_stack_sp - count + 1;
4804 /* push the stringified returned items into the
4805 * incdir_av array for processing immediately
4806 * afterwards. we deliberately stringify or copy
4807 * "special" arguments, so that overload logic for
4808 * instance applies, but so that the end result is
4809 * stable. We speficially do *not* support returning
4810 * coderefs from an INCDIR call. */
4818 char *pv = SvPV(arg,l);
4819 arg = newSVpvn(pv,l);
4821 else if (SvGMAGICAL(arg)) {
4822 arg = newSVsv_nomg(arg);
4827 av_push(incdir_av, arg);
4829 /* We copy $INC into incdir_continue_inc_idx
4830 * so that when we finish processing the items
4831 * we just inserted into incdir_av we can continue
4832 * as though we had just finished executing the INCDIR
4833 * hook. We honour $INC here just like we would for
4834 * an INC hook, the hook might have rewritten @INC
4835 * at the same time as returning something to us.
4837 inc_idx_sv = GvSVn(PL_incgv);
4838 incdir_continue_inc_idx = SvOK(inc_idx_sv)
4839 ? SvIV(inc_idx_sv) : -1;
4846 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
4847 && !isGV_with_GP(SvRV(arg))) {
4848 filter_cache = SvRV(arg);
4855 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
4859 if (isGV_with_GP(arg)) {
4860 IO * const io = GvIO((const GV *)arg);
4865 tryrsfp = IoIFP(io);
4866 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
4867 PerlIO_close(IoOFP(io));
4878 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
4880 SvREFCNT_inc_simple_void_NN(filter_sub);
4883 filter_state = base[i];
4884 SvREFCNT_inc_simple_void(filter_state);
4888 if (!tryrsfp && (filter_cache || filter_sub)) {
4889 tryrsfp = PerlIO_open(BIT_BUCKET,
4893 rpp_popfree_to_NN(base - 1);
4896 if (SvTRUE(errsv) && !SvROK(errsv)) {
4898 char *pv= SvPV(errsv,l);
4899 /* Heuristic to tell if this error message
4900 * includes the standard line number info:
4901 * check if the line ends in digit dot newline.
4902 * If it does then we add some extra info so
4903 * its obvious this is coming from a hook.
4904 * If it is a user generated error we try to
4905 * leave it alone. l>12 is to ensure the
4906 * other checks are in string, but also
4907 * accounts for "at ... line 1.\n" to a
4908 * certain extent. Really we should check
4909 * further, but this is good enough for back
4912 if (l>=12 && pv[l-1] == '\n' && pv[l-2] == '.' && isDIGIT(pv[l-3]))
4913 sv_catpvf(errsv, "%s %s hook died--halting @INC search",
4914 method ? method : "INC",
4915 method ? "method" : "sub");
4920 /* FREETMPS may free our filter_cache */
4921 SvREFCNT_inc_simple_void(filter_cache);
4924 Let the hook override which @INC entry we visit
4925 next by setting $INC to a different value than it
4926 was before we called the hook. If they have
4927 completely rewritten the array they might want us
4928 to start traversing from the beginning, which is
4929 represented by -1. We use undef as an equivalent of
4930 -1. This can't be used as a way to call a hook
4931 twice, as we still dedupe.
4932 We have to do this before we LEAVE, as we localized
4933 $INC before we called the hook.
4935 inc_idx_sv = GvSVn(PL_incgv);
4936 inc_idx = SvOK(inc_idx_sv) ? SvIV(inc_idx_sv) : -1;
4939 LEAVE_with_name("call_INC_hook");
4942 It is possible that @INC has been replaced and that inc_ar
4943 now points at a freed AV. So we have to refresh it from
4946 inc_ar = GvAVn(PL_incgv);
4948 /* Now re-mortalize it. */
4949 sv_2mortal(filter_cache);
4951 /* Adjust file name if the hook has set an %INC entry.
4952 This needs to happen after the FREETMPS above. */
4953 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
4954 /* we have to make sure that the value is not undef
4955 * or the empty string, if it is then we should not
4956 * set tryname to it as this will break error messages.
4958 * This might happen if an @INC hook evals the module
4959 * which was required in the first place and which
4960 * triggered the @INC hook, and that eval dies.
4961 * See https://github.com/Perl/perl5/issues/20535
4963 if (svp && SvOK(*svp)) {
4965 const char *tmp_pv = SvPV_const(*svp,len);
4966 /* we also guard against the deliberate empty string.
4967 * We do not guard against '0', if people want to set their
4968 * file name to 0 that is up to them. */
4978 filter_has_file = 0;
4979 filter_cache = NULL;
4981 SvREFCNT_dec_NN(filter_state);
4982 filter_state = NULL;
4985 SvREFCNT_dec_NN(filter_sub);
4991 if (path_searchable) {
4992 /* match against a plain @INC element (non-searchable
4993 * paths are only matched against refs in @INC) */
4997 dir = SvPV_nomg_const(dirsv, dirlen);
5003 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
5007 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
5010 sv_setpv(namesv, unixdir);
5011 sv_catpv(namesv, unixname);
5013 /* The equivalent of
5014 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
5015 but without the need to parse the format string, or
5016 call strlen on either pointer, and with the correct
5017 allocation up front. */
5019 char *tmp = SvGROW(namesv, dirlen + len + 2);
5021 memcpy(tmp, dir, dirlen);
5024 /* Avoid '<dir>//<file>' */
5025 if (!dirlen || *(tmp-1) != '/') {
5028 /* So SvCUR_set reports the correct length below */
5032 /* name came from an SV, so it will have a '\0' at the
5033 end that we can copy as part of this memcpy(). */
5034 memcpy(tmp, name, len + 1);
5036 SvCUR_set(namesv, dirlen + len + 1);
5040 TAINT_PROPER(op_name);
5041 tryname = SvPVX_const(namesv);
5042 tryrsfp = doopen_pm(namesv);
5044 if (tryname[0] == '.' && tryname[1] == '/') {
5046 while (*++tryname == '/') {}
5050 else if (errno == EMFILE || errno == EACCES) {
5051 /* no point in trying other paths if out of handles;
5052 * on the other hand, if we couldn't open one of the
5053 * files, then going on with the search could lead to
5054 * unexpected results; see perl #113422
5063 /* at this point we've ether opened a file (tryrsfp) or set errno */
5065 saved_errno = errno; /* sv_2mortal can realloc things */
5068 /* we failed; croak if require() or return undef if do() */
5069 if (op_is_require) {
5070 if(saved_errno == EMFILE || saved_errno == EACCES) {
5071 /* diag_listed_as: Can't locate %s */
5072 DIE(aTHX_ "Can't locate %s: %s: %s",
5073 name, tryname, Strerror(saved_errno));
5075 if (path_searchable) { /* did we lookup @INC? */
5077 SV *const msg = newSVpvs_flags("", SVs_TEMP);
5078 SV *const inc = newSVpvs_flags("", SVs_TEMP);
5079 for (i = 0; i <= AvFILL(inc_checked); i++) {
5080 SV **svp= av_fetch(inc_checked, i, TRUE);
5081 if (!svp || !*svp) continue;
5082 sv_catpvs(inc, " ");
5083 sv_catsv(inc, *svp);
5085 if (memENDPs(name, len, ".pm")) {
5086 const char *e = name + len - (sizeof(".pm") - 1);
5088 bool utf8 = cBOOL(SvUTF8(sv));
5090 /* if the filename, when converted from "Foo/Bar.pm"
5091 * form back to Foo::Bar form, makes a valid
5092 * package name (i.e. parseable by C<require
5093 * Foo::Bar>), then emit a hint.
5095 * this loop is modelled after the one in
5099 if (utf8 && isIDFIRST_utf8_safe(c, e)) {
5101 while (c < e && isIDCONT_utf8_safe(
5102 (const U8*) c, (const U8*) e))
5105 else if (isWORDCHAR_A(*c)) {
5106 while (c < e && isWORDCHAR_A(*c))
5115 if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
5116 sv_catpvs(msg, " (you may need to install the ");
5117 for (c = name; c < e; c++) {
5119 sv_catpvs(msg, "::");
5122 sv_catpvn(msg, c, 1);
5125 sv_catpvs(msg, " module)");
5128 else if (memENDs(name, len, ".h")) {
5129 sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
5131 else if (memENDs(name, len, ".ph")) {
5132 sv_catpvs(msg, " (did you run h2ph?)");
5135 /* diag_listed_as: Can't locate %s */
5137 "Can't locate %s in @INC%" SVf " (@INC entries checked:%" SVf ")",
5141 DIE(aTHX_ "Can't locate %s", name);
5144 #ifdef DEFAULT_INC_EXCLUDES_DOT
5148 /* the complication is to match the logic from doopen_pm() so
5149 * we don't treat do "sda1" as a previously successful "do".
5151 bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED__DOT_IN_INC)
5152 && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode)
5153 && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL;
5159 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED__DOT_IN_INC),
5160 "do \"%s\" failed, '.' is no longer in @INC; "
5161 "did you mean do \"./%s\"?",
5166 rpp_replace_1_IMM_NN(&PL_sv_undef);
5171 SETERRNO(0, SS_NORMAL);
5173 rpp_popfree_1_NN(); /* finished with sv now */
5175 /* Update %INC. Assume success here to prevent recursive requirement. */
5176 /* name is never assigned to again, so len is still strlen(name) */
5177 /* Check whether a hook in @INC has already filled %INC */
5179 (void)hv_store(GvHVn(PL_incgv),
5180 unixname, unixlen, newSVpv(tryname,0),0);
5182 /* store the hook in the sv, note we have to *copy* hook_sv,
5183 * we don't want modifications to it to change @INC - see GH #20577
5185 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
5187 (void)hv_store(GvHVn(PL_incgv),
5188 unixname, unixlen, newSVsv(hook_sv), 0 );
5191 /* Now parse the file */
5193 old_savestack_ix = PL_savestack_ix;
5194 SAVECOPFILE_FREE(&PL_compiling);
5195 CopFILE_set(&PL_compiling, tryname);
5196 lex_start(NULL, tryrsfp, 0);
5198 if (filter_sub || filter_cache) {
5199 /* We can use the SvPV of the filter PVIO itself as our cache, rather
5200 than hanging another SV from it. In turn, filter_add() optionally
5201 takes the SV to use as the filter (or creates a new SV if passed
5202 NULL), so simply pass in whatever value filter_cache has. */
5203 SV * const fc = filter_cache ? newSV_type(SVt_NULL) : NULL;
5205 if (fc) sv_copypv(fc, filter_cache);
5206 datasv = filter_add(S_run_user_filter, fc);
5207 IoLINES(datasv) = filter_has_file;
5208 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
5209 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
5212 /* switch to eval mode */
5214 cx = cx_pushblock(CXt_EVAL, gimme, PL_stack_sp, old_savestack_ix);
5215 cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
5217 SAVECOPLINE(&PL_compiling);
5218 CopLINE_set(&PL_compiling, 0);
5220 if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
5223 op = PL_op->op_next;
5225 PERL_DTRACE_PROBE_FILE_LOADED(unixname);
5231 /* also used for: pp_dofile() */
5235 /* If a suitable JMPENV catch frame isn't present, call docatch(),
5237 * - add such a frame, and
5238 * - start a new RUNOPS loop, which will (as the first op to run),
5239 * recursively call this pp function again.
5240 * The main body of this function is then executed by the inner call.
5243 return docatch(Perl_pp_require);
5246 SV *sv = *PL_stack_sp;
5248 /* these tail-called subs are responsible for popping sv off the
5250 return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
5251 ? S_require_version(aTHX_ sv)
5252 : S_require_file(aTHX_ sv);
5257 /* This is a op added to hold the hints hash for
5258 pp_entereval. The hash can be modified by the code
5259 being eval'ed, so we return a copy instead. */
5264 rpp_push_1_norc(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
5275 char tbuf[TYPE_DIGITS(long) + 12];
5283 I32 old_savestack_ix;
5285 /* If a suitable JMPENV catch frame isn't present, call docatch(),
5287 * - add such a frame, and
5288 * - start a new RUNOPS loop, which will (as the first op to run),
5289 * recursively call this pp function again.
5290 * The main body of this function is then executed by the inner call.
5293 return docatch(Perl_pp_entereval);
5298 was = PL_breakable_sub_gen;
5299 saved_delete = FALSE;
5303 bytes = PL_op->op_private & OPpEVAL_BYTES;
5305 if (PL_op->op_private & OPpEVAL_HAS_HH) {
5306 saved_hh = MUTABLE_HV(rpp_pop_1_norc());
5308 else if (PL_hints & HINT_LOCALIZE_HH || (
5309 PL_op->op_private & OPpEVAL_COPHH
5310 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
5312 saved_hh = cop_hints_2hv(PL_curcop, 0);
5313 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
5317 /* make sure we've got a plain PV (no overload etc) before testing
5318 * for taint. Making a copy here is probably overkill, but better
5319 * safe than sorry */
5321 const char * const p = SvPV_const(sv, len);
5323 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
5324 lex_flags |= LEX_START_COPIED;
5326 if (bytes && SvUTF8(sv))
5327 SvPVbyte_force(sv, len);
5329 else if (bytes && SvUTF8(sv)) {
5330 /* Don't modify someone else's scalar */
5333 (void)sv_2mortal(sv);
5334 SvPVbyte_force(sv,len);
5335 lex_flags |= LEX_START_COPIED;
5338 TAINT_IF(SvTAINTED(sv));
5339 TAINT_PROPER("eval");
5341 old_savestack_ix = PL_savestack_ix;
5343 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
5344 ? LEX_IGNORE_UTF8_HINTS
5345 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
5349 rpp_popfree_1_NN(); /* can free sv now */
5351 /* switch to eval mode */
5353 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
5354 SV * const temp_sv = sv_newmortal();
5355 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" LINE_Tf "]",
5356 (unsigned long)++PL_evalseq,
5357 CopFILE(PL_curcop), CopLINE(PL_curcop));
5358 tmpbuf = SvPVX(temp_sv);
5359 len = SvCUR(temp_sv);
5362 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
5363 SAVECOPFILE_FREE(&PL_compiling);
5364 CopFILE_set(&PL_compiling, tmpbuf+2);
5365 SAVECOPLINE(&PL_compiling);
5366 CopLINE_set(&PL_compiling, 1);
5367 /* special case: an eval '' executed within the DB package gets lexically
5368 * placed in the first non-DB CV rather than the current CV - this
5369 * allows the debugger to execute code, find lexicals etc, in the
5370 * scope of the code being debugged. Passing &seq gets find_runcv
5371 * to do the dirty work for us */
5372 runcv = find_runcv(&seq);
5375 cx = cx_pushblock((CXt_EVAL|CXp_REAL),
5376 gimme, PL_stack_sp, old_savestack_ix);
5377 cx_pusheval(cx, PL_op->op_next, NULL);
5379 /* prepare to compile string */
5381 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
5382 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
5384 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
5385 deleting the eval's FILEGV from the stash before gv_check() runs
5386 (i.e. before run-time proper). To work around the coredump that
5387 ensues, we always turn GvMULTI_on for any globals that were
5388 introduced within evals. See force_ident(). GSAR 96-10-12 */
5389 char *const safestr = savepvn(tmpbuf, len);
5390 SAVEDELETE(PL_defstash, safestr, len);
5391 saved_delete = TRUE;
5394 if (doeval_compile(gimme, runcv, seq, saved_hh)) {
5395 if (was != PL_breakable_sub_gen /* Some subs defined here. */
5396 ? PERLDB_LINE_OR_SAVESRC
5397 : PERLDB_SAVESRC_NOSUBS) {
5398 /* Retain the filegv we created. */
5399 } else if (!saved_delete) {
5400 char *const safestr = savepvn(tmpbuf, len);
5401 SAVEDELETE(PL_defstash, safestr, len);
5403 return PL_eval_start;
5405 /* We have already left the scope set up earlier thanks to the LEAVE
5406 in doeval_compile(). */
5407 if (was != PL_breakable_sub_gen /* Some subs defined here. */
5408 ? PERLDB_LINE_OR_SAVESRC
5409 : PERLDB_SAVESRC_INVALID) {
5410 /* Retain the filegv we created. */
5411 } else if (!saved_delete) {
5412 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
5414 if (PL_op->op_private & OPpEVAL_EVALSV)
5415 /* signal compiletime failure to our eval_sv() caller */
5416 *++PL_stack_sp = NULL;
5417 return PL_op->op_next;
5422 /* also tail-called by pp_return */
5431 bool override_return = FALSE; /* is feature 'module_true' in effect? */
5438 assert(CxTYPE(cx) == CXt_EVAL);
5440 oldsp = PL_stack_base + cx->blk_oldsp;
5441 gimme = cx->blk_gimme;
5443 bool is_require= CxOLD_OP_TYPE(cx) == OP_REQUIRE;
5445 /* We are in an require. Check if use feature 'module_true' is enabled,
5446 * and if so later on correct any returns from the require. */
5448 /* we might be called for an OP_LEAVEEVAL or OP_RETURN opcode
5449 * and the parse tree will look different for either case.
5450 * so find the right op to check later */
5451 if (OP_TYPE_IS_OR_WAS(PL_op, OP_RETURN)) {
5452 if (PL_op->op_flags & OPf_SPECIAL)
5453 override_return = true;
5455 else if ((PL_op->op_flags & OPf_KIDS) && OP_TYPE_IS_OR_WAS(PL_op, OP_LEAVEEVAL)){
5456 COP *old_pl_curcop = PL_curcop;
5457 OP *check = cUNOPx(PL_op)->op_first;
5459 /* ok, we found something to check, we need to scan through
5460 * it and find the last OP_NEXTSTATE it contains and then read the
5461 * feature state out of the COP data it contains.
5464 if (!OP_TYPE_IS(check,OP_STUB)) {
5465 const OP *kid = cLISTOPx(check)->op_first;
5466 const OP *last_state = NULL;
5468 for (; kid; kid = OpSIBLING(kid)) {
5470 OP_TYPE_IS_OR_WAS(kid, OP_NEXTSTATE)
5471 || OP_TYPE_IS_OR_WAS(kid, OP_DBSTATE)
5477 PL_curcop = cCOPx(last_state);
5478 if (FEATURE_MODULE_TRUE_IS_ENABLED) {
5479 override_return = TRUE;
5482 NOT_REACHED; /* NOTREACHED */
5486 NOT_REACHED; /* NOTREACHED */
5488 PL_curcop = old_pl_curcop;
5492 /* we might override this later if 'module_true' is enabled */
5494 && !(gimme == G_SCALAR
5495 ? SvTRUE_NN(*PL_stack_sp)
5496 : PL_stack_sp > oldsp);
5498 if (gimme == G_VOID) {
5499 rpp_popfree_to(oldsp);
5500 /* free now to avoid late-called destructors clobbering $@ */
5504 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
5506 /* the cx_popeval does a leavescope, which frees the optree associated
5507 * with eval, which if it frees the nextstate associated with
5508 * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
5509 * regex when running under 'use re Debug' because it needs PL_curcop
5510 * to get the current hints. So restore it early.
5512 PL_curcop = cx->blk_oldcop;
5514 /* grab this value before cx_popeval restores the old PL_in_eval */
5515 keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
5516 retop = cx->blk_eval.retop;
5517 evalcv = cx->blk_eval.cv;
5519 assert(CvDEPTH(evalcv) == 1);
5521 CvDEPTH(evalcv) = 0;
5523 if (override_return) {
5524 /* make sure that we use a standard return when feature 'module_load'
5525 * is enabled. Returns from require are problematic (consider what happens
5526 * when it is called twice) */
5527 if (gimme == G_SCALAR)
5528 rpp_replace_1_IMM_NN(&PL_sv_yes);
5529 assert(gimme == G_VOID || gimme == G_SCALAR);
5533 /* pop the CXt_EVAL, and if a require failed, croak */
5534 S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
5542 /* Ops that implement try/catch syntax
5543 * Note the asymmetry here:
5544 * pp_entertrycatch does two pushblocks
5545 * pp_leavetrycatch pops only the outer one; the inner one is popped by
5546 * pp_poptry or by stack-unwind of die within the try block
5549 PP(pp_entertrycatch)
5552 const U8 gimme = GIMME_V;
5554 /* If a suitable JMPENV catch frame isn't present, call docatch(),
5556 * - add such a frame, and
5557 * - start a new RUNOPS loop, which will (as the first op to run),
5558 * recursively call this pp function again.
5559 * The main body of this function is then executed by the inner call.
5562 return docatch(Perl_pp_entertrycatch);
5566 Perl_pp_enter(aTHX); /* performs cx_pushblock(CXt_BLOCK, ...) */
5568 save_scalar(PL_errgv);
5571 cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK|CXp_TRY), gimme,
5572 PL_stack_sp, PL_savestack_ix);
5573 cx_pushtry(cx, cLOGOP->op_other);
5575 PL_in_eval = EVAL_INEVAL;
5580 PP(pp_leavetrycatch)
5582 /* leavetrycatch is leave */
5583 return Perl_pp_leave(aTHX);
5588 /* poptry is leavetry */
5589 return Perl_pp_leavetry(aTHX);
5596 save_clearsv(&(PAD_SVl(PL_op->op_targ)));
5597 sv_setsv(TARG, ERRSV);
5600 return cLOGOP->op_other;
5603 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
5604 close to the related Perl_create_eval_scope. */
5606 Perl_delete_eval_scope(pTHX)
5617 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
5618 also needed by Perl_fold_constants. */
5620 Perl_create_eval_scope(pTHX_ OP *retop, SV **sp, U32 flags)
5623 const U8 gimme = GIMME_V;
5625 PERL_ARGS_ASSERT_CREATE_EVAL_SCOPE;
5627 cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK), gimme,
5628 sp, PL_savestack_ix);
5629 cx_pusheval(cx, retop, NULL);
5631 PL_in_eval = EVAL_INEVAL;
5632 if (flags & G_KEEPERR)
5633 PL_in_eval |= EVAL_KEEPERR;
5636 if (flags & G_FAKINGEVAL) {
5637 PL_eval_root = PL_op; /* Only needed so that goto works right. */
5643 OP *retop = cLOGOP->op_other->op_next;
5645 /* If a suitable JMPENV catch frame isn't present, call docatch(),
5647 * - add such a frame, and
5648 * - start a new RUNOPS loop, which will (as the first op to run),
5649 * recursively call this pp function again.
5650 * The main body of this function is then executed by the inner call.
5653 return docatch(Perl_pp_entertry);
5657 create_eval_scope(retop, PL_stack_sp, 0);
5659 return PL_op->op_next;
5663 /* also tail-called by pp_return */
5675 assert(CxTYPE(cx) == CXt_EVAL);
5676 oldsp = PL_stack_base + cx->blk_oldsp;
5677 gimme = cx->blk_gimme;
5679 if (gimme == G_VOID) {
5680 rpp_popfree_to_NN(oldsp);
5681 /* free now to avoid late-called destructors clobbering $@ */
5685 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5689 retop = CxTRY(cx) ? PL_op->op_next : cx->blk_eval.retop;
5699 const U8 gimme = GIMME_V;
5702 assert(!PL_op->op_targ); /* used to be set for lexical $_ */
5703 GvSV(PL_defgv) = rpp_pop_1_norc();
5705 cx = cx_pushblock(CXt_GIVEN, gimme, PL_stack_sp, PL_savestack_ix);
5706 cx_pushgiven(cx, origsv);
5716 PERL_UNUSED_CONTEXT;
5719 assert(CxTYPE(cx) == CXt_GIVEN);
5720 oldsp = PL_stack_base + cx->blk_oldsp;
5721 gimme = cx->blk_gimme;
5723 if (gimme == G_VOID)
5724 rpp_popfree_to_NN(oldsp);
5726 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5736 /* Helper routines used by pp_smartmatch */
5738 S_make_matcher(pTHX_ REGEXP *re)
5740 PMOP *matcher = cPMOPx(newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED));
5742 PERL_ARGS_ASSERT_MAKE_MATCHER;
5744 PM_SETRE(matcher, ReREFCNT_inc(re));
5746 SAVEFREEOP((OP *) matcher);
5747 ENTER_with_name("matcher"); SAVETMPS;
5753 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
5757 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
5759 PL_op = (OP *) matcher;
5761 (void) Perl_pp_match(aTHX);
5762 result = SvTRUEx(*PL_stack_sp);
5768 S_destroy_matcher(pTHX_ PMOP *matcher)
5770 PERL_ARGS_ASSERT_DESTROY_MATCHER;
5771 PERL_UNUSED_ARG(matcher);
5774 LEAVE_with_name("matcher");
5778 /* Do a smart match */
5781 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
5782 return do_smartmatch(NULL, NULL, 0);
5786 /* This version of do_smartmatch() implements the
5787 * table of smart matches that is found in perlsyn.
5790 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
5792 bool object_on_left = FALSE;
5793 SV *e = PL_stack_sp[0]; /* e is for 'expression' */
5794 SV *d = PL_stack_sp[-1]; /* d is for 'default', as in PL_defgv */
5796 /* Take care only to invoke mg_get() once for each argument.
5797 * Currently we do this by copying the SV if it's magical. */
5799 if (!copied && SvGMAGICAL(d))
5800 d = sv_mortalcopy(d);
5807 e = sv_mortalcopy(e);
5809 /* First of all, handle overload magic of the rightmost argument */
5812 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
5813 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
5815 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
5817 rpp_replace_2_1_NN(tmpsv);
5820 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
5825 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
5832 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
5833 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
5834 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
5836 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
5837 object_on_left = TRUE;
5840 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
5841 if (object_on_left) {
5842 goto sm_any_sub; /* Treat objects like scalars */
5844 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5845 /* Test sub truth for each key */
5847 bool andedresults = TRUE;
5848 HV *hv = (HV*) SvRV(d);
5849 I32 numkeys = hv_iterinit(hv);
5850 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
5853 while ( (he = hv_iternext(hv)) ) {
5854 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
5855 ENTER_with_name("smartmatch_hash_key_test");
5857 PUSHMARK(PL_stack_sp);
5858 rpp_xpush_1(hv_iterkeysv(he));
5859 (void)call_sv(e, G_SCALAR);
5860 andedresults = SvTRUEx(PL_stack_sp[0]) && andedresults;
5863 LEAVE_with_name("smartmatch_hash_key_test");
5870 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5871 /* Test sub truth for each element */
5873 bool andedresults = TRUE;
5874 AV *av = (AV*) SvRV(d);
5875 const Size_t len = av_count(av);
5876 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
5879 for (i = 0; i < len; ++i) {
5880 SV * const * const svp = av_fetch(av, i, FALSE);
5881 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
5882 ENTER_with_name("smartmatch_array_elem_test");
5884 PUSHMARK(PL_stack_sp);
5887 (void)call_sv(e, G_SCALAR);
5888 andedresults = SvTRUEx(PL_stack_sp[0]) && andedresults;
5891 LEAVE_with_name("smartmatch_array_elem_test");
5900 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
5901 ENTER_with_name("smartmatch_coderef");
5902 PUSHMARK(PL_stack_sp);
5904 (void)call_sv(e, G_SCALAR);
5905 LEAVE_with_name("smartmatch_coderef");
5906 SV *retsv = *PL_stack_sp--;
5907 rpp_replace_2_1(retsv);
5908 #ifdef PERL_RC_STACK
5909 SvREFCNT_dec(retsv);
5915 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
5916 if (object_on_left) {
5917 goto sm_any_hash; /* Treat objects like scalars */
5919 else if (!SvOK(d)) {
5920 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
5923 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5924 /* Check that the key-sets are identical */
5926 HV *other_hv = MUTABLE_HV(SvRV(d));
5929 U32 this_key_count = 0,
5930 other_key_count = 0;
5931 HV *hv = MUTABLE_HV(SvRV(e));
5933 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
5934 /* Tied hashes don't know how many keys they have. */
5935 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
5936 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
5940 HV * const temp = other_hv;
5946 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
5950 /* The hashes have the same number of keys, so it suffices
5951 to check that one is a subset of the other. */
5952 (void) hv_iterinit(hv);
5953 while ( (he = hv_iternext(hv)) ) {
5954 SV *key = hv_iterkeysv(he);
5956 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
5959 if(!hv_exists_ent(other_hv, key, 0)) {
5960 (void) hv_iterinit(hv); /* reset iterator */
5966 (void) hv_iterinit(other_hv);
5967 while ( hv_iternext(other_hv) )
5971 other_key_count = HvUSEDKEYS(other_hv);
5973 if (this_key_count != other_key_count)
5978 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5979 AV * const other_av = MUTABLE_AV(SvRV(d));
5980 const Size_t other_len = av_count(other_av);
5982 HV *hv = MUTABLE_HV(SvRV(e));
5984 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
5985 for (i = 0; i < other_len; ++i) {
5986 SV ** const svp = av_fetch(other_av, i, FALSE);
5987 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
5988 if (svp) { /* ??? When can this not happen? */
5989 if (hv_exists_ent(hv, *svp, 0))
5995 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
5996 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
5999 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
6001 HV *hv = MUTABLE_HV(SvRV(e));
6003 (void) hv_iterinit(hv);
6004 while ( (he = hv_iternext(hv)) ) {
6005 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
6006 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
6007 (void) hv_iterinit(hv);
6008 destroy_matcher(matcher);
6012 destroy_matcher(matcher);
6018 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
6019 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
6026 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
6027 if (object_on_left) {
6028 goto sm_any_array; /* Treat objects like scalars */
6030 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
6031 AV * const other_av = MUTABLE_AV(SvRV(e));
6032 const Size_t other_len = av_count(other_av);
6035 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
6036 for (i = 0; i < other_len; ++i) {
6037 SV ** const svp = av_fetch(other_av, i, FALSE);
6039 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
6040 if (svp) { /* ??? When can this not happen? */
6041 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
6047 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
6048 AV *other_av = MUTABLE_AV(SvRV(d));
6049 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
6050 if (av_count(MUTABLE_AV(SvRV(e))) != av_count(other_av))
6054 const Size_t other_len = av_count(other_av);
6056 if (NULL == seen_this) {
6057 seen_this = (HV*)newSV_type_mortal(SVt_PVHV);
6059 if (NULL == seen_other) {
6060 seen_other = (HV*)newSV_type_mortal(SVt_PVHV);
6062 for(i = 0; i < other_len; ++i) {
6063 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
6064 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
6066 if (!this_elem || !other_elem) {
6067 if ((this_elem && SvOK(*this_elem))
6068 || (other_elem && SvOK(*other_elem)))
6071 else if (hv_exists_ent(seen_this,
6072 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
6073 hv_exists_ent(seen_other,
6074 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
6076 if (*this_elem != *other_elem)
6080 (void)hv_store_ent(seen_this,
6081 sv_2mortal(newSViv(PTR2IV(*this_elem))),
6083 (void)hv_store_ent(seen_other,
6084 sv_2mortal(newSViv(PTR2IV(*other_elem))),
6086 rpp_xpush_2(*other_elem, *this_elem);
6087 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
6088 (void) do_smartmatch(seen_this, seen_other, 0);
6089 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
6091 bool ok = SvTRUEx(PL_stack_sp[0]);
6100 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
6101 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
6104 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
6105 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
6108 for(i = 0; i < this_len; ++i) {
6109 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
6110 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
6111 if (svp && matcher_matches_sv(matcher, *svp)) {
6112 destroy_matcher(matcher);
6116 destroy_matcher(matcher);
6120 else if (!SvOK(d)) {
6121 /* undef ~~ array */
6122 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
6125 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
6126 for (i = 0; i < this_len; ++i) {
6127 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
6128 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
6129 if (!svp || !SvOK(*svp))
6138 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
6140 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
6141 for (i = 0; i < this_len; ++i) {
6142 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
6146 rpp_xpush_2(d, *svp);
6147 /* infinite recursion isn't supposed to happen here */
6148 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
6149 (void) do_smartmatch(NULL, NULL, 1);
6150 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
6151 bool ok = SvTRUEx(PL_stack_sp[0]);
6161 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
6162 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
6163 SV *t = d; d = e; e = t;
6164 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
6167 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
6168 SV *t = d; d = e; e = t;
6169 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
6170 goto sm_regex_array;
6173 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
6176 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
6177 result = matcher_matches_sv(matcher, d);
6178 destroy_matcher(matcher);
6186 /* See if there is overload magic on left */
6187 else if (object_on_left && SvAMAGIC(d)) {
6189 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
6190 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
6191 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
6193 rpp_replace_2_1_NN(tmpsv);
6197 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
6200 else if (!SvOK(d)) {
6201 /* undef ~~ scalar ; we already know that the scalar is SvOK */
6202 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
6207 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
6208 DEBUG_M(if (SvNIOK(e))
6209 Perl_deb(aTHX_ " applying rule Any-Num\n");
6211 Perl_deb(aTHX_ " applying rule Num-numish\n");
6213 /* numeric comparison */
6215 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
6216 (void) Perl_pp_i_eq(aTHX);
6218 (void) Perl_pp_eq(aTHX);
6219 bool ok = SvTRUEx(PL_stack_sp[0]);
6227 /* As a last resort, use string comparison */
6228 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
6232 bool ok = SvTRUEx(PL_stack_sp[0]);
6241 rpp_replace_2_IMM_NN(&PL_sv_no);
6245 rpp_replace_2_IMM_NN(&PL_sv_yes);
6253 const U8 gimme = GIMME_V;
6255 /* This is essentially an optimization: if the match
6256 fails, we don't want to push a context and then
6257 pop it again right away, so we skip straight
6258 to the op that follows the leavewhen.
6260 if (!(PL_op->op_flags & OPf_SPECIAL)) { /* SPECIAL implies no condition */
6261 bool tr = SvTRUEx(*PL_stack_sp);
6264 if (gimme == G_SCALAR)
6265 rpp_push_IMM(&PL_sv_undef);
6266 return cLOGOP->op_other->op_next;
6270 cx = cx_pushblock(CXt_WHEN, gimme, PL_stack_sp, PL_savestack_ix);
6284 assert(CxTYPE(cx) == CXt_WHEN);
6285 gimme = cx->blk_gimme;
6287 cxix = dopoptogivenfor(cxstack_ix);
6289 /* diag_listed_as: Can't "when" outside a topicalizer */
6290 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
6291 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
6293 oldsp = PL_stack_base + cx->blk_oldsp;
6294 if (gimme == G_VOID)
6295 rpp_popfree_to_NN(oldsp);
6297 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
6299 /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
6300 assert(cxix < cxstack_ix);
6303 cx = &cxstack[cxix];
6305 if (CxFOREACH(cx)) {
6306 /* emulate pp_next. Note that any stack(s) cleanup will be
6307 * done by the pp_unstack which op_nextop should point to */
6310 PL_curcop = cx->blk_oldcop;
6311 return cx->blk_loop.my_op->op_nextop;
6315 assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
6316 return cx->blk_givwhen.leave_op;
6326 cxix = dopoptowhen(cxstack_ix);
6328 DIE(aTHX_ "Can't \"continue\" outside a when block");
6330 if (cxix < cxstack_ix)
6334 assert(CxTYPE(cx) == CXt_WHEN);
6335 rpp_popfree_to_NN(PL_stack_base + cx->blk_oldsp);
6339 nextop = cx->blk_givwhen.leave_op->op_next;
6350 cxix = dopoptogivenfor(cxstack_ix);
6352 DIE(aTHX_ "Can't \"break\" outside a given block");
6354 cx = &cxstack[cxix];
6356 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
6358 if (cxix < cxstack_ix)
6361 /* Restore the sp at the time we entered the given block */
6363 rpp_popfree_to_NN(PL_stack_base + cx->blk_oldsp);
6365 return cx->blk_givwhen.leave_op;
6369 _invoke_defer_block(pTHX_ U8 type, void *_arg)
6371 OP *start = (OP *)_arg;
6373 I32 was_cxstack_ix = cxstack_ix;
6376 cx_pushblock(type, G_VOID, PL_stack_sp, PL_savestack_ix);
6392 assert(CxTYPE(cx) == CXt_DEFER);
6394 /* since we're called during a scope cleanup (including after
6395 * a croak), theere's no guarantee thr stack is currently
6397 #ifdef PERL_RC_STACK
6398 if (rpp_stack_is_rc())
6399 rpp_popfree_to_NN(PL_stack_base + cx->blk_oldsp);
6402 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
6410 assert(cxstack_ix == was_cxstack_ix);
6414 invoke_defer_block(pTHX_ void *_arg)
6416 _invoke_defer_block(aTHX_ CXt_DEFER, _arg);
6420 invoke_finally_block(pTHX_ void *_arg)
6422 _invoke_defer_block(aTHX_ CXt_DEFER|CXp_FINALLY, _arg);
6427 if(PL_op->op_private & OPpDEFER_FINALLY)
6428 SAVEDESTRUCTOR_X(invoke_finally_block, cLOGOP->op_other);
6430 SAVEDESTRUCTOR_X(invoke_defer_block, cLOGOP->op_other);
6436 S_doparseform(pTHX_ SV *sv)
6439 char *s = SvPV(sv, len);
6441 char *base = NULL; /* start of current field */
6442 I32 skipspaces = 0; /* number of contiguous spaces seen */
6443 bool noblank = FALSE; /* ~ or ~~ seen on this line */
6444 bool repeat = FALSE; /* ~~ seen on this line */
6445 bool postspace = FALSE; /* a text field may need right padding */
6448 U32 *linepc = NULL; /* position of last FF_LINEMARK */
6450 bool ischop; /* it's a ^ rather than a @ */
6451 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
6452 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
6456 PERL_ARGS_ASSERT_DOPARSEFORM;
6459 Perl_croak(aTHX_ "Null picture in formline");
6461 if (SvTYPE(sv) >= SVt_PVMG) {
6462 /* This might, of course, still return NULL. */
6463 mg = mg_find(sv, PERL_MAGIC_fm);
6465 sv_upgrade(sv, SVt_PVMG);
6469 /* still the same as previously-compiled string? */
6470 SV *old = mg->mg_obj;
6471 if ( ! (cBOOL(SvUTF8(old)) ^ cBOOL(SvUTF8(sv)))
6472 && len == SvCUR(old)
6473 && strnEQ(SvPVX(old), s, len)
6475 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
6479 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
6480 Safefree(mg->mg_ptr);
6486 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
6487 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
6490 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
6491 s = SvPV(sv_copy, len); /* work on the copy, not the original */
6495 /* estimate the buffer size needed */
6496 for (base = s; s <= send; s++) {
6497 if (*s == '\n' || *s == '@' || *s == '^')
6503 Newx(fops, maxops, U32);
6508 *fpc++ = FF_LINEMARK;
6509 noblank = repeat = FALSE;
6527 case ' ': case '\t':
6543 *fpc++ = FF_LITERAL;
6551 *fpc++ = (U32)skipspaces;
6555 *fpc++ = FF_NEWLINE;
6559 arg = fpc - linepc + 1;
6566 *fpc++ = FF_LINEMARK;
6567 noblank = repeat = FALSE;
6576 ischop = s[-1] == '^';
6582 arg = (s - base) - 1;
6584 *fpc++ = FF_LITERAL;
6590 if (*s == '*') { /* @* or ^* */
6592 *fpc++ = 2; /* skip the @* or ^* */
6594 *fpc++ = FF_LINESNGL;
6597 *fpc++ = FF_LINEGLOB;
6599 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
6600 arg = ischop ? FORM_NUM_BLANK : 0;
6605 const char * const f = ++s;
6608 arg |= FORM_NUM_POINT + (s - f);
6610 *fpc++ = s - base; /* fieldsize for FETCH */
6611 *fpc++ = FF_DECIMAL;
6613 unchopnum |= ! ischop;
6615 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
6616 arg = ischop ? FORM_NUM_BLANK : 0;
6618 s++; /* skip the '0' first */
6622 const char * const f = ++s;
6625 arg |= FORM_NUM_POINT + (s - f);
6627 *fpc++ = s - base; /* fieldsize for FETCH */
6628 *fpc++ = FF_0DECIMAL;
6630 unchopnum |= ! ischop;
6632 else { /* text field */
6634 bool ismore = FALSE;
6637 while (*++s == '>') ;
6638 prespace = FF_SPACE;
6640 else if (*s == '|') {
6641 while (*++s == '|') ;
6642 prespace = FF_HALFSPACE;
6647 while (*++s == '<') ;
6650 if (*s == '.' && s[1] == '.' && s[2] == '.') {
6654 *fpc++ = s - base; /* fieldsize for FETCH */
6656 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
6659 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
6673 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
6676 mg->mg_ptr = (char *) fops;
6677 mg->mg_len = arg * sizeof(U32);
6678 mg->mg_obj = sv_copy;
6679 mg->mg_flags |= MGf_REFCOUNTED;
6681 if (unchopnum && repeat)
6682 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
6689 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
6691 /* Can value be printed in fldsize chars, using %*.*f ? */
6695 int intsize = fldsize - (value < 0 ? 1 : 0);
6697 if (frcsize & FORM_NUM_POINT)
6699 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
6702 while (intsize--) pwr *= 10.0;
6703 while (frcsize--) eps /= 10.0;
6706 if (value + eps >= pwr)
6709 if (value - eps <= -pwr)
6716 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
6718 SV * const datasv = FILTER_DATA(idx);
6719 const int filter_has_file = IoLINES(datasv);
6720 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
6721 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
6726 char *prune_from = NULL;
6727 bool read_from_cache = FALSE;
6731 PERL_ARGS_ASSERT_RUN_USER_FILTER;
6733 assert(maxlen >= 0);
6736 /* I was having segfault trouble under Linux 2.2.5 after a
6737 parse error occurred. (Had to hack around it with a test
6738 for PL_parser->error_count == 0.) Solaris doesn't segfault --
6739 not sure where the trouble is yet. XXX */
6742 SV *const cache = datasv;
6745 const char *cache_p = SvPV(cache, cache_len);
6749 /* Running in block mode and we have some cached data already.
6751 if (cache_len >= umaxlen) {
6752 /* In fact, so much data we don't even need to call
6757 const char *const first_nl =
6758 (const char *)memchr(cache_p, '\n', cache_len);
6760 take = first_nl + 1 - cache_p;
6764 sv_catpvn(buf_sv, cache_p, take);
6765 sv_chop(cache, cache_p + take);
6766 /* Definitely not EOF */
6770 sv_catsv(buf_sv, cache);
6772 umaxlen -= cache_len;
6775 read_from_cache = TRUE;
6779 /* Filter API says that the filter appends to the contents of the buffer.
6780 Usually the buffer is "", so the details don't matter. But if it's not,
6781 then clearly what it contains is already filtered by this filter, so we
6782 don't want to pass it in a second time.
6783 I'm going to use a mortal in case the upstream filter croaks. */
6784 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
6785 ? newSV_type_mortal(SVt_PV) : buf_sv;
6786 SvUPGRADE(upstream, SVt_PV);
6788 if (filter_has_file) {
6789 status = FILTER_READ(idx+1, upstream, 0);
6792 if (filter_sub && status >= 0) {
6796 ENTER_with_name("call_filter_sub");
6801 DEFSV_set(upstream);
6805 PUSHs(filter_state);
6808 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
6818 SV * const errsv = ERRSV;
6819 if (SvTRUE_NN(errsv))
6820 err = newSVsv(errsv);
6826 LEAVE_with_name("call_filter_sub");
6829 if (SvGMAGICAL(upstream)) {
6831 if (upstream == buf_sv) mg_free(buf_sv);
6833 if (SvIsCOW(upstream)) sv_force_normal(upstream);
6834 if(!err && SvOK(upstream)) {
6835 got_p = SvPV_nomg(upstream, got_len);
6837 if (got_len > umaxlen) {
6838 prune_from = got_p + umaxlen;
6841 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
6842 if (first_nl && first_nl + 1 < got_p + got_len) {
6843 /* There's a second line here... */
6844 prune_from = first_nl + 1;
6848 if (!err && prune_from) {
6849 /* Oh. Too long. Stuff some in our cache. */
6850 STRLEN cached_len = got_p + got_len - prune_from;
6851 SV *const cache = datasv;
6854 /* Cache should be empty. */
6855 assert(!SvCUR(cache));
6858 sv_setpvn(cache, prune_from, cached_len);
6859 /* If you ask for block mode, you may well split UTF-8 characters.
6860 "If it breaks, you get to keep both parts"
6861 (Your code is broken if you don't put them back together again
6862 before something notices.) */
6863 if (SvUTF8(upstream)) {
6866 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
6868 /* Cannot just use sv_setpvn, as that could free the buffer
6869 before we have a chance to assign it. */
6870 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
6871 got_len - cached_len);
6873 /* Can't yet be EOF */
6878 /* If they are at EOF but buf_sv has something in it, then they may never
6879 have touched the SV upstream, so it may be undefined. If we naively
6880 concatenate it then we get a warning about use of uninitialised value.
6882 if (!err && upstream != buf_sv &&
6884 sv_catsv_nomg(buf_sv, upstream);
6886 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
6889 IoLINES(datasv) = 0;
6891 SvREFCNT_dec(filter_state);
6892 IoTOP_GV(datasv) = NULL;
6895 SvREFCNT_dec(filter_sub);
6896 IoBOTTOM_GV(datasv) = NULL;
6898 filter_del(S_run_user_filter);
6904 if (status == 0 && read_from_cache) {
6905 /* If we read some data from the cache (and by getting here it implies
6906 that we emptied the cache) then we aren't yet at EOF, and mustn't
6907 report that to our caller. */
6914 * ex: set ts=8 sts=4 sw=4 et: