3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
37 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
39 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
45 const PERL_CONTEXT *cx;
48 if (PL_op->op_private & OPpOFFBYONE) {
49 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
52 cxix = dopoptosub(cxstack_ix);
58 switch (cx->blk_gimme) {
77 PMOP *pm = (PMOP*)cLOGOP->op_other;
82 const regexp_engine *eng;
83 bool is_bare_re= FALSE;
85 if (PL_op->op_flags & OPf_STACKED) {
95 /* prevent recompiling under /o and ithreads. */
96 #if defined(USE_ITHREADS)
97 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
104 assert (re != (REGEXP*) &PL_sv_undef);
105 eng = re ? RX_ENGINE(re) : current_re_engine();
108 In the below logic: these are basically the same - check if this regcomp is part of a split.
110 (PL_op->op_pmflags & PMf_split )
111 (PL_op->op_next->op_type == OP_PUSHRE)
113 We could add a new mask for this and copy the PMf_split, if we did
114 some bit definition fiddling first.
116 For now we leave this
119 new_re = (eng->op_comp
121 : &Perl_re_op_compile
122 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
124 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
126 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
128 if (pm->op_pmflags & PMf_HAS_CV)
129 ReANY(new_re)->qr_anoncv
130 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
134 /* The match's LHS's get-magic might need to access this op's regexp
135 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
136 get-magic now before we replace the regexp. Hopefully this hack can
137 be replaced with the approach described at
138 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
140 if (pm->op_type == OP_MATCH) {
142 const bool was_tainted = TAINT_get;
143 if (pm->op_flags & OPf_STACKED)
145 else if (pm->op_targ)
146 lhs = PAD_SV(pm->op_targ);
149 /* Restore the previous value of PL_tainted (which may have been
150 modified by get-magic), to avoid incorrectly setting the
151 RXf_TAINTED flag with RX_TAINT_on further down. */
152 TAINT_set(was_tainted);
153 #ifdef NO_TAINT_SUPPORT
154 PERL_UNUSED_VAR(was_tainted);
157 tmp = reg_temp_copy(NULL, new_re);
158 ReREFCNT_dec(new_re);
164 PM_SETRE(pm, new_re);
168 assert(TAINTING_get || !TAINT_get);
170 SvTAINTED_on((SV*)new_re);
174 #if !defined(USE_ITHREADS)
175 /* can't change the optree at runtime either */
176 /* PMf_KEEP is handled differently under threads to avoid these problems */
177 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
179 if (pm->op_pmflags & PMf_KEEP) {
180 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
181 cLOGOP->op_first->op_next = PL_op->op_next;
193 PERL_CONTEXT *cx = CX_CUR();
194 PMOP * const pm = (PMOP*) cLOGOP->op_other;
195 SV * const dstr = cx->sb_dstr;
198 char *orig = cx->sb_orig;
199 REGEXP * const rx = cx->sb_rx;
201 REGEXP *old = PM_GETRE(pm);
208 PM_SETRE(pm,ReREFCNT_inc(rx));
211 rxres_restore(&cx->sb_rxres, rx);
213 if (cx->sb_iters++) {
214 const SSize_t saviters = cx->sb_iters;
215 if (cx->sb_iters > cx->sb_maxiters)
216 DIE(aTHX_ "Substitution loop");
218 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
220 /* See "how taint works" above pp_subst() */
222 cx->sb_rxtainted |= SUBST_TAINT_REPL;
223 sv_catsv_nomg(dstr, POPs);
224 if (CxONCE(cx) || s < orig ||
225 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
226 (s == m), cx->sb_targ, NULL,
227 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
229 SV *targ = cx->sb_targ;
231 assert(cx->sb_strend >= s);
232 if(cx->sb_strend > s) {
233 if (DO_UTF8(dstr) && !SvUTF8(targ))
234 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
236 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
238 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
239 cx->sb_rxtainted |= SUBST_TAINT_PAT;
241 if (pm->op_pmflags & PMf_NONDESTRUCT) {
243 /* From here on down we're using the copy, and leaving the
244 original untouched. */
248 SV_CHECK_THINKFIRST_COW_DROP(targ);
249 if (isGV(targ)) Perl_croak_no_modify();
251 SvPV_set(targ, SvPVX(dstr));
252 SvCUR_set(targ, SvCUR(dstr));
253 SvLEN_set(targ, SvLEN(dstr));
256 SvPV_set(dstr, NULL);
259 mPUSHi(saviters - 1);
261 (void)SvPOK_only_UTF8(targ);
264 /* update the taint state of various various variables in
265 * preparation for final exit.
266 * See "how taint works" above pp_subst() */
268 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
269 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
270 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
272 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
274 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
275 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
277 SvTAINTED_on(TOPs); /* taint return value */
278 /* needed for mg_set below */
280 cBOOL(cx->sb_rxtainted &
281 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
285 /* PL_tainted must be correctly set for this mg_set */
294 RETURNOP(pm->op_next);
295 NOT_REACHED; /* NOTREACHED */
297 cx->sb_iters = saviters;
299 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
302 assert(!RX_SUBOFFSET(rx));
303 cx->sb_orig = orig = RX_SUBBEG(rx);
305 cx->sb_strend = s + (cx->sb_strend - m);
307 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
309 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
310 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
312 sv_catpvn_nomg(dstr, s, m-s);
314 cx->sb_s = RX_OFFS(rx)[0].end + orig;
315 { /* Update the pos() information. */
317 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
320 /* the string being matched against may no longer be a string,
321 * e.g. $_=0; s/.../$_++/ge */
324 SvPV_force_nomg_nolen(sv);
326 if (!(mg = mg_find_mglob(sv))) {
327 mg = sv_magicext_mglob(sv);
329 MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
332 (void)ReREFCNT_inc(rx);
333 /* update the taint state of various various variables in preparation
334 * for calling the code block.
335 * See "how taint works" above pp_subst() */
337 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
338 cx->sb_rxtainted |= SUBST_TAINT_PAT;
340 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
341 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
342 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
344 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
346 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
347 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
348 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
349 ? cx->sb_dstr : cx->sb_targ);
352 rxres_save(&cx->sb_rxres, rx);
354 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
358 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
363 PERL_ARGS_ASSERT_RXRES_SAVE;
366 if (!p || p[1] < RX_NPARENS(rx)) {
368 i = 7 + (RX_NPARENS(rx)+1) * 2;
370 i = 6 + (RX_NPARENS(rx)+1) * 2;
379 /* what (if anything) to free on croak */
380 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
381 RX_MATCH_COPIED_off(rx);
382 *p++ = RX_NPARENS(rx);
385 *p++ = PTR2UV(RX_SAVED_COPY(rx));
386 RX_SAVED_COPY(rx) = NULL;
389 *p++ = PTR2UV(RX_SUBBEG(rx));
390 *p++ = (UV)RX_SUBLEN(rx);
391 *p++ = (UV)RX_SUBOFFSET(rx);
392 *p++ = (UV)RX_SUBCOFFSET(rx);
393 for (i = 0; i <= RX_NPARENS(rx); ++i) {
394 *p++ = (UV)RX_OFFS(rx)[i].start;
395 *p++ = (UV)RX_OFFS(rx)[i].end;
400 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
405 PERL_ARGS_ASSERT_RXRES_RESTORE;
408 RX_MATCH_COPY_FREE(rx);
409 RX_MATCH_COPIED_set(rx, *p);
411 RX_NPARENS(rx) = *p++;
414 if (RX_SAVED_COPY(rx))
415 SvREFCNT_dec (RX_SAVED_COPY(rx));
416 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
420 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
421 RX_SUBLEN(rx) = (I32)(*p++);
422 RX_SUBOFFSET(rx) = (I32)*p++;
423 RX_SUBCOFFSET(rx) = (I32)*p++;
424 for (i = 0; i <= RX_NPARENS(rx); ++i) {
425 RX_OFFS(rx)[i].start = (I32)(*p++);
426 RX_OFFS(rx)[i].end = (I32)(*p++);
431 S_rxres_free(pTHX_ void **rsp)
433 UV * const p = (UV*)*rsp;
435 PERL_ARGS_ASSERT_RXRES_FREE;
439 void *tmp = INT2PTR(char*,*p);
442 U32 i = 9 + p[1] * 2;
444 U32 i = 8 + p[1] * 2;
449 SvREFCNT_dec (INT2PTR(SV*,p[2]));
452 PoisonFree(p, i, sizeof(UV));
461 #define FORM_NUM_BLANK (1<<30)
462 #define FORM_NUM_POINT (1<<29)
466 dSP; dMARK; dORIGMARK;
467 SV * const tmpForm = *++MARK;
468 SV *formsv; /* contains text of original format */
469 U32 *fpc; /* format ops program counter */
470 char *t; /* current append position in target string */
471 const char *f; /* current position in format string */
473 SV *sv = NULL; /* current item */
474 const char *item = NULL;/* string value of current item */
475 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
476 I32 itembytes = 0; /* as itemsize, but length in bytes */
477 I32 fieldsize = 0; /* width of current field */
478 I32 lines = 0; /* number of lines that have been output */
479 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
480 const char *chophere = NULL; /* where to chop current item */
481 STRLEN linemark = 0; /* pos of start of line in output */
483 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
484 STRLEN len; /* length of current sv */
485 STRLEN linemax; /* estimate of output size in bytes */
486 bool item_is_utf8 = FALSE;
487 bool targ_is_utf8 = FALSE;
490 U8 *source; /* source of bytes to append */
491 STRLEN to_copy; /* how may bytes to append */
492 char trans; /* what chars to translate */
494 mg = doparseform(tmpForm);
496 fpc = (U32*)mg->mg_ptr;
497 /* the actual string the format was compiled from.
498 * with overload etc, this may not match tmpForm */
502 SvPV_force(PL_formtarget, len);
503 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
504 SvTAINTED_on(PL_formtarget);
505 if (DO_UTF8(PL_formtarget))
507 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
508 t = SvGROW(PL_formtarget, len + linemax + 1);
509 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
511 f = SvPV_const(formsv, len);
515 const char *name = "???";
518 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
519 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
520 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
521 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
522 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
524 case FF_CHECKNL: name = "CHECKNL"; break;
525 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
526 case FF_SPACE: name = "SPACE"; break;
527 case FF_HALFSPACE: name = "HALFSPACE"; break;
528 case FF_ITEM: name = "ITEM"; break;
529 case FF_CHOP: name = "CHOP"; break;
530 case FF_LINEGLOB: name = "LINEGLOB"; break;
531 case FF_NEWLINE: name = "NEWLINE"; break;
532 case FF_MORE: name = "MORE"; break;
533 case FF_LINEMARK: name = "LINEMARK"; break;
534 case FF_END: name = "END"; break;
535 case FF_0DECIMAL: name = "0DECIMAL"; break;
536 case FF_LINESNGL: name = "LINESNGL"; break;
539 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
541 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
544 case FF_LINEMARK: /* start (or end) of a line */
545 linemark = t - SvPVX(PL_formtarget);
550 case FF_LITERAL: /* append <arg> literal chars */
555 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
558 case FF_SKIP: /* skip <arg> chars in format */
562 case FF_FETCH: /* get next item and set field size to <arg> */
571 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
574 SvTAINTED_on(PL_formtarget);
577 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
579 const char *s = item = SvPV_const(sv, len);
580 const char *send = s + len;
583 item_is_utf8 = DO_UTF8(sv);
595 if (itemsize == fieldsize)
598 itembytes = s - item;
603 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
605 const char *s = item = SvPV_const(sv, len);
606 const char *send = s + len;
610 item_is_utf8 = DO_UTF8(sv);
612 /* look for a legal split position */
620 /* provisional split point */
624 /* we delay testing fieldsize until after we've
625 * processed the possible split char directly
626 * following the last field char; so if fieldsize=3
627 * and item="a b cdef", we consume "a b", not "a".
628 * Ditto further down.
630 if (size == fieldsize)
634 if (strchr(PL_chopset, *s)) {
635 /* provisional split point */
636 /* for a non-space split char, we include
637 * the split char; hence the '+1' */
641 if (size == fieldsize)
653 if (!chophere || s == send) {
657 itembytes = chophere - item;
662 case FF_SPACE: /* append padding space (diff of field, item size) */
663 arg = fieldsize - itemsize;
671 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
672 arg = fieldsize - itemsize;
681 case FF_ITEM: /* append a text item, while blanking ctrl chars */
687 case FF_CHOP: /* (for ^*) chop the current item */
688 if (sv != &PL_sv_no) {
689 const char *s = chophere;
697 /* tied, overloaded or similar strangeness.
698 * Do it the hard way */
699 sv_setpvn(sv, s, len - (s-item));
704 case FF_LINESNGL: /* process ^* */
708 case FF_LINEGLOB: /* process @* */
710 const bool oneline = fpc[-1] == FF_LINESNGL;
711 const char *s = item = SvPV_const(sv, len);
712 const char *const send = s + len;
714 item_is_utf8 = DO_UTF8(sv);
725 to_copy = s - item - 1;
739 /* append to_copy bytes from source to PL_formstring.
740 * item_is_utf8 implies source is utf8.
741 * if trans, translate certain characters during the copy */
746 SvCUR_set(PL_formtarget,
747 t - SvPVX_const(PL_formtarget));
749 if (targ_is_utf8 && !item_is_utf8) {
750 source = tmp = bytes_to_utf8(source, &to_copy);
752 if (item_is_utf8 && !targ_is_utf8) {
754 /* Upgrade targ to UTF8, and then we reduce it to
755 a problem we have a simple solution for.
756 Don't need get magic. */
757 sv_utf8_upgrade_nomg(PL_formtarget);
759 /* re-calculate linemark */
760 s = (U8*)SvPVX(PL_formtarget);
761 /* the bytes we initially allocated to append the
762 * whole line may have been gobbled up during the
763 * upgrade, so allocate a whole new line's worth
768 linemark = s - (U8*)SvPVX(PL_formtarget);
770 /* Easy. They agree. */
771 assert (item_is_utf8 == targ_is_utf8);
774 /* @* and ^* are the only things that can exceed
775 * the linemax, so grow by the output size, plus
776 * a whole new form's worth in case of any further
778 grow = linemax + to_copy;
780 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
781 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
783 Copy(source, t, to_copy, char);
785 /* blank out ~ or control chars, depending on trans.
786 * works on bytes not chars, so relies on not
787 * matching utf8 continuation bytes */
789 U8 *send = s + to_copy;
792 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
799 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
805 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
808 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
811 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
814 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
816 /* If the field is marked with ^ and the value is undefined,
818 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
826 /* overflow evidence */
827 if (num_overflow(value, fieldsize, arg)) {
833 /* Formats aren't yet marked for locales, so assume "yes". */
835 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
837 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
838 STORE_LC_NUMERIC_SET_TO_NEEDED();
839 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
842 const char* qfmt = quadmath_format_single(fmt);
845 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
846 len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
848 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
853 /* we generate fmt ourselves so it is safe */
854 GCC_DIAG_IGNORE(-Wformat-nonliteral);
855 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
858 PERL_MY_SNPRINTF_POST_GUARD(len, max);
859 RESTORE_LC_NUMERIC();
864 case FF_NEWLINE: /* delete trailing spaces, then append \n */
866 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
871 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
874 if (arg) { /* repeat until fields exhausted? */
880 t = SvPVX(PL_formtarget) + linemark;
885 case FF_MORE: /* replace long end of string with '...' */
887 const char *s = chophere;
888 const char *send = item + len;
890 while (isSPACE(*s) && (s < send))
895 arg = fieldsize - itemsize;
902 if (strnEQ(s1," ",3)) {
903 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
913 case FF_END: /* tidy up, then return */
915 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
917 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
919 SvUTF8_on(PL_formtarget);
920 FmLINES(PL_formtarget) += lines;
922 if (fpc[-1] == FF_BLANK)
923 RETURNOP(cLISTOP->op_first);
935 if (PL_stack_base + TOPMARK == SP) {
937 if (GIMME_V == G_SCALAR)
939 RETURNOP(PL_op->op_next->op_next);
941 PL_stack_sp = PL_stack_base + TOPMARK + 1;
942 Perl_pp_pushmark(aTHX); /* push dst */
943 Perl_pp_pushmark(aTHX); /* push src */
944 ENTER_with_name("grep"); /* enter outer scope */
948 ENTER_with_name("grep_item"); /* enter inner scope */
951 src = PL_stack_base[TOPMARK];
953 src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
960 if (PL_op->op_type == OP_MAPSTART)
961 Perl_pp_pushmark(aTHX); /* push top */
962 return ((LOGOP*)PL_op->op_next)->op_other;
968 const U8 gimme = GIMME_V;
969 I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
975 /* first, move source pointer to the next item in the source list */
976 ++PL_markstack_ptr[-1];
978 /* if there are new items, push them into the destination list */
979 if (items && gimme != G_VOID) {
980 /* might need to make room back there first */
981 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
982 /* XXX this implementation is very pessimal because the stack
983 * is repeatedly extended for every set of items. Is possible
984 * to do this without any stack extension or copying at all
985 * by maintaining a separate list over which the map iterates
986 * (like foreach does). --gsar */
988 /* everything in the stack after the destination list moves
989 * towards the end the stack by the amount of room needed */
990 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
992 /* items to shift up (accounting for the moved source pointer) */
993 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
995 /* This optimization is by Ben Tilly and it does
996 * things differently from what Sarathy (gsar)
997 * is describing. The downside of this optimization is
998 * that leaves "holes" (uninitialized and hopefully unused areas)
999 * to the Perl stack, but on the other hand this
1000 * shouldn't be a problem. If Sarathy's idea gets
1001 * implemented, this optimization should become
1002 * irrelevant. --jhi */
1004 shift = count; /* Avoid shifting too often --Ben Tilly */
1008 dst = (SP += shift);
1009 PL_markstack_ptr[-1] += shift;
1010 *PL_markstack_ptr += shift;
1014 /* copy the new items down to the destination list */
1015 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1016 if (gimme == G_ARRAY) {
1017 /* add returned items to the collection (making mortal copies
1018 * if necessary), then clear the current temps stack frame
1019 * *except* for those items. We do this splicing the items
1020 * into the start of the tmps frame (so some items may be on
1021 * the tmps stack twice), then moving PL_tmps_floor above
1022 * them, then freeing the frame. That way, the only tmps that
1023 * accumulate over iterations are the return values for map.
1024 * We have to do to this way so that everything gets correctly
1025 * freed if we die during the map.
1029 /* make space for the slice */
1030 EXTEND_MORTAL(items);
1031 tmpsbase = PL_tmps_floor + 1;
1032 Move(PL_tmps_stack + tmpsbase,
1033 PL_tmps_stack + tmpsbase + items,
1034 PL_tmps_ix - PL_tmps_floor,
1036 PL_tmps_ix += items;
1041 sv = sv_mortalcopy(sv);
1043 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1045 /* clear the stack frame except for the items */
1046 PL_tmps_floor += items;
1048 /* FREETMPS may have cleared the TEMP flag on some of the items */
1051 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1054 /* scalar context: we don't care about which values map returns
1055 * (we use undef here). And so we certainly don't want to do mortal
1056 * copies of meaningless values. */
1057 while (items-- > 0) {
1059 *dst-- = &PL_sv_undef;
1067 LEAVE_with_name("grep_item"); /* exit inner scope */
1070 if (PL_markstack_ptr[-1] > TOPMARK) {
1072 (void)POPMARK; /* pop top */
1073 LEAVE_with_name("grep"); /* exit outer scope */
1074 (void)POPMARK; /* pop src */
1075 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1076 (void)POPMARK; /* pop dst */
1077 SP = PL_stack_base + POPMARK; /* pop original mark */
1078 if (gimme == G_SCALAR) {
1082 else if (gimme == G_ARRAY)
1089 ENTER_with_name("grep_item"); /* enter inner scope */
1092 /* set $_ to the new source item */
1093 src = PL_stack_base[PL_markstack_ptr[-1]];
1094 if (SvPADTMP(src)) {
1095 src = sv_mortalcopy(src);
1100 RETURNOP(cLOGOP->op_other);
1108 if (GIMME_V == G_ARRAY)
1110 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1111 return cLOGOP->op_other;
1120 if (GIMME_V == G_ARRAY) {
1121 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1125 SV * const targ = PAD_SV(PL_op->op_targ);
1128 if (PL_op->op_private & OPpFLIP_LINENUM) {
1129 if (GvIO(PL_last_in_gv)) {
1130 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1133 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1135 flip = SvIV(sv) == SvIV(GvSV(gv));
1141 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1142 if (PL_op->op_flags & OPf_SPECIAL) {
1150 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1153 sv_setpvs(TARG, "");
1159 /* This code tries to decide if "$left .. $right" should use the
1160 magical string increment, or if the range is numeric (we make
1161 an exception for .."0" [#18165]). AMS 20021031. */
1163 #define RANGE_IS_NUMERIC(left,right) ( \
1164 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1165 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1166 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1167 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1168 && (!SvOK(right) || looks_like_number(right))))
1174 if (GIMME_V == G_ARRAY) {
1180 if (RANGE_IS_NUMERIC(left,right)) {
1182 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1183 (SvOK(right) && (SvIOK(right)
1184 ? SvIsUV(right) && SvUV(right) > IV_MAX
1185 : SvNV_nomg(right) > IV_MAX)))
1186 DIE(aTHX_ "Range iterator outside integer range");
1187 i = SvIV_nomg(left);
1188 j = SvIV_nomg(right);
1190 /* Dance carefully around signed max. */
1191 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1194 /* The wraparound of signed integers is undefined
1195 * behavior, but here we aim for count >=1, and
1196 * negative count is just wrong. */
1198 #if IVSIZE > Size_t_size
1205 Perl_croak(aTHX_ "Out of memory during list extend");
1212 SV * const sv = sv_2mortal(newSViv(i));
1214 if (n) /* avoid incrementing above IV_MAX */
1220 const char * const lpv = SvPV_nomg_const(left, llen);
1221 const char * const tmps = SvPV_nomg_const(right, len);
1223 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1224 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1226 if (strEQ(SvPVX_const(sv),tmps))
1228 sv = sv_2mortal(newSVsv(sv));
1235 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1239 if (PL_op->op_private & OPpFLIP_LINENUM) {
1240 if (GvIO(PL_last_in_gv)) {
1241 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1244 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1245 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1253 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1254 sv_catpvs(targ, "E0");
1264 static const char * const context_name[] = {
1266 NULL, /* CXt_WHEN never actually needs "block" */
1267 NULL, /* CXt_BLOCK never actually needs "block" */
1268 NULL, /* CXt_GIVEN never actually needs "block" */
1269 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1270 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1271 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1272 NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1273 NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1281 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1285 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1287 for (i = cxstack_ix; i >= 0; i--) {
1288 const PERL_CONTEXT * const cx = &cxstack[i];
1289 switch (CxTYPE(cx)) {
1295 /* diag_listed_as: Exiting subroutine via %s */
1296 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1297 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1298 if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1301 case CXt_LOOP_PLAIN:
1302 case CXt_LOOP_LAZYIV:
1303 case CXt_LOOP_LAZYSV:
1307 STRLEN cx_label_len = 0;
1308 U32 cx_label_flags = 0;
1309 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1311 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1314 (const U8*)cx_label, cx_label_len,
1315 (const U8*)label, len) == 0)
1317 (const U8*)label, len,
1318 (const U8*)cx_label, cx_label_len) == 0)
1319 : (len == cx_label_len && ((cx_label == label)
1320 || memEQ(cx_label, label, len))) )) {
1321 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1322 (long)i, cx_label));
1325 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1336 Perl_dowantarray(pTHX)
1338 const U8 gimme = block_gimme();
1339 return (gimme == G_VOID) ? G_SCALAR : gimme;
1343 Perl_block_gimme(pTHX)
1345 const I32 cxix = dopoptosub(cxstack_ix);
1350 gimme = (cxstack[cxix].blk_gimme & G_WANT);
1352 Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1358 Perl_is_lvalue_sub(pTHX)
1360 const I32 cxix = dopoptosub(cxstack_ix);
1361 assert(cxix >= 0); /* We should only be called from inside subs */
1363 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1364 return CxLVAL(cxstack + cxix);
1369 /* only used by cx_pushsub() */
1371 Perl_was_lvalue_sub(pTHX)
1373 const I32 cxix = dopoptosub(cxstack_ix-1);
1374 assert(cxix >= 0); /* We should only be called from inside subs */
1376 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1377 return CxLVAL(cxstack + cxix);
1383 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1387 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1389 PERL_UNUSED_CONTEXT;
1392 for (i = startingblock; i >= 0; i--) {
1393 const PERL_CONTEXT * const cx = &cxstk[i];
1394 switch (CxTYPE(cx)) {
1398 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1399 * twice; the first for the normal foo() call, and the second
1400 * for a faked up re-entry into the sub to execute the
1401 * code block. Hide this faked entry from the world. */
1402 if (cx->cx_type & CXp_SUB_RE_FAKE)
1407 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1415 S_dopoptoeval(pTHX_ I32 startingblock)
1418 for (i = startingblock; i >= 0; i--) {
1419 const PERL_CONTEXT *cx = &cxstack[i];
1420 switch (CxTYPE(cx)) {
1424 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1432 S_dopoptoloop(pTHX_ I32 startingblock)
1435 for (i = startingblock; i >= 0; i--) {
1436 const PERL_CONTEXT * const cx = &cxstack[i];
1437 switch (CxTYPE(cx)) {
1443 /* diag_listed_as: Exiting subroutine via %s */
1444 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1445 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1446 if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1449 case CXt_LOOP_PLAIN:
1450 case CXt_LOOP_LAZYIV:
1451 case CXt_LOOP_LAZYSV:
1454 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1461 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1464 S_dopoptogivenfor(pTHX_ I32 startingblock)
1467 for (i = startingblock; i >= 0; i--) {
1468 const PERL_CONTEXT *cx = &cxstack[i];
1469 switch (CxTYPE(cx)) {
1473 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1475 case CXt_LOOP_PLAIN:
1476 assert(!(cx->cx_type & CXp_FOR_DEF));
1478 case CXt_LOOP_LAZYIV:
1479 case CXt_LOOP_LAZYSV:
1482 if (cx->cx_type & CXp_FOR_DEF) {
1483 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1492 S_dopoptowhen(pTHX_ I32 startingblock)
1495 for (i = startingblock; i >= 0; i--) {
1496 const PERL_CONTEXT *cx = &cxstack[i];
1497 switch (CxTYPE(cx)) {
1501 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1508 /* dounwind(): pop all contexts above (but not including) cxix.
1509 * Note that it clears the savestack frame associated with each popped
1510 * context entry, but doesn't free any temps.
1511 * It does a cx_popblock() of the last frame that it pops, and leaves
1512 * cxstack_ix equal to cxix.
1516 Perl_dounwind(pTHX_ I32 cxix)
1518 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1521 while (cxstack_ix > cxix) {
1522 PERL_CONTEXT *cx = CX_CUR();
1524 CX_DEBUG(cx, "UNWIND");
1525 /* Note: we don't need to restore the base context info till the end. */
1529 switch (CxTYPE(cx)) {
1539 case CXt_LOOP_PLAIN:
1540 case CXt_LOOP_LAZYIV:
1541 case CXt_LOOP_LAZYSV:
1554 /* these two don't have a POPFOO() */
1560 if (cxstack_ix == cxix + 1) {
1569 Perl_qerror(pTHX_ SV *err)
1571 PERL_ARGS_ASSERT_QERROR;
1574 if (PL_in_eval & EVAL_KEEPERR) {
1575 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1579 sv_catsv(ERRSV, err);
1582 sv_catsv(PL_errors, err);
1584 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1586 ++PL_parser->error_count;
1591 /* undef or delete the $INC{namesv} entry, then croak.
1592 * require0 indicates that the require didn't return a true value */
1595 S_undo_inc_then_croak(pTHX_ SV *namesv, SV *err, bool require0)
1598 HV *inc_hv = GvHVn(PL_incgv);
1599 I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv);
1600 const char *key = SvPVX_const(namesv);
1603 (void)hv_delete(inc_hv, key, klen, G_DISCARD);
1604 fmt = "%"SVf" did not return a true value";
1608 (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0);
1609 fmt = "%"SVf"Compilation failed in require";
1610 err = err ? err : newSVpvs_flags("Unknown error\n", SVs_TEMP);
1613 Perl_croak(aTHX_ fmt, SVfARG(err));
1618 Perl_die_unwind(pTHX_ SV *msv)
1620 SV *exceptsv = sv_mortalcopy(msv);
1621 U8 in_eval = PL_in_eval;
1622 PERL_ARGS_ASSERT_DIE_UNWIND;
1628 * Historically, perl used to set ERRSV ($@) early in the die
1629 * process and rely on it not getting clobbered during unwinding.
1630 * That sucked, because it was liable to get clobbered, so the
1631 * setting of ERRSV used to emit the exception from eval{} has
1632 * been moved to much later, after unwinding (see just before
1633 * JMPENV_JUMP below). However, some modules were relying on the
1634 * early setting, by examining $@ during unwinding to use it as
1635 * a flag indicating whether the current unwinding was caused by
1636 * an exception. It was never a reliable flag for that purpose,
1637 * being totally open to false positives even without actual
1638 * clobberage, but was useful enough for production code to
1639 * semantically rely on it.
1641 * We'd like to have a proper introspective interface that
1642 * explicitly describes the reason for whatever unwinding
1643 * operations are currently in progress, so that those modules
1644 * work reliably and $@ isn't further overloaded. But we don't
1645 * have one yet. In its absence, as a stopgap measure, ERRSV is
1646 * now *additionally* set here, before unwinding, to serve as the
1647 * (unreliable) flag that it used to.
1649 * This behaviour is temporary, and should be removed when a
1650 * proper way to detect exceptional unwinding has been developed.
1651 * As of 2010-12, the authors of modules relying on the hack
1652 * are aware of the issue, because the modules failed on
1653 * perls 5.13.{1..7} which had late setting of $@ without this
1654 * early-setting hack.
1656 if (!(in_eval & EVAL_KEEPERR)) {
1657 SvTEMP_off(exceptsv);
1658 sv_setsv(ERRSV, exceptsv);
1661 if (in_eval & EVAL_KEEPERR) {
1662 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1666 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1667 && PL_curstackinfo->si_prev)
1678 JMPENV *restartjmpenv;
1681 if (cxix < cxstack_ix)
1685 assert(CxTYPE(cx) == CXt_EVAL);
1687 /* return false to the caller of eval */
1688 oldsp = PL_stack_base + cx->blk_oldsp;
1689 gimme = cx->blk_gimme;
1690 if (gimme == G_SCALAR)
1691 *++oldsp = &PL_sv_undef;
1692 PL_stack_sp = oldsp;
1697 restartjmpenv = cx->blk_eval.cur_top_env;
1698 restartop = cx->blk_eval.retop;
1699 if (CxOLD_OP_TYPE(cx) == OP_REQUIRE)
1700 namesv = cx->blk_eval.old_namesv;
1704 /* note that unlike pp_entereval, pp_require isn't
1705 * supposed to trap errors. So now that we've popped the
1706 * EVAL that pp_require pushed, process the error message
1707 * and rethrow the error */
1708 S_undo_inc_then_croak(aTHX_ namesv, exceptsv, FALSE);
1709 NOT_REACHED; /* NOTREACHED */
1712 if (!(in_eval & EVAL_KEEPERR))
1713 sv_setsv(ERRSV, exceptsv);
1714 PL_restartjmpenv = restartjmpenv;
1715 PL_restartop = restartop;
1717 NOT_REACHED; /* NOTREACHED */
1721 write_to_stderr(exceptsv);
1723 NOT_REACHED; /* NOTREACHED */
1729 if (SvTRUE(left) != SvTRUE(right))
1737 =head1 CV Manipulation Functions
1739 =for apidoc caller_cx
1741 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1742 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1743 information returned to Perl by C<caller>. Note that XSUBs don't get a
1744 stack frame, so C<caller_cx(0, NULL)> will return information for the
1745 immediately-surrounding Perl code.
1747 This function skips over the automatic calls to C<&DB::sub> made on the
1748 behalf of the debugger. If the stack frame requested was a sub called by
1749 C<DB::sub>, the return value will be the frame for the call to
1750 C<DB::sub>, since that has the correct line number/etc. for the call
1751 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1752 frame for the sub call itself.
1757 const PERL_CONTEXT *
1758 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1760 I32 cxix = dopoptosub(cxstack_ix);
1761 const PERL_CONTEXT *cx;
1762 const PERL_CONTEXT *ccstack = cxstack;
1763 const PERL_SI *top_si = PL_curstackinfo;
1766 /* we may be in a higher stacklevel, so dig down deeper */
1767 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1768 top_si = top_si->si_prev;
1769 ccstack = top_si->si_cxstack;
1770 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1774 /* caller() should not report the automatic calls to &DB::sub */
1775 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1776 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1780 cxix = dopoptosub_at(ccstack, cxix - 1);
1783 cx = &ccstack[cxix];
1784 if (dbcxp) *dbcxp = cx;
1786 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1787 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1788 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1789 field below is defined for any cx. */
1790 /* caller() should not report the automatic calls to &DB::sub */
1791 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1792 cx = &ccstack[dbcxix];
1801 const PERL_CONTEXT *cx;
1802 const PERL_CONTEXT *dbcx;
1804 const HEK *stash_hek;
1806 bool has_arg = MAXARG && TOPs;
1815 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1817 if (gimme != G_ARRAY) {
1824 CX_DEBUG(cx, "CALLER");
1825 assert(CopSTASH(cx->blk_oldcop));
1826 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1827 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1829 if (gimme != G_ARRAY) {
1832 PUSHs(&PL_sv_undef);
1835 sv_sethek(TARG, stash_hek);
1844 PUSHs(&PL_sv_undef);
1847 sv_sethek(TARG, stash_hek);
1850 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1851 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1852 cx->blk_sub.retop, TRUE);
1854 lcop = cx->blk_oldcop;
1855 mPUSHu(CopLINE(lcop));
1858 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1859 /* So is ccstack[dbcxix]. */
1860 if (CvHASGV(dbcx->blk_sub.cv)) {
1861 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1862 PUSHs(boolSV(CxHASARGS(cx)));
1865 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1866 PUSHs(boolSV(CxHASARGS(cx)));
1870 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1873 gimme = cx->blk_gimme;
1874 if (gimme == G_VOID)
1875 PUSHs(&PL_sv_undef);
1877 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1878 if (CxTYPE(cx) == CXt_EVAL) {
1880 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1881 SV *cur_text = cx->blk_eval.cur_text;
1882 if (SvCUR(cur_text) >= 2) {
1883 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1884 SvUTF8(cur_text)|SVs_TEMP));
1887 /* I think this is will always be "", but be sure */
1888 PUSHs(sv_2mortal(newSVsv(cur_text)));
1894 else if (cx->blk_eval.old_namesv) {
1895 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1898 /* eval BLOCK (try blocks have old_namesv == 0) */
1900 PUSHs(&PL_sv_undef);
1901 PUSHs(&PL_sv_undef);
1905 PUSHs(&PL_sv_undef);
1906 PUSHs(&PL_sv_undef);
1908 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1909 && CopSTASH_eq(PL_curcop, PL_debstash))
1911 /* slot 0 of the pad contains the original @_ */
1912 AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
1913 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1914 cx->blk_sub.olddepth+1]))[0]);
1915 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1917 Perl_init_dbargs(aTHX);
1919 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1920 av_extend(PL_dbargs, AvFILLp(ary) + off);
1921 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1922 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1924 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1927 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1929 if (old_warnings == pWARN_NONE)
1930 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1931 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1932 mask = &PL_sv_undef ;
1933 else if (old_warnings == pWARN_ALL ||
1934 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1935 /* Get the bit mask for $warnings::Bits{all}, because
1936 * it could have been extended by warnings::register */
1938 HV * const bits = get_hv("warnings::Bits", 0);
1939 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1940 mask = newSVsv(*bits_all);
1943 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1947 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1951 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1952 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1962 if (MAXARG < 1 || (!TOPs && !POPs))
1963 tmps = NULL, len = 0;
1965 tmps = SvPVx_const(POPs, len);
1966 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1971 /* like pp_nextstate, but used instead when the debugger is active */
1975 PL_curcop = (COP*)PL_op;
1976 TAINT_NOT; /* Each statement is presumed innocent */
1977 PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
1982 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1983 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
1987 const U8 gimme = G_ARRAY;
1988 GV * const gv = PL_DBgv;
1991 if (gv && isGV_with_GP(gv))
1994 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1995 DIE(aTHX_ "No DB::DB routine defined");
1997 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1998 /* don't do recursive DB::DB call */
2008 (void)(*CvXSUB(cv))(aTHX_ cv);
2014 cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
2015 cx_pushsub(cx, cv, PL_op->op_next, 0);
2016 /* OP_DBSTATE's op_private holds hint bits rather than
2017 * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2018 * any CxLVAL() flags that have now been mis-calculated */
2025 if (CvDEPTH(cv) >= 2)
2026 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2027 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2028 RETURNOP(CvSTART(cv));
2040 (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2052 assert(CxTYPE(cx) == CXt_BLOCK);
2054 if (PL_op->op_flags & OPf_SPECIAL)
2055 /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */
2056 cx->blk_oldpm = PL_curpm;
2058 oldsp = PL_stack_base + cx->blk_oldsp;
2059 gimme = cx->blk_gimme;
2061 if (gimme == G_VOID)
2062 PL_stack_sp = oldsp;
2064 leave_adjust_stacks(oldsp, oldsp, gimme,
2065 PL_op->op_private & OPpLVALUE ? 3 : 1);
2075 S_outside_integer(pTHX_ SV *sv)
2078 const NV nv = SvNV_nomg(sv);
2079 if (Perl_isinfnan(nv))
2081 #ifdef NV_PRESERVES_UV
2082 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2085 if (nv <= (NV)IV_MIN)
2088 ((nv > (NV)UV_MAX ||
2089 SvUV_nomg(sv) > (UV)IV_MAX)))
2100 const U8 gimme = GIMME_V;
2101 void *itervarp; /* GV or pad slot of the iteration variable */
2102 SV *itersave; /* the old var in the iterator var slot */
2105 if (PL_op->op_targ) { /* "my" variable */
2106 itervarp = &PAD_SVl(PL_op->op_targ);
2107 itersave = *(SV**)itervarp;
2109 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2110 /* the SV currently in the pad slot is never live during
2111 * iteration (the slot is always aliased to one of the items)
2112 * so it's always stale */
2113 SvPADSTALE_on(itersave);
2115 SvREFCNT_inc_simple_void_NN(itersave);
2116 cxflags = CXp_FOR_PAD;
2119 SV * const sv = POPs;
2120 itervarp = (void *)sv;
2121 if (LIKELY(isGV(sv))) { /* symbol table variable */
2122 itersave = GvSV(sv);
2123 SvREFCNT_inc_simple_void(itersave);
2124 cxflags = CXp_FOR_GV;
2125 if (PL_op->op_private & OPpITER_DEF)
2126 cxflags |= CXp_FOR_DEF;
2128 else { /* LV ref: for \$foo (...) */
2129 assert(SvTYPE(sv) == SVt_PVMG);
2130 assert(SvMAGIC(sv));
2131 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2133 cxflags = CXp_FOR_LVREF;
2136 /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2137 assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2139 /* Note that this context is initially set as CXt_NULL. Further on
2140 * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2141 * there mustn't be anything in the blk_loop substruct that requires
2142 * freeing or undoing, in case we die in the meantime. And vice-versa.
2144 cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2145 cx_pushloop_for(cx, itervarp, itersave);
2147 if (PL_op->op_flags & OPf_STACKED) {
2148 /* OPf_STACKED implies either a single array: for(@), with a
2149 * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2151 SV *maybe_ary = POPs;
2152 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2155 SV * const right = maybe_ary;
2156 if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2157 DIE(aTHX_ "Assigned value is not a reference");
2160 if (RANGE_IS_NUMERIC(sv,right)) {
2161 cx->cx_type |= CXt_LOOP_LAZYIV;
2162 if (S_outside_integer(aTHX_ sv) ||
2163 S_outside_integer(aTHX_ right))
2164 DIE(aTHX_ "Range iterator outside integer range");
2165 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2166 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2169 cx->cx_type |= CXt_LOOP_LAZYSV;
2170 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2171 cx->blk_loop.state_u.lazysv.end = right;
2172 SvREFCNT_inc_simple_void_NN(right);
2173 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2174 /* This will do the upgrade to SVt_PV, and warn if the value
2175 is uninitialised. */
2176 (void) SvPV_nolen_const(right);
2177 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2178 to replace !SvOK() with a pointer to "". */
2180 SvREFCNT_dec(right);
2181 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2185 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2186 /* for (@array) {} */
2187 cx->cx_type |= CXt_LOOP_ARY;
2188 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2189 SvREFCNT_inc_simple_void_NN(maybe_ary);
2190 cx->blk_loop.state_u.ary.ix =
2191 (PL_op->op_private & OPpITER_REVERSED) ?
2192 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2195 /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
2197 else { /* iterating over items on the stack */
2198 cx->cx_type |= CXt_LOOP_LIST;
2199 cx->blk_oldsp = SP - PL_stack_base;
2200 cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2201 cx->blk_loop.state_u.stack.ix =
2202 (PL_op->op_private & OPpITER_REVERSED)
2204 : cx->blk_loop.state_u.stack.basesp;
2205 /* pre-extend stack so pp_iter doesn't have to check every time
2206 * it pushes yes/no */
2216 const U8 gimme = GIMME_V;
2218 cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2219 cx_pushloop_plain(cx);
2232 assert(CxTYPE_is_LOOP(cx));
2233 mark = PL_stack_base + cx->blk_oldsp;
2234 oldsp = CxTYPE(cx) == CXt_LOOP_LIST
2235 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2237 gimme = cx->blk_gimme;
2239 if (gimme == G_VOID)
2240 PL_stack_sp = oldsp;
2242 leave_adjust_stacks(MARK, oldsp, gimme,
2243 PL_op->op_private & OPpLVALUE ? 3 : 1);
2246 cx_poploop(cx); /* Stack values are safe: release loop vars ... */
2254 /* This duplicates most of pp_leavesub, but with additional code to handle
2255 * return args in lvalue context. It was forked from pp_leavesub to
2256 * avoid slowing down that function any further.
2258 * Any changes made to this function may need to be copied to pp_leavesub
2261 * also tail-called by pp_return
2272 assert(CxTYPE(cx) == CXt_SUB);
2274 if (CxMULTICALL(cx)) {
2275 /* entry zero of a stack is always PL_sv_undef, which
2276 * simplifies converting a '()' return into undef in scalar context */
2277 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2281 gimme = cx->blk_gimme;
2282 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2284 if (gimme == G_VOID)
2285 PL_stack_sp = oldsp;
2287 U8 lval = CxLVAL(cx);
2288 bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2289 const char *what = NULL;
2291 if (gimme == G_SCALAR) {
2293 /* check for bad return arg */
2294 if (oldsp < PL_stack_sp) {
2295 SV *sv = *PL_stack_sp;
2296 if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2298 SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2299 : "a readonly value" : "a temporary";
2304 /* sub:lvalue{} will take us here. */
2309 "Can't return %s from lvalue subroutine", what);
2313 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2315 if (lval & OPpDEREF) {
2316 /* lval_sub()->{...} and similar */
2320 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2326 assert(gimme == G_ARRAY);
2327 assert (!(lval & OPpDEREF));
2330 /* scan for bad return args */
2332 for (p = PL_stack_sp; p > oldsp; p--) {
2334 /* the PL_sv_undef exception is to allow things like
2335 * this to work, where PL_sv_undef acts as 'skip'
2336 * placeholder on the LHS of list assigns:
2337 * sub foo :lvalue { undef }
2338 * ($a, undef, foo(), $b) = 1..4;
2340 if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2342 /* Might be flattened array after $#array = */
2343 what = SvREADONLY(sv)
2344 ? "a readonly value" : "a temporary";
2350 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2355 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
2357 retop = cx->blk_sub.retop;
2368 const I32 cxix = dopoptosub(cxstack_ix);
2370 assert(cxstack_ix >= 0);
2371 if (cxix < cxstack_ix) {
2373 if (!( PL_curstackinfo->si_type == PERLSI_SORT
2374 || ( PL_curstackinfo->si_type == PERLSI_MULTICALL
2375 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2378 DIE(aTHX_ "Can't return outside a subroutine");
2380 * a sort block, which is a CXt_NULL not a CXt_SUB;
2381 * or a /(?{...})/ block.
2382 * Handle specially. */
2383 assert(CxTYPE(&cxstack[0]) == CXt_NULL
2384 || ( CxTYPE(&cxstack[0]) == CXt_SUB
2385 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2386 if (cxstack_ix > 0) {
2387 /* See comment below about context popping. Since we know
2388 * we're scalar and not lvalue, we can preserve the return
2389 * value in a simpler fashion than there. */
2391 assert(cxstack[0].blk_gimme == G_SCALAR);
2392 if ( (sp != PL_stack_base)
2393 && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2395 *SP = sv_mortalcopy(sv);
2398 /* caller responsible for popping cxstack[0] */
2402 /* There are contexts that need popping. Doing this may free the
2403 * return value(s), so preserve them first: e.g. popping the plain
2404 * loop here would free $x:
2405 * sub f { { my $x = 1; return $x } }
2406 * We may also need to shift the args down; for example,
2407 * for (1,2) { return 3,4 }
2408 * leaves 1,2,3,4 on the stack. Both these actions will be done by
2409 * leave_adjust_stacks(), along with freeing any temps. Note that
2410 * whoever we tail-call (e.g. pp_leaveeval) will also call
2411 * leave_adjust_stacks(); however, the second call is likely to
2412 * just see a bunch of SvTEMPs with a ref count of 1, and so just
2413 * pass them through, rather than copying them again. So this
2414 * isn't as inefficient as it sounds.
2416 cx = &cxstack[cxix];
2418 if (cx->blk_gimme != G_VOID)
2419 leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2421 CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2425 cx = &cxstack[cxix]; /* CX stack may have been realloced */
2428 /* Like in the branch above, we need to handle any extra junk on
2429 * the stack. But because we're not also popping extra contexts, we
2430 * don't have to worry about prematurely freeing args. So we just
2431 * need to do the bare minimum to handle junk, and leave the main
2432 * arg processing in the function we tail call, e.g. pp_leavesub.
2433 * In list context we have to splice out the junk; in scalar
2434 * context we can leave as-is (pp_leavesub will later return the
2435 * top stack element). But for an empty arg list, e.g.
2436 * for (1,2) { return }
2437 * we need to set sp = oldsp so that pp_leavesub knows to push
2438 * &PL_sv_undef onto the stack.
2441 cx = &cxstack[cxix];
2442 oldsp = PL_stack_base + cx->blk_oldsp;
2443 if (oldsp != MARK) {
2444 SSize_t nargs = SP - MARK;
2446 if (cx->blk_gimme == G_ARRAY) {
2447 /* shift return args to base of call stack frame */
2448 Move(MARK + 1, oldsp + 1, nargs, SV*);
2449 PL_stack_sp = oldsp + nargs;
2453 PL_stack_sp = oldsp;
2457 /* fall through to a normal exit */
2458 switch (CxTYPE(cx)) {
2460 return CxTRYBLOCK(cx)
2461 ? Perl_pp_leavetry(aTHX)
2462 : Perl_pp_leaveeval(aTHX);
2464 return CvLVALUE(cx->blk_sub.cv)
2465 ? Perl_pp_leavesublv(aTHX)
2466 : Perl_pp_leavesub(aTHX);
2468 return Perl_pp_leavewrite(aTHX);
2470 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2474 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2476 static PERL_CONTEXT *
2480 if (PL_op->op_flags & OPf_SPECIAL) {
2481 cxix = dopoptoloop(cxstack_ix);
2483 /* diag_listed_as: Can't "last" outside a loop block */
2484 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2490 const char * const label =
2491 PL_op->op_flags & OPf_STACKED
2492 ? SvPV(TOPs,label_len)
2493 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2494 const U32 label_flags =
2495 PL_op->op_flags & OPf_STACKED
2497 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2499 cxix = dopoptolabel(label, label_len, label_flags);
2501 /* diag_listed_as: Label not found for "last %s" */
2502 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2504 SVfARG(PL_op->op_flags & OPf_STACKED
2505 && !SvGMAGICAL(TOPp1s)
2507 : newSVpvn_flags(label,
2509 label_flags | SVs_TEMP)));
2511 if (cxix < cxstack_ix)
2513 return &cxstack[cxix];
2522 cx = S_unwind_loop(aTHX);
2524 assert(CxTYPE_is_LOOP(cx));
2525 PL_stack_sp = PL_stack_base
2526 + (CxTYPE(cx) == CXt_LOOP_LIST
2527 ? cx->blk_loop.state_u.stack.basesp
2533 /* Stack values are safe: */
2535 cx_poploop(cx); /* release loop vars ... */
2537 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2547 /* if not a bare 'next' in the main scope, search for it */
2549 if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
2550 cx = S_unwind_loop(aTHX);
2553 PL_curcop = cx->blk_oldcop;
2555 return (cx)->blk_loop.my_op->op_nextop;
2560 PERL_CONTEXT *cx = S_unwind_loop(aTHX);
2561 OP* redo_op = cx->blk_loop.my_op->op_redoop;
2563 if (redo_op->op_type == OP_ENTER) {
2564 /* pop one less context to avoid $x being freed in while (my $x..) */
2567 assert(CxTYPE(cx) == CXt_BLOCK);
2568 redo_op = redo_op->op_next;
2574 PL_curcop = cx->blk_oldcop;
2580 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2583 static const char* const too_deep = "Target of goto is too deeply nested";
2585 PERL_ARGS_ASSERT_DOFINDLABEL;
2588 Perl_croak(aTHX_ "%s", too_deep);
2589 if (o->op_type == OP_LEAVE ||
2590 o->op_type == OP_SCOPE ||
2591 o->op_type == OP_LEAVELOOP ||
2592 o->op_type == OP_LEAVESUB ||
2593 o->op_type == OP_LEAVETRY)
2595 *ops++ = cUNOPo->op_first;
2597 Perl_croak(aTHX_ "%s", too_deep);
2600 if (o->op_flags & OPf_KIDS) {
2602 /* First try all the kids at this level, since that's likeliest. */
2603 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2604 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2605 STRLEN kid_label_len;
2606 U32 kid_label_flags;
2607 const char *kid_label = CopLABEL_len_flags(kCOP,
2608 &kid_label_len, &kid_label_flags);
2610 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2613 (const U8*)kid_label, kid_label_len,
2614 (const U8*)label, len) == 0)
2616 (const U8*)label, len,
2617 (const U8*)kid_label, kid_label_len) == 0)
2618 : ( len == kid_label_len && ((kid_label == label)
2619 || memEQ(kid_label, label, len)))))
2623 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2624 if (kid == PL_lastgotoprobe)
2626 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2629 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2630 ops[-1]->op_type == OP_DBSTATE)
2635 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2644 /* also used for: pp_dump() */
2652 #define GOTO_DEPTH 64
2653 OP *enterops[GOTO_DEPTH];
2654 const char *label = NULL;
2655 STRLEN label_len = 0;
2656 U32 label_flags = 0;
2657 const bool do_dump = (PL_op->op_type == OP_DUMP);
2658 static const char* const must_have_label = "goto must have label";
2660 if (PL_op->op_flags & OPf_STACKED) {
2661 /* goto EXPR or goto &foo */
2663 SV * const sv = POPs;
2666 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2667 /* This egregious kludge implements goto &subroutine */
2670 CV *cv = MUTABLE_CV(SvRV(sv));
2671 AV *arg = GvAV(PL_defgv);
2673 while (!CvROOT(cv) && !CvXSUB(cv)) {
2674 const GV * const gv = CvGV(cv);
2678 /* autoloaded stub? */
2679 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2681 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2683 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2684 if (autogv && (cv = GvCV(autogv)))
2686 tmpstr = sv_newmortal();
2687 gv_efullname3(tmpstr, gv, NULL);
2688 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2690 DIE(aTHX_ "Goto undefined subroutine");
2693 cxix = dopoptosub(cxstack_ix);
2695 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2697 cx = &cxstack[cxix];
2698 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2699 if (CxTYPE(cx) == CXt_EVAL) {
2701 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2702 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2704 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2705 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2707 else if (CxMULTICALL(cx))
2708 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2710 /* First do some returnish stuff. */
2712 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2714 if (cxix < cxstack_ix) {
2721 /* protect @_ during save stack unwind. */
2723 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
2725 assert(PL_scopestack_ix == cx->blk_oldscopesp);
2728 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2729 /* this is part of cx_popsub_args() */
2730 AV* av = MUTABLE_AV(PAD_SVl(0));
2731 assert(AvARRAY(MUTABLE_AV(
2732 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2733 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2735 /* we are going to donate the current @_ from the old sub
2736 * to the new sub. This first part of the donation puts a
2737 * new empty AV in the pad[0] slot of the old sub,
2738 * unless pad[0] and @_ differ (e.g. if the old sub did
2739 * local *_ = []); in which case clear the old pad[0]
2740 * array in the usual way */
2741 if (av == arg || AvREAL(av))
2742 clear_defarray(av, av == arg);
2743 else CLEAR_ARGARRAY(av);
2746 /* don't restore PL_comppad here. It won't be needed if the
2747 * sub we're going to is non-XS, but restoring it early then
2748 * croaking (e.g. the "Goto undefined subroutine" below)
2749 * means the CX block gets processed again in dounwind,
2750 * but this time with the wrong PL_comppad */
2752 /* A destructor called during LEAVE_SCOPE could have undefined
2753 * our precious cv. See bug #99850. */
2754 if (!CvROOT(cv) && !CvXSUB(cv)) {
2755 const GV * const gv = CvGV(cv);
2757 SV * const tmpstr = sv_newmortal();
2758 gv_efullname3(tmpstr, gv, NULL);
2759 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2762 DIE(aTHX_ "Goto undefined subroutine");
2765 if (CxTYPE(cx) == CXt_SUB) {
2766 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2767 SvREFCNT_dec_NN(cx->blk_sub.cv);
2770 /* Now do some callish stuff. */
2772 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2773 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2778 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2780 /* put GvAV(defgv) back onto stack */
2782 EXTEND(SP, items+1); /* @_ could have been extended. */
2787 bool r = cBOOL(AvREAL(arg));
2788 for (index=0; index<items; index++)
2792 SV ** const svp = av_fetch(arg, index, 0);
2793 sv = svp ? *svp : NULL;
2795 else sv = AvARRAY(arg)[index];
2797 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2798 : sv_2mortal(newSVavdefelem(arg, index, 1));
2802 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2803 /* Restore old @_ */
2804 CX_POP_SAVEARRAY(cx);
2807 retop = cx->blk_sub.retop;
2808 PL_comppad = cx->blk_sub.prevcomppad;
2809 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2811 /* XS subs don't have a CXt_SUB, so pop it;
2812 * this is a cx_popblock(), less all the stuff we already did
2813 * for cx_topblock() earlier */
2814 PL_curcop = cx->blk_oldcop;
2817 /* Push a mark for the start of arglist */
2820 (void)(*CvXSUB(cv))(aTHX_ cv);
2825 PADLIST * const padlist = CvPADLIST(cv);
2827 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2829 /* partial unrolled cx_pushsub(): */
2831 cx->blk_sub.cv = cv;
2832 cx->blk_sub.olddepth = CvDEPTH(cv);
2835 SvREFCNT_inc_simple_void_NN(cv);
2836 if (CvDEPTH(cv) > 1) {
2837 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2838 sub_crush_depth(cv);
2839 pad_push(padlist, CvDEPTH(cv));
2841 PL_curcop = cx->blk_oldcop;
2842 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2845 /* second half of donating @_ from the old sub to the
2846 * new sub: abandon the original pad[0] AV in the
2847 * new sub, and replace it with the donated @_.
2848 * pad[0] takes ownership of the extra refcount
2849 * we gave arg earlier */
2851 SvREFCNT_dec(PAD_SVl(0));
2852 PAD_SVl(0) = (SV *)arg;
2853 SvREFCNT_inc_simple_void_NN(arg);
2856 /* GvAV(PL_defgv) might have been modified on scope
2857 exit, so point it at arg again. */
2858 if (arg != GvAV(PL_defgv)) {
2859 AV * const av = GvAV(PL_defgv);
2860 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2865 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2866 Perl_get_db_sub(aTHX_ NULL, cv);
2868 CV * const gotocv = get_cvs("DB::goto", 0);
2870 PUSHMARK( PL_stack_sp );
2871 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2876 retop = CvSTART(cv);
2877 goto putback_return;
2882 label = SvPV_nomg_const(sv, label_len);
2883 label_flags = SvUTF8(sv);
2886 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2887 /* goto LABEL or dump LABEL */
2888 label = cPVOP->op_pv;
2889 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2890 label_len = strlen(label);
2892 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2897 OP *gotoprobe = NULL;
2898 bool leaving_eval = FALSE;
2899 bool in_block = FALSE;
2900 PERL_CONTEXT *last_eval_cx = NULL;
2904 PL_lastgotoprobe = NULL;
2906 for (ix = cxstack_ix; ix >= 0; ix--) {
2908 switch (CxTYPE(cx)) {
2910 leaving_eval = TRUE;
2911 if (!CxTRYBLOCK(cx)) {
2912 gotoprobe = (last_eval_cx ?
2913 last_eval_cx->blk_eval.old_eval_root :
2918 /* else fall through */
2919 case CXt_LOOP_PLAIN:
2920 case CXt_LOOP_LAZYIV:
2921 case CXt_LOOP_LAZYSV:
2926 gotoprobe = OpSIBLING(cx->blk_oldcop);
2932 gotoprobe = OpSIBLING(cx->blk_oldcop);
2935 gotoprobe = PL_main_root;
2938 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2939 gotoprobe = CvROOT(cx->blk_sub.cv);
2945 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2948 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
2949 CxTYPE(cx), (long) ix);
2950 gotoprobe = PL_main_root;
2956 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
2957 enterops, enterops + GOTO_DEPTH);
2960 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
2961 sibl1->op_type == OP_UNSTACK &&
2962 (sibl2 = OpSIBLING(sibl1)))
2964 retop = dofindlabel(sibl2,
2965 label, label_len, label_flags, enterops,
2966 enterops + GOTO_DEPTH);
2971 PL_lastgotoprobe = gotoprobe;
2974 DIE(aTHX_ "Can't find label %"UTF8f,
2975 UTF8fARG(label_flags, label_len, label));
2977 /* if we're leaving an eval, check before we pop any frames
2978 that we're not going to punt, otherwise the error
2981 if (leaving_eval && *enterops && enterops[1]) {
2983 for (i = 1; enterops[i]; i++)
2984 if (enterops[i]->op_type == OP_ENTERITER)
2985 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2988 if (*enterops && enterops[1]) {
2989 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2991 deprecate("\"goto\" to jump into a construct");
2994 /* pop unwanted frames */
2996 if (ix < cxstack_ix) {
2998 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3004 /* push wanted frames */
3006 if (*enterops && enterops[1]) {
3007 OP * const oldop = PL_op;
3008 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3009 for (; enterops[ix]; ix++) {
3010 PL_op = enterops[ix];
3011 /* Eventually we may want to stack the needed arguments
3012 * for each op. For now, we punt on the hard ones. */
3013 if (PL_op->op_type == OP_ENTERITER)
3014 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3015 PL_op->op_ppaddr(aTHX);
3023 if (!retop) retop = PL_main_start;
3025 PL_restartop = retop;
3026 PL_do_undump = TRUE;
3030 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3031 PL_do_undump = FALSE;
3049 anum = 0; (void)POPs;
3055 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3058 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3061 PL_exit_flags |= PERL_EXIT_EXPECTED;
3063 PUSHs(&PL_sv_undef);
3070 S_save_lines(pTHX_ AV *array, SV *sv)
3072 const char *s = SvPVX_const(sv);
3073 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3076 PERL_ARGS_ASSERT_SAVE_LINES;
3078 while (s && s < send) {
3080 SV * const tmpstr = newSV_type(SVt_PVMG);
3082 t = (const char *)memchr(s, '\n', send - s);
3088 sv_setpvn(tmpstr, s, t - s);
3089 av_store(array, line++, tmpstr);
3097 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3099 0 is used as continue inside eval,
3101 3 is used for a die caught by an inner eval - continue inner loop
3103 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3104 establish a local jmpenv to handle exception traps.
3109 S_docatch(pTHX_ OP *o)
3112 OP * const oldop = PL_op;
3116 assert(CATCH_GET == TRUE);
3123 assert(cxstack_ix >= 0);
3124 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3125 CX_CUR()->blk_eval.cur_top_env = PL_top_env;
3130 /* die caught by an inner eval - continue inner loop */
3131 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3132 PL_restartjmpenv = NULL;
3133 PL_op = PL_restartop;
3142 NOT_REACHED; /* NOTREACHED */
3151 =for apidoc find_runcv
3153 Locate the CV corresponding to the currently executing sub or eval.
3154 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3155 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3156 entered. (This allows debuggers to eval in the scope of the breakpoint
3157 rather than in the scope of the debugger itself.)
3163 Perl_find_runcv(pTHX_ U32 *db_seqp)
3165 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3168 /* If this becomes part of the API, it might need a better name. */
3170 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3177 PL_curcop == &PL_compiling
3179 : PL_curcop->cop_seq;
3181 for (si = PL_curstackinfo; si; si = si->si_prev) {
3183 for (ix = si->si_cxix; ix >= 0; ix--) {
3184 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3186 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3187 cv = cx->blk_sub.cv;
3188 /* skip DB:: code */
3189 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3190 *db_seqp = cx->blk_oldcop->cop_seq;
3193 if (cx->cx_type & CXp_SUB_RE)
3196 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3197 cv = cx->blk_eval.cv;
3200 case FIND_RUNCV_padid_eq:
3202 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3205 case FIND_RUNCV_level_eq:
3206 if (level++ != arg) continue;
3214 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3218 /* Run yyparse() in a setjmp wrapper. Returns:
3219 * 0: yyparse() successful
3220 * 1: yyparse() failed
3224 S_try_yyparse(pTHX_ int gramtype)
3229 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3233 ret = yyparse(gramtype) ? 1 : 0;
3240 NOT_REACHED; /* NOTREACHED */
3247 /* Compile a require/do or an eval ''.
3249 * outside is the lexically enclosing CV (if any) that invoked us.
3250 * seq is the current COP scope value.
3251 * hh is the saved hints hash, if any.
3253 * Returns a bool indicating whether the compile was successful; if so,
3254 * PL_eval_start contains the first op of the compiled code; otherwise,
3257 * This function is called from two places: pp_require and pp_entereval.
3258 * These can be distinguished by whether PL_op is entereval.
3262 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3265 OP * const saveop = PL_op;
3266 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3267 COP * const oldcurcop = PL_curcop;
3268 bool in_require = (saveop->op_type == OP_REQUIRE);
3272 PL_in_eval = (in_require
3273 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3275 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3276 ? EVAL_RE_REPARSING : 0)));
3280 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3282 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3283 CX_CUR()->blk_eval.cv = evalcv;
3284 CX_CUR()->blk_gimme = gimme;
3286 CvOUTSIDE_SEQ(evalcv) = seq;
3287 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3289 /* set up a scratch pad */
3291 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3292 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3295 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3297 /* make sure we compile in the right package */
3299 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3300 SAVEGENERICSV(PL_curstash);
3301 PL_curstash = (HV *)CopSTASH(PL_curcop);
3302 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3303 else SvREFCNT_inc_simple_void(PL_curstash);
3305 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3306 SAVESPTR(PL_beginav);
3307 PL_beginav = newAV();
3308 SAVEFREESV(PL_beginav);
3309 SAVESPTR(PL_unitcheckav);
3310 PL_unitcheckav = newAV();
3311 SAVEFREESV(PL_unitcheckav);
3314 ENTER_with_name("evalcomp");
3315 SAVESPTR(PL_compcv);
3318 /* try to compile it */
3320 PL_eval_root = NULL;
3321 PL_curcop = &PL_compiling;
3322 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3323 PL_in_eval |= EVAL_KEEPERR;
3330 hv_clear(GvHV(PL_hintgv));
3333 PL_hints = saveop->op_private & OPpEVAL_COPHH
3334 ? oldcurcop->cop_hints : saveop->op_targ;
3336 /* making 'use re eval' not be in scope when compiling the
3337 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3338 * infinite recursion when S_has_runtime_code() gives a false
3339 * positive: the second time round, HINT_RE_EVAL isn't set so we
3340 * don't bother calling S_has_runtime_code() */
3341 if (PL_in_eval & EVAL_RE_REPARSING)
3342 PL_hints &= ~HINT_RE_EVAL;
3345 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3346 SvREFCNT_dec(GvHV(PL_hintgv));
3347 GvHV(PL_hintgv) = hh;
3350 SAVECOMPILEWARNINGS();
3352 if (PL_dowarn & G_WARN_ALL_ON)
3353 PL_compiling.cop_warnings = pWARN_ALL ;
3354 else if (PL_dowarn & G_WARN_ALL_OFF)
3355 PL_compiling.cop_warnings = pWARN_NONE ;
3357 PL_compiling.cop_warnings = pWARN_STD ;
3360 PL_compiling.cop_warnings =
3361 DUP_WARNINGS(oldcurcop->cop_warnings);
3362 cophh_free(CopHINTHASH_get(&PL_compiling));
3363 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3364 /* The label, if present, is the first entry on the chain. So rather
3365 than writing a blank label in front of it (which involves an
3366 allocation), just use the next entry in the chain. */
3367 PL_compiling.cop_hints_hash
3368 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3369 /* Check the assumption that this removed the label. */
3370 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3373 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3376 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3378 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3379 * so honour CATCH_GET and trap it here if necessary */
3382 /* compile the code */
3383 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3385 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3386 SV *namesv = NULL; /* initialise to avoid compiler warning */
3391 /* note that if yystatus == 3, then the require/eval died during
3392 * compilation, so the EVAL CX block has already been popped, and
3393 * various vars restored */
3394 if (yystatus != 3) {
3396 op_free(PL_eval_root);
3397 PL_eval_root = NULL;
3399 SP = PL_stack_base + POPMARK; /* pop original mark */
3405 namesv = cx->blk_eval.old_namesv;
3411 if (yystatus == 3) {
3413 assert(CxTYPE(cx) == CXt_EVAL);
3414 namesv = cx->blk_eval.old_namesv;
3416 S_undo_inc_then_croak(aTHX_ namesv, errsv, FALSE);
3417 NOT_REACHED; /* NOTREACHED */
3420 if (!*(SvPV_nolen_const(errsv)))
3421 sv_setpvs(errsv, "Compilation error");
3423 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3428 /* Compilation successful. Now clean up */
3430 LEAVE_with_name("evalcomp");
3432 CopLINE_set(&PL_compiling, 0);
3433 SAVEFREEOP(PL_eval_root);
3434 cv_forget_slab(evalcv);
3436 DEBUG_x(dump_eval());
3438 /* Register with debugger: */
3439 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3440 CV * const cv = get_cvs("DB::postponed", 0);
3444 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3446 call_sv(MUTABLE_SV(cv), G_DISCARD);
3450 if (PL_unitcheckav) {
3451 OP *es = PL_eval_start;
3452 call_list(PL_scopestack_ix, PL_unitcheckav);
3456 CvDEPTH(evalcv) = 1;
3457 SP = PL_stack_base + POPMARK; /* pop original mark */
3458 PL_op = saveop; /* The caller may need it. */
3459 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3467 S_check_type_and_open(pTHX_ SV *name)
3472 const char *p = SvPV_const(name, len);
3475 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3477 /* checking here captures a reasonable error message when
3478 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3479 * user gets a confusing message about looking for the .pmc file
3480 * rather than for the .pm file so do the check in S_doopen_pm when
3481 * PMC is on instead of here. S_doopen_pm calls this func.
3482 * This check prevents a \0 in @INC causing problems.
3484 #ifdef PERL_DISABLE_PMC
3485 if (!IS_SAFE_PATHNAME(p, len, "require"))
3489 /* on Win32 stat is expensive (it does an open() and close() twice and
3490 a couple other IO calls), the open will fail with a dir on its own with
3491 errno EACCES, so only do a stat to separate a dir from a real EACCES
3492 caused by user perms */
3494 /* we use the value of errno later to see how stat() or open() failed.
3495 * We don't want it set if the stat succeeded but we still failed,
3496 * such as if the name exists, but is a directory */
3499 st_rc = PerlLIO_stat(p, &st);
3501 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3506 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3508 /* EACCES stops the INC search early in pp_require to implement
3509 feature RT #113422 */
3510 if(!retio && errno == EACCES) { /* exists but probably a directory */
3512 st_rc = PerlLIO_stat(p, &st);
3514 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3525 #ifndef PERL_DISABLE_PMC
3527 S_doopen_pm(pTHX_ SV *name)
3530 const char *p = SvPV_const(name, namelen);
3532 PERL_ARGS_ASSERT_DOOPEN_PM;
3534 /* check the name before trying for the .pmc name to avoid the
3535 * warning referring to the .pmc which the user probably doesn't
3536 * know or care about
3538 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3541 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3542 SV *const pmcsv = sv_newmortal();
3545 SvSetSV_nosteal(pmcsv,name);
3546 sv_catpvs(pmcsv, "c");
3548 pmcio = check_type_and_open(pmcsv);
3552 return check_type_and_open(name);
3555 # define doopen_pm(name) check_type_and_open(name)
3556 #endif /* !PERL_DISABLE_PMC */
3558 /* require doesn't search for absolute names, or when the name is
3559 explicitly relative the current directory */
3560 PERL_STATIC_INLINE bool
3561 S_path_is_searchable(const char *name)
3563 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3565 if (PERL_FILE_IS_ABSOLUTE(name)
3567 || (*name == '.' && ((name[1] == '/' ||
3568 (name[1] == '.' && name[2] == '/'))
3569 || (name[1] == '\\' ||
3570 ( name[1] == '.' && name[2] == '\\')))
3573 || (*name == '.' && (name[1] == '/' ||
3574 (name[1] == '.' && name[2] == '/')))
3585 /* implement 'require 5.010001' */
3588 S_require_version(pTHX_ SV *sv)
3592 sv = sv_2mortal(new_version(sv));
3593 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3594 upg_version(PL_patchlevel, TRUE);
3595 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3596 if ( vcmp(sv,PL_patchlevel) <= 0 )
3597 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3598 SVfARG(sv_2mortal(vnormal(sv))),
3599 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3603 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3606 SV * const req = SvRV(sv);
3607 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3609 /* get the left hand term */
3610 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3612 first = SvIV(*av_fetch(lav,0,0));
3613 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3614 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3615 || av_tindex(lav) > 1 /* FP with > 3 digits */
3616 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3618 DIE(aTHX_ "Perl %"SVf" required--this is only "
3620 SVfARG(sv_2mortal(vnormal(req))),
3621 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3624 else { /* probably 'use 5.10' or 'use 5.8' */
3628 if (av_tindex(lav)>=1)
3629 second = SvIV(*av_fetch(lav,1,0));
3631 second /= second >= 600 ? 100 : 10;
3632 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3633 (int)first, (int)second);
3634 upg_version(hintsv, TRUE);
3636 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3637 "--this is only %"SVf", stopped",
3638 SVfARG(sv_2mortal(vnormal(req))),
3639 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3640 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3649 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
3650 * The first form will have already been converted at compile time to
3651 * the second form */
3654 S_require_file(pTHX_ SV *const sv)
3664 int vms_unixname = 0;
3667 const char *tryname = NULL;
3669 const U8 gimme = GIMME_V;
3670 int filter_has_file = 0;
3671 PerlIO *tryrsfp = NULL;
3672 SV *filter_cache = NULL;
3673 SV *filter_state = NULL;
3674 SV *filter_sub = NULL;
3678 bool path_searchable;
3679 I32 old_savestack_ix;
3682 DIE(aTHX_ "Missing or undefined argument to require");
3683 name = SvPV_nomg_const(sv, len);
3684 if (!(name && len > 0 && *name))
3685 DIE(aTHX_ "Missing or undefined argument to require");
3687 if (!IS_SAFE_PATHNAME(name, len, "require")) {
3688 DIE(aTHX_ "Can't locate %s: %s",
3689 pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
3690 NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3693 TAINT_PROPER("require");
3695 path_searchable = path_is_searchable(name);
3698 /* The key in the %ENV hash is in the syntax of file passed as the argument
3699 * usually this is in UNIX format, but sometimes in VMS format, which
3700 * can result in a module being pulled in more than once.
3701 * To prevent this, the key must be stored in UNIX format if the VMS
3702 * name can be translated to UNIX.
3706 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3708 unixlen = strlen(unixname);
3714 /* if not VMS or VMS name can not be translated to UNIX, pass it
3717 unixname = (char *) name;
3720 if (PL_op->op_type == OP_REQUIRE) {
3721 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3722 unixname, unixlen, 0);
3724 if (*svp != &PL_sv_undef)
3727 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3728 "Compilation failed in require", unixname);
3731 if (PL_op->op_flags & OPf_KIDS) {
3732 SVOP * const kid = (SVOP*)cUNOP->op_first;
3734 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3735 /* require foo (or use foo) with a bareword.
3736 Perl_load_module fakes up the identical optree, but its
3737 arguments aren't restricted by the parser to real barewords.
3739 const STRLEN package_len = len - 3;
3740 const char slashdot[2] = {'/', '.'};
3742 const char backslashdot[2] = {'\\', '.'};
3745 /* Disallow *purported* barewords that map to absolute
3746 filenames, filenames relative to the current or parent
3747 directory, or (*nix) hidden filenames. Also sanity check
3748 that the generated filename ends .pm */
3749 if (!path_searchable || len < 3 || name[0] == '.'
3750 || !memEQ(name + package_len, ".pm", 3))
3751 DIE(aTHX_ "Bareword in require maps to disallowed filename \"%"SVf"\"", sv);
3752 if (memchr(name, 0, package_len)) {
3753 /* diag_listed_as: Bareword in require contains "%s" */
3754 DIE(aTHX_ "Bareword in require contains \"\\0\"");
3756 if (ninstr(name, name + package_len, slashdot,
3757 slashdot + sizeof(slashdot))) {
3758 /* diag_listed_as: Bareword in require contains "%s" */
3759 DIE(aTHX_ "Bareword in require contains \"/.\"");
3762 if (ninstr(name, name + package_len, backslashdot,
3763 backslashdot + sizeof(backslashdot))) {
3764 /* diag_listed_as: Bareword in require contains "%s" */
3765 DIE(aTHX_ "Bareword in require contains \"\\.\"");
3772 PERL_DTRACE_PROBE_FILE_LOADING(unixname);
3774 /* prepare to compile file */
3776 if (!path_searchable) {
3777 /* At this point, name is SvPVX(sv) */
3779 tryrsfp = doopen_pm(sv);
3781 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3782 AV * const ar = GvAVn(PL_incgv);
3789 namesv = newSV_type(SVt_PV);
3790 for (i = 0; i <= AvFILL(ar); i++) {
3791 SV * const dirsv = *av_fetch(ar, i, TRUE);
3799 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3800 && !SvOBJECT(SvRV(loader)))
3802 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3806 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3807 PTR2UV(SvRV(dirsv)), name);
3808 tryname = SvPVX_const(namesv);
3811 if (SvPADTMP(nsv)) {
3812 nsv = sv_newmortal();
3813 SvSetSV_nosteal(nsv,sv);
3816 ENTER_with_name("call_INC");
3824 if (SvGMAGICAL(loader)) {
3825 SV *l = sv_newmortal();
3826 sv_setsv_nomg(l, loader);
3829 if (sv_isobject(loader))
3830 count = call_method("INC", G_ARRAY);
3832 count = call_sv(loader, G_ARRAY);
3842 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3843 && !isGV_with_GP(SvRV(arg))) {
3844 filter_cache = SvRV(arg);
3851 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3855 if (isGV_with_GP(arg)) {
3856 IO * const io = GvIO((const GV *)arg);
3861 tryrsfp = IoIFP(io);
3862 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3863 PerlIO_close(IoOFP(io));
3874 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3876 SvREFCNT_inc_simple_void_NN(filter_sub);
3879 filter_state = SP[i];
3880 SvREFCNT_inc_simple_void(filter_state);
3884 if (!tryrsfp && (filter_cache || filter_sub)) {
3885 tryrsfp = PerlIO_open(BIT_BUCKET,
3891 /* FREETMPS may free our filter_cache */
3892 SvREFCNT_inc_simple_void(filter_cache);
3896 LEAVE_with_name("call_INC");
3898 /* Now re-mortalize it. */
3899 sv_2mortal(filter_cache);
3901 /* Adjust file name if the hook has set an %INC entry.
3902 This needs to happen after the FREETMPS above. */
3903 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3905 tryname = SvPV_nolen_const(*svp);
3912 filter_has_file = 0;
3913 filter_cache = NULL;
3915 SvREFCNT_dec_NN(filter_state);
3916 filter_state = NULL;
3919 SvREFCNT_dec_NN(filter_sub);
3924 if (path_searchable) {
3929 dir = SvPV_nomg_const(dirsv, dirlen);
3935 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3939 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3942 sv_setpv(namesv, unixdir);
3943 sv_catpv(namesv, unixname);
3945 # ifdef __SYMBIAN32__
3946 if (PL_origfilename[0] &&
3947 PL_origfilename[1] == ':' &&
3948 !(dir[0] && dir[1] == ':'))
3949 Perl_sv_setpvf(aTHX_ namesv,
3954 Perl_sv_setpvf(aTHX_ namesv,
3958 /* The equivalent of
3959 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3960 but without the need to parse the format string, or
3961 call strlen on either pointer, and with the correct
3962 allocation up front. */
3964 char *tmp = SvGROW(namesv, dirlen + len + 2);
3966 memcpy(tmp, dir, dirlen);
3969 /* Avoid '<dir>//<file>' */
3970 if (!dirlen || *(tmp-1) != '/') {
3973 /* So SvCUR_set reports the correct length below */
3977 /* name came from an SV, so it will have a '\0' at the
3978 end that we can copy as part of this memcpy(). */
3979 memcpy(tmp, name, len + 1);
3981 SvCUR_set(namesv, dirlen + len + 1);
3986 TAINT_PROPER("require");
3987 tryname = SvPVX_const(namesv);
3988 tryrsfp = doopen_pm(namesv);
3990 if (tryname[0] == '.' && tryname[1] == '/') {
3992 while (*++tryname == '/') {}
3996 else if (errno == EMFILE || errno == EACCES) {
3997 /* no point in trying other paths if out of handles;
3998 * on the other hand, if we couldn't open one of the
3999 * files, then going on with the search could lead to
4000 * unexpected results; see perl #113422
4009 saved_errno = errno; /* sv_2mortal can realloc things */
4012 if (PL_op->op_type == OP_REQUIRE) {
4013 if(saved_errno == EMFILE || saved_errno == EACCES) {
4014 /* diag_listed_as: Can't locate %s */
4015 DIE(aTHX_ "Can't locate %s: %s: %s",
4016 name, tryname, Strerror(saved_errno));
4018 if (namesv) { /* did we lookup @INC? */
4019 AV * const ar = GvAVn(PL_incgv);
4021 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4022 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4023 for (i = 0; i <= AvFILL(ar); i++) {
4024 sv_catpvs(inc, " ");
4025 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4027 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4028 const char *c, *e = name + len - 3;
4029 sv_catpv(msg, " (you may need to install the ");
4030 for (c = name; c < e; c++) {
4032 sv_catpvs(msg, "::");
4035 sv_catpvn(msg, c, 1);
4038 sv_catpv(msg, " module)");
4040 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4041 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4043 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4044 sv_catpv(msg, " (did you run h2ph?)");
4047 /* diag_listed_as: Can't locate %s */
4049 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4053 DIE(aTHX_ "Can't locate %s", name);
4060 SETERRNO(0, SS_NORMAL);
4062 /* Assume success here to prevent recursive requirement. */
4063 /* name is never assigned to again, so len is still strlen(name) */
4064 /* Check whether a hook in @INC has already filled %INC */
4066 (void)hv_store(GvHVn(PL_incgv),
4067 unixname, unixlen, newSVpv(tryname,0),0);
4069 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4071 (void)hv_store(GvHVn(PL_incgv),
4072 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4075 old_savestack_ix = PL_savestack_ix;
4076 SAVECOPFILE_FREE(&PL_compiling);
4077 CopFILE_set(&PL_compiling, tryname);
4078 lex_start(NULL, tryrsfp, 0);
4080 if (filter_sub || filter_cache) {
4081 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4082 than hanging another SV from it. In turn, filter_add() optionally
4083 takes the SV to use as the filter (or creates a new SV if passed
4084 NULL), so simply pass in whatever value filter_cache has. */
4085 SV * const fc = filter_cache ? newSV(0) : NULL;
4087 if (fc) sv_copypv(fc, filter_cache);
4088 datasv = filter_add(S_run_user_filter, fc);
4089 IoLINES(datasv) = filter_has_file;
4090 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4091 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4094 /* switch to eval mode */
4095 cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4096 cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4098 SAVECOPLINE(&PL_compiling);
4099 CopLINE_set(&PL_compiling, 0);
4103 if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4104 op = DOCATCH(PL_eval_start);
4106 op = PL_op->op_next;
4108 PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4114 /* also used for: pp_dofile() */
4122 return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4123 ? S_require_version(aTHX_ sv)
4124 : S_require_file(aTHX_ sv);
4128 /* This is a op added to hold the hints hash for
4129 pp_entereval. The hash can be modified by the code
4130 being eval'ed, so we return a copy instead. */
4135 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4145 const U8 gimme = GIMME_V;
4146 const U32 was = PL_breakable_sub_gen;
4147 char tbuf[TYPE_DIGITS(long) + 12];
4148 bool saved_delete = FALSE;
4149 char *tmpbuf = tbuf;
4152 U32 seq, lex_flags = 0;
4153 HV *saved_hh = NULL;
4154 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4155 I32 old_savestack_ix;
4157 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4158 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4160 else if (PL_hints & HINT_LOCALIZE_HH || (
4161 PL_op->op_private & OPpEVAL_COPHH
4162 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4164 saved_hh = cop_hints_2hv(PL_curcop, 0);
4165 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4169 /* make sure we've got a plain PV (no overload etc) before testing
4170 * for taint. Making a copy here is probably overkill, but better
4171 * safe than sorry */
4173 const char * const p = SvPV_const(sv, len);
4175 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4176 lex_flags |= LEX_START_COPIED;
4178 if (bytes && SvUTF8(sv))
4179 SvPVbyte_force(sv, len);
4181 else if (bytes && SvUTF8(sv)) {
4182 /* Don't modify someone else's scalar */
4185 (void)sv_2mortal(sv);
4186 SvPVbyte_force(sv,len);
4187 lex_flags |= LEX_START_COPIED;
4190 TAINT_IF(SvTAINTED(sv));
4191 TAINT_PROPER("eval");
4193 old_savestack_ix = PL_savestack_ix;
4195 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4196 ? LEX_IGNORE_UTF8_HINTS
4197 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4201 /* switch to eval mode */
4203 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4204 SV * const temp_sv = sv_newmortal();
4205 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4206 (unsigned long)++PL_evalseq,
4207 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4208 tmpbuf = SvPVX(temp_sv);
4209 len = SvCUR(temp_sv);
4212 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4213 SAVECOPFILE_FREE(&PL_compiling);
4214 CopFILE_set(&PL_compiling, tmpbuf+2);
4215 SAVECOPLINE(&PL_compiling);
4216 CopLINE_set(&PL_compiling, 1);
4217 /* special case: an eval '' executed within the DB package gets lexically
4218 * placed in the first non-DB CV rather than the current CV - this
4219 * allows the debugger to execute code, find lexicals etc, in the
4220 * scope of the code being debugged. Passing &seq gets find_runcv
4221 * to do the dirty work for us */
4222 runcv = find_runcv(&seq);
4224 cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
4225 cx_pusheval(cx, PL_op->op_next, NULL);
4227 /* prepare to compile string */
4229 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4230 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4232 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4233 deleting the eval's FILEGV from the stash before gv_check() runs
4234 (i.e. before run-time proper). To work around the coredump that
4235 ensues, we always turn GvMULTI_on for any globals that were
4236 introduced within evals. See force_ident(). GSAR 96-10-12 */
4237 char *const safestr = savepvn(tmpbuf, len);
4238 SAVEDELETE(PL_defstash, safestr, len);
4239 saved_delete = TRUE;
4244 if (doeval_compile(gimme, runcv, seq, saved_hh)) {
4245 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4246 ? PERLDB_LINE_OR_SAVESRC
4247 : PERLDB_SAVESRC_NOSUBS) {
4248 /* Retain the filegv we created. */
4249 } else if (!saved_delete) {
4250 char *const safestr = savepvn(tmpbuf, len);
4251 SAVEDELETE(PL_defstash, safestr, len);
4253 return DOCATCH(PL_eval_start);
4255 /* We have already left the scope set up earlier thanks to the LEAVE
4256 in doeval_compile(). */
4257 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4258 ? PERLDB_LINE_OR_SAVESRC
4259 : PERLDB_SAVESRC_INVALID) {
4260 /* Retain the filegv we created. */
4261 } else if (!saved_delete) {
4262 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4264 return PL_op->op_next;
4269 /* also tail-called by pp_return */
4279 /* grab this value before cx_popeval restores old PL_in_eval */
4280 bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4285 assert(CxTYPE(cx) == CXt_EVAL);
4287 oldsp = PL_stack_base + cx->blk_oldsp;
4288 gimme = cx->blk_gimme;
4290 /* did require return a false value? */
4291 if ( CxOLD_OP_TYPE(cx) == OP_REQUIRE
4292 && !(gimme == G_SCALAR
4293 ? SvTRUE(*PL_stack_sp)
4294 : PL_stack_sp > oldsp)
4296 namesv = cx->blk_eval.old_namesv;
4298 if (gimme == G_VOID)
4299 PL_stack_sp = oldsp;
4301 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4303 /* the cx_popeval does a leavescope, which frees the optree associated
4304 * with eval, which if it frees the nextstate associated with
4305 * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
4306 * regex when running under 'use re Debug' because it needs PL_curcop
4307 * to get the current hints. So restore it early.
4309 PL_curcop = cx->blk_oldcop;
4314 retop = cx->blk_eval.retop;
4315 evalcv = cx->blk_eval.cv;
4319 assert(CvDEPTH(evalcv) == 1);
4321 CvDEPTH(evalcv) = 0;
4323 if (namesv) { /* require returned false */
4324 /* Unassume the success we assumed earlier. */
4325 S_undo_inc_then_croak(aTHX_ namesv, NULL, TRUE);
4326 NOT_REACHED; /* NOTREACHED */
4335 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4336 close to the related Perl_create_eval_scope. */
4338 Perl_delete_eval_scope(pTHX)
4349 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4350 also needed by Perl_fold_constants. */
4352 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
4355 const U8 gimme = GIMME_V;
4357 cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
4358 PL_stack_sp, PL_savestack_ix);
4359 cx_pusheval(cx, retop, NULL);
4361 PL_in_eval = EVAL_INEVAL;
4362 if (flags & G_KEEPERR)
4363 PL_in_eval |= EVAL_KEEPERR;
4366 if (flags & G_FAKINGEVAL) {
4367 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4373 create_eval_scope(cLOGOP->op_other->op_next, 0);
4374 return DOCATCH(PL_op->op_next);
4378 /* also tail-called by pp_return */
4390 assert(CxTYPE(cx) == CXt_EVAL);
4391 oldsp = PL_stack_base + cx->blk_oldsp;
4392 gimme = cx->blk_gimme;
4394 if (gimme == G_VOID)
4395 PL_stack_sp = oldsp;
4397 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4401 retop = cx->blk_eval.retop;
4412 const U8 gimme = GIMME_V;
4416 assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4417 GvSV(PL_defgv) = SvREFCNT_inc(newsv);
4419 cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
4420 cx_pushgiven(cx, origsv);
4430 PERL_UNUSED_CONTEXT;
4433 assert(CxTYPE(cx) == CXt_GIVEN);
4434 oldsp = PL_stack_base + cx->blk_oldsp;
4435 gimme = cx->blk_gimme;
4437 if (gimme == G_VOID)
4438 PL_stack_sp = oldsp;
4440 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4450 /* Helper routines used by pp_smartmatch */
4452 S_make_matcher(pTHX_ REGEXP *re)
4454 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4456 PERL_ARGS_ASSERT_MAKE_MATCHER;
4458 PM_SETRE(matcher, ReREFCNT_inc(re));
4460 SAVEFREEOP((OP *) matcher);
4461 ENTER_with_name("matcher"); SAVETMPS;
4467 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4472 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4474 PL_op = (OP *) matcher;
4477 (void) Perl_pp_match(aTHX);
4479 result = SvTRUEx(POPs);
4486 S_destroy_matcher(pTHX_ PMOP *matcher)
4488 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4489 PERL_UNUSED_ARG(matcher);
4492 LEAVE_with_name("matcher");
4495 /* Do a smart match */
4498 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4499 return do_smartmatch(NULL, NULL, 0);
4502 /* This version of do_smartmatch() implements the
4503 * table of smart matches that is found in perlsyn.
4506 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4510 bool object_on_left = FALSE;
4511 SV *e = TOPs; /* e is for 'expression' */
4512 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4514 /* Take care only to invoke mg_get() once for each argument.
4515 * Currently we do this by copying the SV if it's magical. */
4517 if (!copied && SvGMAGICAL(d))
4518 d = sv_mortalcopy(d);
4525 e = sv_mortalcopy(e);
4527 /* First of all, handle overload magic of the rightmost argument */
4530 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4531 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4533 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4540 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4543 SP -= 2; /* Pop the values */
4548 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4555 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4556 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4557 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4559 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4560 object_on_left = TRUE;
4563 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4565 if (object_on_left) {
4566 goto sm_any_sub; /* Treat objects like scalars */
4568 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4569 /* Test sub truth for each key */
4571 bool andedresults = TRUE;
4572 HV *hv = (HV*) SvRV(d);
4573 I32 numkeys = hv_iterinit(hv);
4574 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4577 while ( (he = hv_iternext(hv)) ) {
4578 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4579 ENTER_with_name("smartmatch_hash_key_test");
4582 PUSHs(hv_iterkeysv(he));
4584 c = call_sv(e, G_SCALAR);
4587 andedresults = FALSE;
4589 andedresults = SvTRUEx(POPs) && andedresults;
4591 LEAVE_with_name("smartmatch_hash_key_test");
4598 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4599 /* Test sub truth for each element */
4601 bool andedresults = TRUE;
4602 AV *av = (AV*) SvRV(d);
4603 const I32 len = av_tindex(av);
4604 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4607 for (i = 0; i <= len; ++i) {
4608 SV * const * const svp = av_fetch(av, i, FALSE);
4609 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4610 ENTER_with_name("smartmatch_array_elem_test");
4616 c = call_sv(e, G_SCALAR);
4619 andedresults = FALSE;
4621 andedresults = SvTRUEx(POPs) && andedresults;
4623 LEAVE_with_name("smartmatch_array_elem_test");
4632 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4633 ENTER_with_name("smartmatch_coderef");
4638 c = call_sv(e, G_SCALAR);
4642 else if (SvTEMP(TOPs))
4643 SvREFCNT_inc_void(TOPs);
4645 LEAVE_with_name("smartmatch_coderef");
4650 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4651 if (object_on_left) {
4652 goto sm_any_hash; /* Treat objects like scalars */
4654 else if (!SvOK(d)) {
4655 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4658 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4659 /* Check that the key-sets are identical */
4661 HV *other_hv = MUTABLE_HV(SvRV(d));
4664 U32 this_key_count = 0,
4665 other_key_count = 0;
4666 HV *hv = MUTABLE_HV(SvRV(e));
4668 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4669 /* Tied hashes don't know how many keys they have. */
4670 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4671 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4675 HV * const temp = other_hv;
4681 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4685 /* The hashes have the same number of keys, so it suffices
4686 to check that one is a subset of the other. */
4687 (void) hv_iterinit(hv);
4688 while ( (he = hv_iternext(hv)) ) {
4689 SV *key = hv_iterkeysv(he);
4691 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4694 if(!hv_exists_ent(other_hv, key, 0)) {
4695 (void) hv_iterinit(hv); /* reset iterator */
4701 (void) hv_iterinit(other_hv);
4702 while ( hv_iternext(other_hv) )
4706 other_key_count = HvUSEDKEYS(other_hv);
4708 if (this_key_count != other_key_count)
4713 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4714 AV * const other_av = MUTABLE_AV(SvRV(d));
4715 const SSize_t other_len = av_tindex(other_av) + 1;
4717 HV *hv = MUTABLE_HV(SvRV(e));
4719 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4720 for (i = 0; i < other_len; ++i) {
4721 SV ** const svp = av_fetch(other_av, i, FALSE);
4722 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4723 if (svp) { /* ??? When can this not happen? */
4724 if (hv_exists_ent(hv, *svp, 0))
4730 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4731 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4734 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4736 HV *hv = MUTABLE_HV(SvRV(e));
4738 (void) hv_iterinit(hv);
4739 while ( (he = hv_iternext(hv)) ) {
4740 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4742 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4744 (void) hv_iterinit(hv);
4745 destroy_matcher(matcher);
4750 destroy_matcher(matcher);
4756 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4757 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4764 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4765 if (object_on_left) {
4766 goto sm_any_array; /* Treat objects like scalars */
4768 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4769 AV * const other_av = MUTABLE_AV(SvRV(e));
4770 const SSize_t other_len = av_tindex(other_av) + 1;
4773 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4774 for (i = 0; i < other_len; ++i) {
4775 SV ** const svp = av_fetch(other_av, i, FALSE);
4777 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4778 if (svp) { /* ??? When can this not happen? */
4779 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4785 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4786 AV *other_av = MUTABLE_AV(SvRV(d));
4787 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4788 if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4792 const SSize_t other_len = av_tindex(other_av);
4794 if (NULL == seen_this) {
4795 seen_this = newHV();
4796 (void) sv_2mortal(MUTABLE_SV(seen_this));
4798 if (NULL == seen_other) {
4799 seen_other = newHV();
4800 (void) sv_2mortal(MUTABLE_SV(seen_other));
4802 for(i = 0; i <= other_len; ++i) {
4803 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4804 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4806 if (!this_elem || !other_elem) {
4807 if ((this_elem && SvOK(*this_elem))
4808 || (other_elem && SvOK(*other_elem)))
4811 else if (hv_exists_ent(seen_this,
4812 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4813 hv_exists_ent(seen_other,
4814 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4816 if (*this_elem != *other_elem)
4820 (void)hv_store_ent(seen_this,
4821 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4823 (void)hv_store_ent(seen_other,
4824 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4830 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4831 (void) do_smartmatch(seen_this, seen_other, 0);
4833 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4842 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4843 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4846 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4847 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4850 for(i = 0; i <= this_len; ++i) {
4851 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4852 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4854 if (svp && matcher_matches_sv(matcher, *svp)) {
4856 destroy_matcher(matcher);
4861 destroy_matcher(matcher);
4865 else if (!SvOK(d)) {
4866 /* undef ~~ array */
4867 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4870 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4871 for (i = 0; i <= this_len; ++i) {
4872 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4873 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4874 if (!svp || !SvOK(*svp))
4883 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4885 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4886 for (i = 0; i <= this_len; ++i) {
4887 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4894 /* infinite recursion isn't supposed to happen here */
4895 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4896 (void) do_smartmatch(NULL, NULL, 1);
4898 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4907 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4908 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4909 SV *t = d; d = e; e = t;
4910 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4913 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4914 SV *t = d; d = e; e = t;
4915 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4916 goto sm_regex_array;
4919 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4922 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4924 result = matcher_matches_sv(matcher, d);
4926 PUSHs(result ? &PL_sv_yes : &PL_sv_no);
4927 destroy_matcher(matcher);
4932 /* See if there is overload magic on left */
4933 else if (object_on_left && SvAMAGIC(d)) {
4935 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4936 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4939 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4947 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4950 else if (!SvOK(d)) {
4951 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4952 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4957 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4958 DEBUG_M(if (SvNIOK(e))
4959 Perl_deb(aTHX_ " applying rule Any-Num\n");
4961 Perl_deb(aTHX_ " applying rule Num-numish\n");
4963 /* numeric comparison */
4966 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4967 (void) Perl_pp_i_eq(aTHX);
4969 (void) Perl_pp_eq(aTHX);
4977 /* As a last resort, use string comparison */
4978 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4981 return Perl_pp_seq(aTHX);
4988 const U8 gimme = GIMME_V;
4990 /* This is essentially an optimization: if the match
4991 fails, we don't want to push a context and then
4992 pop it again right away, so we skip straight
4993 to the op that follows the leavewhen.
4994 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4996 if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs))
4997 RETURNOP(cLOGOP->op_other->op_next);
4999 cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
5013 assert(CxTYPE(cx) == CXt_WHEN);
5014 gimme = cx->blk_gimme;
5016 cxix = dopoptogivenfor(cxstack_ix);
5018 /* diag_listed_as: Can't "when" outside a topicalizer */
5019 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5020 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5022 oldsp = PL_stack_base + cx->blk_oldsp;
5023 if (gimme == G_VOID)
5024 PL_stack_sp = oldsp;
5026 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5028 /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
5029 assert(cxix < cxstack_ix);
5032 cx = &cxstack[cxix];
5034 if (CxFOREACH(cx)) {
5035 /* emulate pp_next. Note that any stack(s) cleanup will be
5036 * done by the pp_unstack which op_nextop should point to */
5039 PL_curcop = cx->blk_oldcop;
5040 return cx->blk_loop.my_op->op_nextop;
5044 assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
5045 return cx->blk_givwhen.leave_op;
5055 cxix = dopoptowhen(cxstack_ix);
5057 DIE(aTHX_ "Can't \"continue\" outside a when block");
5059 if (cxix < cxstack_ix)
5063 assert(CxTYPE(cx) == CXt_WHEN);
5064 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5068 nextop = cx->blk_givwhen.leave_op->op_next;
5079 cxix = dopoptogivenfor(cxstack_ix);
5081 DIE(aTHX_ "Can't \"break\" outside a given block");
5083 cx = &cxstack[cxix];
5085 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5087 if (cxix < cxstack_ix)
5090 /* Restore the sp at the time we entered the given block */
5092 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5094 return cx->blk_givwhen.leave_op;
5098 S_doparseform(pTHX_ SV *sv)
5101 char *s = SvPV(sv, len);
5103 char *base = NULL; /* start of current field */
5104 I32 skipspaces = 0; /* number of contiguous spaces seen */
5105 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5106 bool repeat = FALSE; /* ~~ seen on this line */
5107 bool postspace = FALSE; /* a text field may need right padding */
5110 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5112 bool ischop; /* it's a ^ rather than a @ */
5113 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5114 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5118 PERL_ARGS_ASSERT_DOPARSEFORM;
5121 Perl_croak(aTHX_ "Null picture in formline");
5123 if (SvTYPE(sv) >= SVt_PVMG) {
5124 /* This might, of course, still return NULL. */
5125 mg = mg_find(sv, PERL_MAGIC_fm);
5127 sv_upgrade(sv, SVt_PVMG);
5131 /* still the same as previously-compiled string? */
5132 SV *old = mg->mg_obj;
5133 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5134 && len == SvCUR(old)
5135 && strnEQ(SvPVX(old), SvPVX(sv), len)
5137 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5141 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5142 Safefree(mg->mg_ptr);
5148 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5149 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5152 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5153 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5157 /* estimate the buffer size needed */
5158 for (base = s; s <= send; s++) {
5159 if (*s == '\n' || *s == '@' || *s == '^')
5165 Newx(fops, maxops, U32);
5170 *fpc++ = FF_LINEMARK;
5171 noblank = repeat = FALSE;
5189 case ' ': case '\t':
5196 } /* else FALL THROUGH */
5204 *fpc++ = FF_LITERAL;
5212 *fpc++ = (U32)skipspaces;
5216 *fpc++ = FF_NEWLINE;
5220 arg = fpc - linepc + 1;
5227 *fpc++ = FF_LINEMARK;
5228 noblank = repeat = FALSE;
5237 ischop = s[-1] == '^';
5243 arg = (s - base) - 1;
5245 *fpc++ = FF_LITERAL;
5251 if (*s == '*') { /* @* or ^* */
5253 *fpc++ = 2; /* skip the @* or ^* */
5255 *fpc++ = FF_LINESNGL;
5258 *fpc++ = FF_LINEGLOB;
5260 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5261 arg = ischop ? FORM_NUM_BLANK : 0;
5266 const char * const f = ++s;
5269 arg |= FORM_NUM_POINT + (s - f);
5271 *fpc++ = s - base; /* fieldsize for FETCH */
5272 *fpc++ = FF_DECIMAL;
5274 unchopnum |= ! ischop;
5276 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5277 arg = ischop ? FORM_NUM_BLANK : 0;
5279 s++; /* skip the '0' first */
5283 const char * const f = ++s;
5286 arg |= FORM_NUM_POINT + (s - f);
5288 *fpc++ = s - base; /* fieldsize for FETCH */
5289 *fpc++ = FF_0DECIMAL;
5291 unchopnum |= ! ischop;
5293 else { /* text field */
5295 bool ismore = FALSE;
5298 while (*++s == '>') ;
5299 prespace = FF_SPACE;
5301 else if (*s == '|') {
5302 while (*++s == '|') ;
5303 prespace = FF_HALFSPACE;
5308 while (*++s == '<') ;
5311 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5315 *fpc++ = s - base; /* fieldsize for FETCH */
5317 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5320 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5334 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5337 mg->mg_ptr = (char *) fops;
5338 mg->mg_len = arg * sizeof(U32);
5339 mg->mg_obj = sv_copy;
5340 mg->mg_flags |= MGf_REFCOUNTED;
5342 if (unchopnum && repeat)
5343 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5350 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5352 /* Can value be printed in fldsize chars, using %*.*f ? */
5356 int intsize = fldsize - (value < 0 ? 1 : 0);
5358 if (frcsize & FORM_NUM_POINT)
5360 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5363 while (intsize--) pwr *= 10.0;
5364 while (frcsize--) eps /= 10.0;
5367 if (value + eps >= pwr)
5370 if (value - eps <= -pwr)
5377 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5379 SV * const datasv = FILTER_DATA(idx);
5380 const int filter_has_file = IoLINES(datasv);
5381 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5382 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5387 char *prune_from = NULL;
5388 bool read_from_cache = FALSE;
5392 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5394 assert(maxlen >= 0);
5397 /* I was having segfault trouble under Linux 2.2.5 after a
5398 parse error occurred. (Had to hack around it with a test
5399 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5400 not sure where the trouble is yet. XXX */
5403 SV *const cache = datasv;
5406 const char *cache_p = SvPV(cache, cache_len);
5410 /* Running in block mode and we have some cached data already.
5412 if (cache_len >= umaxlen) {
5413 /* In fact, so much data we don't even need to call
5418 const char *const first_nl =
5419 (const char *)memchr(cache_p, '\n', cache_len);
5421 take = first_nl + 1 - cache_p;
5425 sv_catpvn(buf_sv, cache_p, take);
5426 sv_chop(cache, cache_p + take);
5427 /* Definitely not EOF */
5431 sv_catsv(buf_sv, cache);
5433 umaxlen -= cache_len;
5436 read_from_cache = TRUE;
5440 /* Filter API says that the filter appends to the contents of the buffer.
5441 Usually the buffer is "", so the details don't matter. But if it's not,
5442 then clearly what it contains is already filtered by this filter, so we
5443 don't want to pass it in a second time.
5444 I'm going to use a mortal in case the upstream filter croaks. */
5445 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5446 ? sv_newmortal() : buf_sv;
5447 SvUPGRADE(upstream, SVt_PV);
5449 if (filter_has_file) {
5450 status = FILTER_READ(idx+1, upstream, 0);
5453 if (filter_sub && status >= 0) {
5457 ENTER_with_name("call_filter_sub");
5462 DEFSV_set(upstream);
5466 PUSHs(filter_state);
5469 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5479 SV * const errsv = ERRSV;
5480 if (SvTRUE_NN(errsv))
5481 err = newSVsv(errsv);
5487 LEAVE_with_name("call_filter_sub");
5490 if (SvGMAGICAL(upstream)) {
5492 if (upstream == buf_sv) mg_free(buf_sv);
5494 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5495 if(!err && SvOK(upstream)) {
5496 got_p = SvPV_nomg(upstream, got_len);
5498 if (got_len > umaxlen) {
5499 prune_from = got_p + umaxlen;
5502 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5503 if (first_nl && first_nl + 1 < got_p + got_len) {
5504 /* There's a second line here... */
5505 prune_from = first_nl + 1;
5509 if (!err && prune_from) {
5510 /* Oh. Too long. Stuff some in our cache. */
5511 STRLEN cached_len = got_p + got_len - prune_from;
5512 SV *const cache = datasv;
5515 /* Cache should be empty. */
5516 assert(!SvCUR(cache));
5519 sv_setpvn(cache, prune_from, cached_len);
5520 /* If you ask for block mode, you may well split UTF-8 characters.
5521 "If it breaks, you get to keep both parts"
5522 (Your code is broken if you don't put them back together again
5523 before something notices.) */
5524 if (SvUTF8(upstream)) {
5527 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5529 /* Cannot just use sv_setpvn, as that could free the buffer
5530 before we have a chance to assign it. */
5531 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5532 got_len - cached_len);
5534 /* Can't yet be EOF */
5539 /* If they are at EOF but buf_sv has something in it, then they may never
5540 have touched the SV upstream, so it may be undefined. If we naively
5541 concatenate it then we get a warning about use of uninitialised value.
5543 if (!err && upstream != buf_sv &&
5545 sv_catsv_nomg(buf_sv, upstream);
5547 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5550 IoLINES(datasv) = 0;
5552 SvREFCNT_dec(filter_state);
5553 IoTOP_GV(datasv) = NULL;
5556 SvREFCNT_dec(filter_sub);
5557 IoBOTTOM_GV(datasv) = NULL;
5559 filter_del(S_run_user_filter);
5565 if (status == 0 && read_from_cache) {
5566 /* If we read some data from the cache (and by getting here it implies
5567 that we emptied the cache) then we aren't yet at EOF, and mustn't
5568 report that to our caller. */
5575 * ex: set ts=8 sts=4 sw=4 et: