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))
46 const PERL_CONTEXT *cx;
49 if (PL_op->op_private & OPpOFFBYONE) {
50 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
53 cxix = dopoptosub(cxstack_ix);
59 switch (cx->blk_gimme) {
80 PMOP *pm = (PMOP*)cLOGOP->op_other;
85 const regexp_engine *eng;
86 bool is_bare_re= FALSE;
88 if (PL_op->op_flags & OPf_STACKED) {
98 /* prevent recompiling under /o and ithreads. */
99 #if defined(USE_ITHREADS)
100 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
107 assert (re != (REGEXP*) &PL_sv_undef);
108 eng = re ? RX_ENGINE(re) : current_re_engine();
111 In the below logic: these are basically the same - check if this regcomp is part of a split.
113 (PL_op->op_pmflags & PMf_split )
114 (PL_op->op_next->op_type == OP_PUSHRE)
116 We could add a new mask for this and copy the PMf_split, if we did
117 some bit definition fiddling first.
119 For now we leave this
122 new_re = (eng->op_comp
124 : &Perl_re_op_compile
125 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
127 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
129 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
131 if (pm->op_pmflags & PMf_HAS_CV)
132 ReANY(new_re)->qr_anoncv
133 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
137 /* The match's LHS's get-magic might need to access this op's regexp
138 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
139 get-magic now before we replace the regexp. Hopefully this hack can
140 be replaced with the approach described at
141 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
143 if (pm->op_type == OP_MATCH) {
145 const bool was_tainted = TAINT_get;
146 if (pm->op_flags & OPf_STACKED)
148 else if (pm->op_private & OPpTARGET_MY)
149 lhs = PAD_SV(pm->op_targ);
152 /* Restore the previous value of PL_tainted (which may have been
153 modified by get-magic), to avoid incorrectly setting the
154 RXf_TAINTED flag with RX_TAINT_on further down. */
155 TAINT_set(was_tainted);
157 PERL_UNUSED_VAR(was_tainted);
160 tmp = reg_temp_copy(NULL, new_re);
161 ReREFCNT_dec(new_re);
167 PM_SETRE(pm, new_re);
171 if (TAINTING_get && TAINT_get) {
172 SvTAINTED_on((SV*)new_re);
176 #if !defined(USE_ITHREADS)
177 /* can't change the optree at runtime either */
178 /* PMf_KEEP is handled differently under threads to avoid these problems */
179 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
181 if (pm->op_pmflags & PMf_KEEP) {
182 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
183 cLOGOP->op_first->op_next = PL_op->op_next;
196 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
197 PMOP * const pm = (PMOP*) cLOGOP->op_other;
198 SV * const dstr = cx->sb_dstr;
201 char *orig = cx->sb_orig;
202 REGEXP * const rx = cx->sb_rx;
204 REGEXP *old = PM_GETRE(pm);
211 PM_SETRE(pm,ReREFCNT_inc(rx));
214 rxres_restore(&cx->sb_rxres, rx);
216 if (cx->sb_iters++) {
217 const I32 saviters = cx->sb_iters;
218 if (cx->sb_iters > cx->sb_maxiters)
219 DIE(aTHX_ "Substitution loop");
221 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
223 /* See "how taint works" above pp_subst() */
225 cx->sb_rxtainted |= SUBST_TAINT_REPL;
226 sv_catsv_nomg(dstr, POPs);
227 if (CxONCE(cx) || s < orig ||
228 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
229 (s == m), cx->sb_targ, NULL,
230 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
232 SV *targ = cx->sb_targ;
234 assert(cx->sb_strend >= s);
235 if(cx->sb_strend > s) {
236 if (DO_UTF8(dstr) && !SvUTF8(targ))
237 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
239 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
241 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
242 cx->sb_rxtainted |= SUBST_TAINT_PAT;
244 if (pm->op_pmflags & PMf_NONDESTRUCT) {
246 /* From here on down we're using the copy, and leaving the
247 original untouched. */
251 SV_CHECK_THINKFIRST_COW_DROP(targ);
252 if (isGV(targ)) Perl_croak_no_modify();
254 SvPV_set(targ, SvPVX(dstr));
255 SvCUR_set(targ, SvCUR(dstr));
256 SvLEN_set(targ, SvLEN(dstr));
259 SvPV_set(dstr, NULL);
262 mPUSHi(saviters - 1);
264 (void)SvPOK_only_UTF8(targ);
267 /* update the taint state of various various variables in
268 * preparation for final exit.
269 * See "how taint works" above pp_subst() */
271 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
272 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
273 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
275 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
277 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
278 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
280 SvTAINTED_on(TOPs); /* taint return value */
281 /* needed for mg_set below */
283 cBOOL(cx->sb_rxtainted &
284 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
288 /* PL_tainted must be correctly set for this mg_set */
291 LEAVE_SCOPE(cx->sb_oldsave);
294 RETURNOP(pm->op_next);
295 assert(0); /* 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;
319 if (!(mg = mg_find_mglob(sv))) {
320 mg = sv_magicext_mglob(sv);
323 MgBYTEPOS_set(mg, sv, SvPVX(dstr), m - orig);
326 (void)ReREFCNT_inc(rx);
327 /* update the taint state of various various variables in preparation
328 * for calling the code block.
329 * See "how taint works" above pp_subst() */
331 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
332 cx->sb_rxtainted |= SUBST_TAINT_PAT;
334 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
335 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
336 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
338 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
340 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
341 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
342 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
343 ? cx->sb_dstr : cx->sb_targ);
346 rxres_save(&cx->sb_rxres, rx);
348 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
352 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
357 PERL_ARGS_ASSERT_RXRES_SAVE;
360 if (!p || p[1] < RX_NPARENS(rx)) {
362 i = 7 + (RX_NPARENS(rx)+1) * 2;
364 i = 6 + (RX_NPARENS(rx)+1) * 2;
373 /* what (if anything) to free on croak */
374 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
375 RX_MATCH_COPIED_off(rx);
376 *p++ = RX_NPARENS(rx);
379 *p++ = PTR2UV(RX_SAVED_COPY(rx));
380 RX_SAVED_COPY(rx) = NULL;
383 *p++ = PTR2UV(RX_SUBBEG(rx));
384 *p++ = (UV)RX_SUBLEN(rx);
385 *p++ = (UV)RX_SUBOFFSET(rx);
386 *p++ = (UV)RX_SUBCOFFSET(rx);
387 for (i = 0; i <= RX_NPARENS(rx); ++i) {
388 *p++ = (UV)RX_OFFS(rx)[i].start;
389 *p++ = (UV)RX_OFFS(rx)[i].end;
394 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
399 PERL_ARGS_ASSERT_RXRES_RESTORE;
402 RX_MATCH_COPY_FREE(rx);
403 RX_MATCH_COPIED_set(rx, *p);
405 RX_NPARENS(rx) = *p++;
408 if (RX_SAVED_COPY(rx))
409 SvREFCNT_dec (RX_SAVED_COPY(rx));
410 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
414 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
415 RX_SUBLEN(rx) = (I32)(*p++);
416 RX_SUBOFFSET(rx) = (I32)*p++;
417 RX_SUBCOFFSET(rx) = (I32)*p++;
418 for (i = 0; i <= RX_NPARENS(rx); ++i) {
419 RX_OFFS(rx)[i].start = (I32)(*p++);
420 RX_OFFS(rx)[i].end = (I32)(*p++);
425 S_rxres_free(pTHX_ void **rsp)
427 UV * const p = (UV*)*rsp;
429 PERL_ARGS_ASSERT_RXRES_FREE;
433 void *tmp = INT2PTR(char*,*p);
436 U32 i = 9 + p[1] * 2;
438 U32 i = 8 + p[1] * 2;
443 SvREFCNT_dec (INT2PTR(SV*,p[2]));
446 PoisonFree(p, i, sizeof(UV));
455 #define FORM_NUM_BLANK (1<<30)
456 #define FORM_NUM_POINT (1<<29)
460 dVAR; dSP; dMARK; dORIGMARK;
461 SV * const tmpForm = *++MARK;
462 SV *formsv; /* contains text of original format */
463 U32 *fpc; /* format ops program counter */
464 char *t; /* current append position in target string */
465 const char *f; /* current position in format string */
467 SV *sv = NULL; /* current item */
468 const char *item = NULL;/* string value of current item */
469 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
470 I32 itembytes = 0; /* as itemsize, but length in bytes */
471 I32 fieldsize = 0; /* width of current field */
472 I32 lines = 0; /* number of lines that have been output */
473 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
474 const char *chophere = NULL; /* where to chop current item */
475 STRLEN linemark = 0; /* pos of start of line in output */
477 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
478 STRLEN len; /* length of current sv */
479 STRLEN linemax; /* estimate of output size in bytes */
480 bool item_is_utf8 = FALSE;
481 bool targ_is_utf8 = FALSE;
484 U8 *source; /* source of bytes to append */
485 STRLEN to_copy; /* how may bytes to append */
486 char trans; /* what chars to translate */
488 mg = doparseform(tmpForm);
490 fpc = (U32*)mg->mg_ptr;
491 /* the actual string the format was compiled from.
492 * with overload etc, this may not match tmpForm */
496 SvPV_force(PL_formtarget, len);
497 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
498 SvTAINTED_on(PL_formtarget);
499 if (DO_UTF8(PL_formtarget))
501 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
502 t = SvGROW(PL_formtarget, len + linemax + 1);
503 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
505 f = SvPV_const(formsv, len);
509 const char *name = "???";
512 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
513 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
514 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
515 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
516 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
518 case FF_CHECKNL: name = "CHECKNL"; break;
519 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
520 case FF_SPACE: name = "SPACE"; break;
521 case FF_HALFSPACE: name = "HALFSPACE"; break;
522 case FF_ITEM: name = "ITEM"; break;
523 case FF_CHOP: name = "CHOP"; break;
524 case FF_LINEGLOB: name = "LINEGLOB"; break;
525 case FF_NEWLINE: name = "NEWLINE"; break;
526 case FF_MORE: name = "MORE"; break;
527 case FF_LINEMARK: name = "LINEMARK"; break;
528 case FF_END: name = "END"; break;
529 case FF_0DECIMAL: name = "0DECIMAL"; break;
530 case FF_LINESNGL: name = "LINESNGL"; break;
533 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
535 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
538 case FF_LINEMARK: /* start (or end) of a line */
539 linemark = t - SvPVX(PL_formtarget);
544 case FF_LITERAL: /* append <arg> literal chars */
549 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
552 case FF_SKIP: /* skip <arg> chars in format */
556 case FF_FETCH: /* get next item and set field size to <arg> */
565 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
568 SvTAINTED_on(PL_formtarget);
571 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
573 const char *s = item = SvPV_const(sv, len);
574 const char *send = s + len;
577 item_is_utf8 = DO_UTF8(sv);
589 if (itemsize == fieldsize)
592 itembytes = s - item;
596 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
598 const char *s = item = SvPV_const(sv, len);
599 const char *send = s + len;
603 item_is_utf8 = DO_UTF8(sv);
605 /* look for a legal split position */
613 /* provisional split point */
617 /* we delay testing fieldsize until after we've
618 * processed the possible split char directly
619 * following the last field char; so if fieldsize=3
620 * and item="a b cdef", we consume "a b", not "a".
621 * Ditto further down.
623 if (size == fieldsize)
627 if (strchr(PL_chopset, *s)) {
628 /* provisional split point */
629 /* for a non-space split char, we include
630 * the split char; hence the '+1' */
634 if (size == fieldsize)
646 if (!chophere || s == send) {
650 itembytes = chophere - item;
655 case FF_SPACE: /* append padding space (diff of field, item size) */
656 arg = fieldsize - itemsize;
664 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
665 arg = fieldsize - itemsize;
674 case FF_ITEM: /* append a text item, while blanking ctrl chars */
680 case FF_CHOP: /* (for ^*) chop the current item */
682 const char *s = chophere;
690 /* tied, overloaded or similar strangeness.
691 * Do it the hard way */
692 sv_setpvn(sv, s, len - (s-item));
697 case FF_LINESNGL: /* process ^* */
700 case FF_LINEGLOB: /* process @* */
702 const bool oneline = fpc[-1] == FF_LINESNGL;
703 const char *s = item = SvPV_const(sv, len);
704 const char *const send = s + len;
706 item_is_utf8 = DO_UTF8(sv);
717 to_copy = s - item - 1;
731 /* append to_copy bytes from source to PL_formstring.
732 * item_is_utf8 implies source is utf8.
733 * if trans, translate certain characters during the copy */
738 SvCUR_set(PL_formtarget,
739 t - SvPVX_const(PL_formtarget));
741 if (targ_is_utf8 && !item_is_utf8) {
742 source = tmp = bytes_to_utf8(source, &to_copy);
744 if (item_is_utf8 && !targ_is_utf8) {
746 /* Upgrade targ to UTF8, and then we reduce it to
747 a problem we have a simple solution for.
748 Don't need get magic. */
749 sv_utf8_upgrade_nomg(PL_formtarget);
751 /* re-calculate linemark */
752 s = (U8*)SvPVX(PL_formtarget);
753 /* the bytes we initially allocated to append the
754 * whole line may have been gobbled up during the
755 * upgrade, so allocate a whole new line's worth
760 linemark = s - (U8*)SvPVX(PL_formtarget);
762 /* Easy. They agree. */
763 assert (item_is_utf8 == targ_is_utf8);
766 /* @* and ^* are the only things that can exceed
767 * the linemax, so grow by the output size, plus
768 * a whole new form's worth in case of any further
770 grow = linemax + to_copy;
772 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
773 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
775 Copy(source, t, to_copy, char);
777 /* blank out ~ or control chars, depending on trans.
778 * works on bytes not chars, so relies on not
779 * matching utf8 continuation bytes */
781 U8 *send = s + to_copy;
784 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
791 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
797 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
799 #if defined(USE_LONG_DOUBLE)
801 ((arg & FORM_NUM_POINT) ?
802 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
805 ((arg & FORM_NUM_POINT) ?
806 "%#0*.*f" : "%0*.*f");
810 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
812 #if defined(USE_LONG_DOUBLE)
814 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
817 ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
820 /* If the field is marked with ^ and the value is undefined,
822 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
830 /* overflow evidence */
831 if (num_overflow(value, fieldsize, arg)) {
837 /* Formats aren't yet marked for locales, so assume "yes". */
839 DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
840 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
841 /* we generate fmt ourselves so it is safe */
842 GCC_DIAG_IGNORE(-Wformat-nonliteral);
843 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
845 RESTORE_LC_NUMERIC();
850 case FF_NEWLINE: /* delete trailing spaces, then append \n */
852 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
857 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
860 if (arg) { /* repeat until fields exhausted? */
866 t = SvPVX(PL_formtarget) + linemark;
871 case FF_MORE: /* replace long end of string with '...' */
873 const char *s = chophere;
874 const char *send = item + len;
876 while (isSPACE(*s) && (s < send))
881 arg = fieldsize - itemsize;
888 if (strnEQ(s1," ",3)) {
889 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
899 case FF_END: /* tidy up, then return */
901 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
903 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
905 SvUTF8_on(PL_formtarget);
906 FmLINES(PL_formtarget) += lines;
908 if (fpc[-1] == FF_BLANK)
909 RETURNOP(cLISTOP->op_first);
921 if (PL_stack_base + *PL_markstack_ptr == SP) {
923 if (GIMME_V == G_SCALAR)
925 RETURNOP(PL_op->op_next->op_next);
927 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
928 Perl_pp_pushmark(aTHX); /* push dst */
929 Perl_pp_pushmark(aTHX); /* push src */
930 ENTER_with_name("grep"); /* enter outer scope */
933 if (PL_op->op_private & OPpGREP_LEX)
934 SAVESPTR(PAD_SVl(PL_op->op_targ));
937 ENTER_with_name("grep_item"); /* enter inner scope */
940 src = PL_stack_base[*PL_markstack_ptr];
941 if (SvPADTMP(src) && !IS_PADGV(src)) {
942 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
946 if (PL_op->op_private & OPpGREP_LEX)
947 PAD_SVl(PL_op->op_targ) = src;
952 if (PL_op->op_type == OP_MAPSTART)
953 Perl_pp_pushmark(aTHX); /* push top */
954 return ((LOGOP*)PL_op->op_next)->op_other;
960 const I32 gimme = GIMME_V;
961 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
967 /* first, move source pointer to the next item in the source list */
968 ++PL_markstack_ptr[-1];
970 /* if there are new items, push them into the destination list */
971 if (items && gimme != G_VOID) {
972 /* might need to make room back there first */
973 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
974 /* XXX this implementation is very pessimal because the stack
975 * is repeatedly extended for every set of items. Is possible
976 * to do this without any stack extension or copying at all
977 * by maintaining a separate list over which the map iterates
978 * (like foreach does). --gsar */
980 /* everything in the stack after the destination list moves
981 * towards the end the stack by the amount of room needed */
982 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
984 /* items to shift up (accounting for the moved source pointer) */
985 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
987 /* This optimization is by Ben Tilly and it does
988 * things differently from what Sarathy (gsar)
989 * is describing. The downside of this optimization is
990 * that leaves "holes" (uninitialized and hopefully unused areas)
991 * to the Perl stack, but on the other hand this
992 * shouldn't be a problem. If Sarathy's idea gets
993 * implemented, this optimization should become
994 * irrelevant. --jhi */
996 shift = count; /* Avoid shifting too often --Ben Tilly */
1000 dst = (SP += shift);
1001 PL_markstack_ptr[-1] += shift;
1002 *PL_markstack_ptr += shift;
1006 /* copy the new items down to the destination list */
1007 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1008 if (gimme == G_ARRAY) {
1009 /* add returned items to the collection (making mortal copies
1010 * if necessary), then clear the current temps stack frame
1011 * *except* for those items. We do this splicing the items
1012 * into the start of the tmps frame (so some items may be on
1013 * the tmps stack twice), then moving PL_tmps_floor above
1014 * them, then freeing the frame. That way, the only tmps that
1015 * accumulate over iterations are the return values for map.
1016 * We have to do to this way so that everything gets correctly
1017 * freed if we die during the map.
1021 /* make space for the slice */
1022 EXTEND_MORTAL(items);
1023 tmpsbase = PL_tmps_floor + 1;
1024 Move(PL_tmps_stack + tmpsbase,
1025 PL_tmps_stack + tmpsbase + items,
1026 PL_tmps_ix - PL_tmps_floor,
1028 PL_tmps_ix += items;
1033 sv = sv_mortalcopy(sv);
1035 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1037 /* clear the stack frame except for the items */
1038 PL_tmps_floor += items;
1040 /* FREETMPS may have cleared the TEMP flag on some of the items */
1043 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1046 /* scalar context: we don't care about which values map returns
1047 * (we use undef here). And so we certainly don't want to do mortal
1048 * copies of meaningless values. */
1049 while (items-- > 0) {
1051 *dst-- = &PL_sv_undef;
1059 LEAVE_with_name("grep_item"); /* exit inner scope */
1062 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1064 (void)POPMARK; /* pop top */
1065 LEAVE_with_name("grep"); /* exit outer scope */
1066 (void)POPMARK; /* pop src */
1067 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1068 (void)POPMARK; /* pop dst */
1069 SP = PL_stack_base + POPMARK; /* pop original mark */
1070 if (gimme == G_SCALAR) {
1071 if (PL_op->op_private & OPpGREP_LEX) {
1072 SV* sv = sv_newmortal();
1073 sv_setiv(sv, items);
1081 else if (gimme == G_ARRAY)
1088 ENTER_with_name("grep_item"); /* enter inner scope */
1091 /* set $_ to the new source item */
1092 src = PL_stack_base[PL_markstack_ptr[-1]];
1093 if (SvPADTMP(src) && !IS_PADGV(src)) src = sv_mortalcopy(src);
1095 if (PL_op->op_private & OPpGREP_LEX)
1096 PAD_SVl(PL_op->op_targ) = src;
1100 RETURNOP(cLOGOP->op_other);
1109 if (GIMME == G_ARRAY)
1111 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1112 return cLOGOP->op_other;
1122 if (GIMME == G_ARRAY) {
1123 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1127 SV * const targ = PAD_SV(PL_op->op_targ);
1130 if (PL_op->op_private & OPpFLIP_LINENUM) {
1131 if (GvIO(PL_last_in_gv)) {
1132 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1135 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1137 flip = SvIV(sv) == SvIV(GvSV(gv));
1143 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1144 if (PL_op->op_flags & OPf_SPECIAL) {
1152 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1155 sv_setpvs(TARG, "");
1161 /* This code tries to decide if "$left .. $right" should use the
1162 magical string increment, or if the range is numeric (we make
1163 an exception for .."0" [#18165]). AMS 20021031. */
1165 #define RANGE_IS_NUMERIC(left,right) ( \
1166 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1167 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1168 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1169 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1170 && (!SvOK(right) || looks_like_number(right))))
1176 if (GIMME == G_ARRAY) {
1182 if (RANGE_IS_NUMERIC(left,right)) {
1185 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1186 (SvOK(right) && (SvIOK(right)
1187 ? SvIsUV(right) && SvUV(right) > IV_MAX
1188 : SvNV_nomg(right) > IV_MAX)))
1189 DIE(aTHX_ "Range iterator outside integer range");
1190 i = SvIV_nomg(left);
1191 max = SvIV_nomg(right);
1194 if (j > SSize_t_MAX)
1195 Perl_croak(aTHX_ "Out of memory during list extend");
1202 SV * const sv = sv_2mortal(newSViv(i++));
1208 const char * const lpv = SvPV_nomg_const(left, llen);
1209 const char * const tmps = SvPV_nomg_const(right, len);
1211 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1212 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1214 if (strEQ(SvPVX_const(sv),tmps))
1216 sv = sv_2mortal(newSVsv(sv));
1223 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1227 if (PL_op->op_private & OPpFLIP_LINENUM) {
1228 if (GvIO(PL_last_in_gv)) {
1229 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1232 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1233 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1241 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1242 sv_catpvs(targ, "E0");
1252 static const char * const context_name[] = {
1254 NULL, /* CXt_WHEN never actually needs "block" */
1255 NULL, /* CXt_BLOCK never actually needs "block" */
1256 NULL, /* CXt_GIVEN never actually needs "block" */
1257 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1258 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1259 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1260 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1268 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1273 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1275 for (i = cxstack_ix; i >= 0; i--) {
1276 const PERL_CONTEXT * const cx = &cxstack[i];
1277 switch (CxTYPE(cx)) {
1283 /* diag_listed_as: Exiting subroutine via %s */
1284 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1285 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1286 if (CxTYPE(cx) == CXt_NULL)
1289 case CXt_LOOP_LAZYIV:
1290 case CXt_LOOP_LAZYSV:
1292 case CXt_LOOP_PLAIN:
1294 STRLEN cx_label_len = 0;
1295 U32 cx_label_flags = 0;
1296 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1298 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1301 (const U8*)cx_label, cx_label_len,
1302 (const U8*)label, len) == 0)
1304 (const U8*)label, len,
1305 (const U8*)cx_label, cx_label_len) == 0)
1306 : (len == cx_label_len && ((cx_label == label)
1307 || memEQ(cx_label, label, len))) )) {
1308 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1309 (long)i, cx_label));
1312 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1323 Perl_dowantarray(pTHX)
1326 const I32 gimme = block_gimme();
1327 return (gimme == G_VOID) ? G_SCALAR : gimme;
1331 Perl_block_gimme(pTHX)
1334 const I32 cxix = dopoptosub(cxstack_ix);
1338 switch (cxstack[cxix].blk_gimme) {
1346 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1347 assert(0); /* NOTREACHED */
1353 Perl_is_lvalue_sub(pTHX)
1356 const I32 cxix = dopoptosub(cxstack_ix);
1357 assert(cxix >= 0); /* We should only be called from inside subs */
1359 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1360 return CxLVAL(cxstack + cxix);
1365 /* only used by PUSHSUB */
1367 Perl_was_lvalue_sub(pTHX)
1370 const I32 cxix = dopoptosub(cxstack_ix-1);
1371 assert(cxix >= 0); /* We should only be called from inside subs */
1373 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1374 return CxLVAL(cxstack + cxix);
1380 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1385 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1387 for (i = startingblock; i >= 0; i--) {
1388 const PERL_CONTEXT * const cx = &cxstk[i];
1389 switch (CxTYPE(cx)) {
1393 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1394 * twice; the first for the normal foo() call, and the second
1395 * for a faked up re-entry into the sub to execute the
1396 * code block. Hide this faked entry from the world. */
1397 if (cx->cx_type & CXp_SUB_RE_FAKE)
1401 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1409 S_dopoptoeval(pTHX_ I32 startingblock)
1413 for (i = startingblock; i >= 0; i--) {
1414 const PERL_CONTEXT *cx = &cxstack[i];
1415 switch (CxTYPE(cx)) {
1419 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1427 S_dopoptoloop(pTHX_ I32 startingblock)
1431 for (i = startingblock; i >= 0; i--) {
1432 const PERL_CONTEXT * const cx = &cxstack[i];
1433 switch (CxTYPE(cx)) {
1439 /* diag_listed_as: Exiting subroutine via %s */
1440 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1441 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1442 if ((CxTYPE(cx)) == CXt_NULL)
1445 case CXt_LOOP_LAZYIV:
1446 case CXt_LOOP_LAZYSV:
1448 case CXt_LOOP_PLAIN:
1449 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1457 S_dopoptogiven(pTHX_ I32 startingblock)
1461 for (i = startingblock; i >= 0; i--) {
1462 const PERL_CONTEXT *cx = &cxstack[i];
1463 switch (CxTYPE(cx)) {
1467 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1469 case CXt_LOOP_PLAIN:
1470 assert(!CxFOREACHDEF(cx));
1472 case CXt_LOOP_LAZYIV:
1473 case CXt_LOOP_LAZYSV:
1475 if (CxFOREACHDEF(cx)) {
1476 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1485 S_dopoptowhen(pTHX_ I32 startingblock)
1489 for (i = startingblock; i >= 0; i--) {
1490 const PERL_CONTEXT *cx = &cxstack[i];
1491 switch (CxTYPE(cx)) {
1495 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1503 Perl_dounwind(pTHX_ I32 cxix)
1508 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1511 while (cxstack_ix > cxix) {
1513 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1514 DEBUG_CX("UNWIND"); \
1515 /* Note: we don't need to restore the base context info till the end. */
1516 switch (CxTYPE(cx)) {
1519 continue; /* not break */
1527 case CXt_LOOP_LAZYIV:
1528 case CXt_LOOP_LAZYSV:
1530 case CXt_LOOP_PLAIN:
1541 PERL_UNUSED_VAR(optype);
1545 Perl_qerror(pTHX_ SV *err)
1549 PERL_ARGS_ASSERT_QERROR;
1552 if (PL_in_eval & EVAL_KEEPERR) {
1553 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1557 sv_catsv(ERRSV, err);
1560 sv_catsv(PL_errors, err);
1562 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1564 ++PL_parser->error_count;
1568 Perl_die_unwind(pTHX_ SV *msv)
1571 SV *exceptsv = sv_mortalcopy(msv);
1572 U8 in_eval = PL_in_eval;
1573 PERL_ARGS_ASSERT_DIE_UNWIND;
1580 * Historically, perl used to set ERRSV ($@) early in the die
1581 * process and rely on it not getting clobbered during unwinding.
1582 * That sucked, because it was liable to get clobbered, so the
1583 * setting of ERRSV used to emit the exception from eval{} has
1584 * been moved to much later, after unwinding (see just before
1585 * JMPENV_JUMP below). However, some modules were relying on the
1586 * early setting, by examining $@ during unwinding to use it as
1587 * a flag indicating whether the current unwinding was caused by
1588 * an exception. It was never a reliable flag for that purpose,
1589 * being totally open to false positives even without actual
1590 * clobberage, but was useful enough for production code to
1591 * semantically rely on it.
1593 * We'd like to have a proper introspective interface that
1594 * explicitly describes the reason for whatever unwinding
1595 * operations are currently in progress, so that those modules
1596 * work reliably and $@ isn't further overloaded. But we don't
1597 * have one yet. In its absence, as a stopgap measure, ERRSV is
1598 * now *additionally* set here, before unwinding, to serve as the
1599 * (unreliable) flag that it used to.
1601 * This behaviour is temporary, and should be removed when a
1602 * proper way to detect exceptional unwinding has been developed.
1603 * As of 2010-12, the authors of modules relying on the hack
1604 * are aware of the issue, because the modules failed on
1605 * perls 5.13.{1..7} which had late setting of $@ without this
1606 * early-setting hack.
1608 if (!(in_eval & EVAL_KEEPERR)) {
1609 SvTEMP_off(exceptsv);
1610 sv_setsv(ERRSV, exceptsv);
1613 if (in_eval & EVAL_KEEPERR) {
1614 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1618 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1619 && PL_curstackinfo->si_prev)
1631 JMPENV *restartjmpenv;
1634 if (cxix < cxstack_ix)
1637 POPBLOCK(cx,PL_curpm);
1638 if (CxTYPE(cx) != CXt_EVAL) {
1640 const char* message = SvPVx_const(exceptsv, msglen);
1641 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1642 PerlIO_write(Perl_error_log, message, msglen);
1646 namesv = cx->blk_eval.old_namesv;
1647 oldcop = cx->blk_oldcop;
1648 restartjmpenv = cx->blk_eval.cur_top_env;
1649 restartop = cx->blk_eval.retop;
1651 if (gimme == G_SCALAR)
1652 *++newsp = &PL_sv_undef;
1653 PL_stack_sp = newsp;
1657 /* LEAVE could clobber PL_curcop (see save_re_context())
1658 * XXX it might be better to find a way to avoid messing with
1659 * PL_curcop in save_re_context() instead, but this is a more
1660 * minimal fix --GSAR */
1663 if (optype == OP_REQUIRE) {
1664 (void)hv_store(GvHVn(PL_incgv),
1665 SvPVX_const(namesv),
1666 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1668 /* note that unlike pp_entereval, pp_require isn't
1669 * supposed to trap errors. So now that we've popped the
1670 * EVAL that pp_require pushed, and processed the error
1671 * message, rethrow the error */
1672 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1673 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1676 if (!(in_eval & EVAL_KEEPERR))
1677 sv_setsv(ERRSV, exceptsv);
1678 PL_restartjmpenv = restartjmpenv;
1679 PL_restartop = restartop;
1681 assert(0); /* NOTREACHED */
1685 write_to_stderr(exceptsv);
1687 assert(0); /* NOTREACHED */
1692 dVAR; dSP; dPOPTOPssrl;
1693 if (SvTRUE(left) != SvTRUE(right))
1700 =for apidoc caller_cx
1702 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1703 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1704 information returned to Perl by C<caller>. Note that XSUBs don't get a
1705 stack frame, so C<caller_cx(0, NULL)> will return information for the
1706 immediately-surrounding Perl code.
1708 This function skips over the automatic calls to C<&DB::sub> made on the
1709 behalf of the debugger. If the stack frame requested was a sub called by
1710 C<DB::sub>, the return value will be the frame for the call to
1711 C<DB::sub>, since that has the correct line number/etc. for the call
1712 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1713 frame for the sub call itself.
1718 const PERL_CONTEXT *
1719 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1721 I32 cxix = dopoptosub(cxstack_ix);
1722 const PERL_CONTEXT *cx;
1723 const PERL_CONTEXT *ccstack = cxstack;
1724 const PERL_SI *top_si = PL_curstackinfo;
1727 /* we may be in a higher stacklevel, so dig down deeper */
1728 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1729 top_si = top_si->si_prev;
1730 ccstack = top_si->si_cxstack;
1731 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1735 /* caller() should not report the automatic calls to &DB::sub */
1736 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1737 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1741 cxix = dopoptosub_at(ccstack, cxix - 1);
1744 cx = &ccstack[cxix];
1745 if (dbcxp) *dbcxp = cx;
1747 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1748 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1749 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1750 field below is defined for any cx. */
1751 /* caller() should not report the automatic calls to &DB::sub */
1752 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1753 cx = &ccstack[dbcxix];
1763 const PERL_CONTEXT *cx;
1764 const PERL_CONTEXT *dbcx;
1766 const HEK *stash_hek;
1768 bool has_arg = MAXARG && TOPs;
1777 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1779 if (GIMME != G_ARRAY) {
1787 assert(CopSTASH(cx->blk_oldcop));
1788 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1789 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1791 if (GIMME != G_ARRAY) {
1794 PUSHs(&PL_sv_undef);
1797 sv_sethek(TARG, stash_hek);
1806 PUSHs(&PL_sv_undef);
1809 sv_sethek(TARG, stash_hek);
1812 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1813 lcop = closest_cop(cx->blk_oldcop, cx->blk_oldcop->op_sibling,
1814 cx->blk_sub.retop, TRUE);
1816 lcop = cx->blk_oldcop;
1817 mPUSHi((I32)CopLINE(lcop));
1820 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1821 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1822 /* So is ccstack[dbcxix]. */
1823 if (cvgv && isGV(cvgv)) {
1824 SV * const sv = newSV(0);
1825 gv_efullname3(sv, cvgv, NULL);
1827 PUSHs(boolSV(CxHASARGS(cx)));
1830 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1831 PUSHs(boolSV(CxHASARGS(cx)));
1835 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1838 gimme = (I32)cx->blk_gimme;
1839 if (gimme == G_VOID)
1840 PUSHs(&PL_sv_undef);
1842 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1843 if (CxTYPE(cx) == CXt_EVAL) {
1845 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1846 PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
1847 SvCUR(cx->blk_eval.cur_text)-2,
1848 SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
1852 else if (cx->blk_eval.old_namesv) {
1853 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1856 /* eval BLOCK (try blocks have old_namesv == 0) */
1858 PUSHs(&PL_sv_undef);
1859 PUSHs(&PL_sv_undef);
1863 PUSHs(&PL_sv_undef);
1864 PUSHs(&PL_sv_undef);
1866 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1867 && CopSTASH_eq(PL_curcop, PL_debstash))
1869 AV * const ary = cx->blk_sub.argarray;
1870 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1872 Perl_init_dbargs(aTHX);
1874 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1875 av_extend(PL_dbargs, AvFILLp(ary) + off);
1876 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1877 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1879 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1882 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1884 if (old_warnings == pWARN_NONE)
1885 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1886 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1887 mask = &PL_sv_undef ;
1888 else if (old_warnings == pWARN_ALL ||
1889 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1890 /* Get the bit mask for $warnings::Bits{all}, because
1891 * it could have been extended by warnings::register */
1893 HV * const bits = get_hv("warnings::Bits", 0);
1894 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1895 mask = newSVsv(*bits_all);
1898 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1902 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1906 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1907 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1918 if (MAXARG < 1 || (!TOPs && !POPs))
1919 tmps = NULL, len = 0;
1921 tmps = SvPVx_const(POPs, len);
1922 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1927 /* like pp_nextstate, but used instead when the debugger is active */
1932 PL_curcop = (COP*)PL_op;
1933 TAINT_NOT; /* Each statement is presumed innocent */
1934 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1939 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1940 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1944 const I32 gimme = G_ARRAY;
1946 GV * const gv = PL_DBgv;
1949 if (gv && isGV_with_GP(gv))
1952 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1953 DIE(aTHX_ "No DB::DB routine defined");
1955 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1956 /* don't do recursive DB::DB call */
1970 (void)(*CvXSUB(cv))(aTHX_ cv);
1976 PUSHBLOCK(cx, CXt_SUB, SP);
1978 cx->blk_sub.retop = PL_op->op_next;
1980 if (CvDEPTH(cv) >= 2) {
1981 PERL_STACK_OVERFLOW_CHECK();
1982 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1985 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1986 RETURNOP(CvSTART(cv));
1993 /* SVs on the stack that have any of the flags passed in are left as is.
1994 Other SVs are protected via the mortals stack if lvalue is true, and
1995 copied otherwise. */
1998 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
1999 U32 flags, bool lvalue)
2002 PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2004 if (flags & SVs_PADTMP) {
2005 flags &= ~SVs_PADTMP;
2008 if (gimme == G_SCALAR) {
2010 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2013 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2014 : sv_mortalcopy(*SP);
2016 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2019 *++MARK = &PL_sv_undef;
2023 else if (gimme == G_ARRAY) {
2024 /* in case LEAVE wipes old return values */
2025 while (++MARK <= SP) {
2026 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2030 ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
2031 : sv_mortalcopy(*MARK);
2032 TAINT_NOT; /* Each item is independent */
2035 /* When this function was called with MARK == newsp, we reach this
2036 * point with SP == newsp. */
2046 I32 gimme = GIMME_V;
2048 ENTER_with_name("block");
2051 PUSHBLOCK(cx, CXt_BLOCK, SP);
2064 if (PL_op->op_flags & OPf_SPECIAL) {
2065 cx = &cxstack[cxstack_ix];
2066 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2071 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2074 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
2075 PL_op->op_private & OPpLVALUE);
2076 PL_curpm = newpm; /* Don't pop $1 et al till now */
2078 LEAVE_with_name("block");
2087 const I32 gimme = GIMME_V;
2088 void *itervar; /* location of the iteration variable */
2089 U8 cxtype = CXt_LOOP_FOR;
2091 ENTER_with_name("loop1");
2094 if (PL_op->op_targ) { /* "my" variable */
2095 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2096 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2097 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2098 SVs_PADSTALE, SVs_PADSTALE);
2100 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2102 itervar = PL_comppad;
2104 itervar = &PAD_SVl(PL_op->op_targ);
2107 else { /* symbol table variable */
2108 GV * const gv = MUTABLE_GV(POPs);
2109 SV** svp = &GvSV(gv);
2110 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2112 itervar = (void *)gv;
2115 if (PL_op->op_private & OPpITER_DEF)
2116 cxtype |= CXp_FOR_DEF;
2118 ENTER_with_name("loop2");
2120 PUSHBLOCK(cx, cxtype, SP);
2121 PUSHLOOP_FOR(cx, itervar, MARK);
2122 if (PL_op->op_flags & OPf_STACKED) {
2123 SV *maybe_ary = POPs;
2124 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2126 SV * const right = maybe_ary;
2129 if (RANGE_IS_NUMERIC(sv,right)) {
2130 cx->cx_type &= ~CXTYPEMASK;
2131 cx->cx_type |= CXt_LOOP_LAZYIV;
2132 /* Make sure that no-one re-orders cop.h and breaks our
2134 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2135 #ifdef NV_PRESERVES_UV
2136 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2137 (SvNV_nomg(sv) > (NV)IV_MAX)))
2139 (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2140 (SvNV_nomg(right) < (NV)IV_MIN))))
2142 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
2144 ((SvNV_nomg(sv) > 0) &&
2145 ((SvUV_nomg(sv) > (UV)IV_MAX) ||
2146 (SvNV_nomg(sv) > (NV)UV_MAX)))))
2148 (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
2150 ((SvNV_nomg(right) > 0) &&
2151 ((SvUV_nomg(right) > (UV)IV_MAX) ||
2152 (SvNV_nomg(right) > (NV)UV_MAX))
2155 DIE(aTHX_ "Range iterator outside integer range");
2156 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2157 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2159 /* for correct -Dstv display */
2160 cx->blk_oldsp = sp - PL_stack_base;
2164 cx->cx_type &= ~CXTYPEMASK;
2165 cx->cx_type |= CXt_LOOP_LAZYSV;
2166 /* Make sure that no-one re-orders cop.h and breaks our
2168 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2169 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2170 cx->blk_loop.state_u.lazysv.end = right;
2171 SvREFCNT_inc(right);
2172 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2173 /* This will do the upgrade to SVt_PV, and warn if the value
2174 is uninitialised. */
2175 (void) SvPV_nolen_const(right);
2176 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2177 to replace !SvOK() with a pointer to "". */
2179 SvREFCNT_dec(right);
2180 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2184 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2185 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2186 SvREFCNT_inc(maybe_ary);
2187 cx->blk_loop.state_u.ary.ix =
2188 (PL_op->op_private & OPpITER_REVERSED) ?
2189 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2193 else { /* iterating over items on the stack */
2194 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2195 if (PL_op->op_private & OPpITER_REVERSED) {
2196 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2199 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2210 const I32 gimme = GIMME_V;
2212 ENTER_with_name("loop1");
2214 ENTER_with_name("loop2");
2216 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2217 PUSHLOOP_PLAIN(cx, SP);
2232 assert(CxTYPE_is_LOOP(cx));
2234 newsp = PL_stack_base + cx->blk_loop.resetsp;
2237 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0,
2238 PL_op->op_private & OPpLVALUE);
2241 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2242 PL_curpm = newpm; /* ... and pop $1 et al */
2244 LEAVE_with_name("loop2");
2245 LEAVE_with_name("loop1");
2251 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2252 PERL_CONTEXT *cx, PMOP *newpm)
2254 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2255 if (gimme == G_SCALAR) {
2256 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2258 const char *what = NULL;
2260 assert(MARK+1 == SP);
2261 if ((SvPADTMP(TOPs) ||
2262 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2265 !SvSMAGICAL(TOPs)) {
2267 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2268 : "a readonly value" : "a temporary";
2273 /* sub:lvalue{} will take us here. */
2282 "Can't return %s from lvalue subroutine", what
2287 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2288 if (!SvPADTMP(*SP)) {
2289 *++newsp = SvREFCNT_inc(*SP);
2294 /* FREETMPS could clobber it */
2295 SV *sv = SvREFCNT_inc(*SP);
2297 *++newsp = sv_mortalcopy(sv);
2304 ? sv_mortalcopy(*SP)
2306 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2311 *++newsp = &PL_sv_undef;
2313 if (CxLVAL(cx) & OPpDEREF) {
2316 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2320 else if (gimme == G_ARRAY) {
2321 assert (!(CxLVAL(cx) & OPpDEREF));
2322 if (ref || !CxLVAL(cx))
2323 while (++MARK <= SP)
2325 SvFLAGS(*MARK) & SVs_PADTMP
2326 ? sv_mortalcopy(*MARK)
2329 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2330 else while (++MARK <= SP) {
2331 if (*MARK != &PL_sv_undef
2333 || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2338 /* Might be flattened array after $#array = */
2345 /* diag_listed_as: Can't return %s from lvalue subroutine */
2347 "Can't return a %s from lvalue subroutine",
2348 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2354 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2357 PL_stack_sp = newsp;
2364 bool popsub2 = FALSE;
2365 bool clear_errsv = FALSE;
2375 const I32 cxix = dopoptosub(cxstack_ix);
2378 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2379 * sort block, which is a CXt_NULL
2382 PL_stack_base[1] = *PL_stack_sp;
2383 PL_stack_sp = PL_stack_base + 1;
2387 DIE(aTHX_ "Can't return outside a subroutine");
2389 if (cxix < cxstack_ix)
2392 if (CxMULTICALL(&cxstack[cxix])) {
2393 gimme = cxstack[cxix].blk_gimme;
2394 if (gimme == G_VOID)
2395 PL_stack_sp = PL_stack_base;
2396 else if (gimme == G_SCALAR) {
2397 PL_stack_base[1] = *PL_stack_sp;
2398 PL_stack_sp = PL_stack_base + 1;
2404 switch (CxTYPE(cx)) {
2407 lval = !!CvLVALUE(cx->blk_sub.cv);
2408 retop = cx->blk_sub.retop;
2409 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2412 if (!(PL_in_eval & EVAL_KEEPERR))
2415 namesv = cx->blk_eval.old_namesv;
2416 retop = cx->blk_eval.retop;
2419 if (optype == OP_REQUIRE &&
2420 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2422 /* Unassume the success we assumed earlier. */
2423 (void)hv_delete(GvHVn(PL_incgv),
2424 SvPVX_const(namesv),
2425 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2427 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2431 retop = cx->blk_sub.retop;
2435 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2439 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2441 if (gimme == G_SCALAR) {
2444 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2445 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2446 && !SvMAGICAL(TOPs)) {
2447 *++newsp = SvREFCNT_inc(*SP);
2452 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2454 *++newsp = sv_mortalcopy(sv);
2458 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2459 && !SvMAGICAL(*SP)) {
2463 *++newsp = sv_mortalcopy(*SP);
2466 *++newsp = sv_mortalcopy(*SP);
2469 *++newsp = &PL_sv_undef;
2471 else if (gimme == G_ARRAY) {
2472 while (++MARK <= SP) {
2473 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2474 && !SvGMAGICAL(*MARK)
2475 ? *MARK : sv_mortalcopy(*MARK);
2476 TAINT_NOT; /* Each item is independent */
2479 PL_stack_sp = newsp;
2483 /* Stack values are safe: */
2486 POPSUB(cx,sv); /* release CV and @_ ... */
2490 PL_curpm = newpm; /* ... and pop $1 et al */
2499 /* This duplicates parts of pp_leavesub, so that it can share code with
2510 if (CxMULTICALL(&cxstack[cxstack_ix]))
2514 cxstack_ix++; /* temporarily protect top context */
2518 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2521 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2523 PL_curpm = newpm; /* ... and pop $1 et al */
2526 return cx->blk_sub.retop;
2530 S_unwind_loop(pTHX_ const char * const opname)
2534 if (PL_op->op_flags & OPf_SPECIAL) {
2535 cxix = dopoptoloop(cxstack_ix);
2537 /* diag_listed_as: Can't "last" outside a loop block */
2538 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2543 const char * const label =
2544 PL_op->op_flags & OPf_STACKED
2545 ? SvPV(TOPs,label_len)
2546 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2547 const U32 label_flags =
2548 PL_op->op_flags & OPf_STACKED
2550 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2552 cxix = dopoptolabel(label, label_len, label_flags);
2554 /* diag_listed_as: Label not found for "last %s" */
2555 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2557 SVfARG(PL_op->op_flags & OPf_STACKED
2558 && !SvGMAGICAL(TOPp1s)
2560 : newSVpvn_flags(label,
2562 label_flags | SVs_TEMP)));
2564 if (cxix < cxstack_ix)
2581 S_unwind_loop(aTHX_ "last");
2584 cxstack_ix++; /* temporarily protect top context */
2585 switch (CxTYPE(cx)) {
2586 case CXt_LOOP_LAZYIV:
2587 case CXt_LOOP_LAZYSV:
2589 case CXt_LOOP_PLAIN:
2591 newsp = PL_stack_base + cx->blk_loop.resetsp;
2592 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2596 nextop = cx->blk_sub.retop;
2600 nextop = cx->blk_eval.retop;
2604 nextop = cx->blk_sub.retop;
2607 DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2611 PL_stack_sp = newsp;
2615 /* Stack values are safe: */
2617 case CXt_LOOP_LAZYIV:
2618 case CXt_LOOP_PLAIN:
2619 case CXt_LOOP_LAZYSV:
2621 POPLOOP(cx); /* release loop vars ... */
2625 POPSUB(cx,sv); /* release CV and @_ ... */
2628 PL_curpm = newpm; /* ... and pop $1 et al */
2631 PERL_UNUSED_VAR(optype);
2632 PERL_UNUSED_VAR(gimme);
2640 const I32 inner = PL_scopestack_ix;
2642 S_unwind_loop(aTHX_ "next");
2644 /* clear off anything above the scope we're re-entering, but
2645 * save the rest until after a possible continue block */
2647 if (PL_scopestack_ix < inner)
2648 leave_scope(PL_scopestack[PL_scopestack_ix]);
2649 PL_curcop = cx->blk_oldcop;
2651 return (cx)->blk_loop.my_op->op_nextop;
2657 const I32 cxix = S_unwind_loop(aTHX_ "redo");
2660 OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2662 if (redo_op->op_type == OP_ENTER) {
2663 /* pop one less context to avoid $x being freed in while (my $x..) */
2665 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2666 redo_op = redo_op->op_next;
2670 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2671 LEAVE_SCOPE(oldsave);
2673 PL_curcop = cx->blk_oldcop;
2679 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2683 static const char* const too_deep = "Target of goto is too deeply nested";
2685 PERL_ARGS_ASSERT_DOFINDLABEL;
2688 Perl_croak(aTHX_ "%s", too_deep);
2689 if (o->op_type == OP_LEAVE ||
2690 o->op_type == OP_SCOPE ||
2691 o->op_type == OP_LEAVELOOP ||
2692 o->op_type == OP_LEAVESUB ||
2693 o->op_type == OP_LEAVETRY)
2695 *ops++ = cUNOPo->op_first;
2697 Perl_croak(aTHX_ "%s", too_deep);
2700 if (o->op_flags & OPf_KIDS) {
2702 /* First try all the kids at this level, since that's likeliest. */
2703 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2704 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2705 STRLEN kid_label_len;
2706 U32 kid_label_flags;
2707 const char *kid_label = CopLABEL_len_flags(kCOP,
2708 &kid_label_len, &kid_label_flags);
2710 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2713 (const U8*)kid_label, kid_label_len,
2714 (const U8*)label, len) == 0)
2716 (const U8*)label, len,
2717 (const U8*)kid_label, kid_label_len) == 0)
2718 : ( len == kid_label_len && ((kid_label == label)
2719 || memEQ(kid_label, label, len)))))
2723 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2724 if (kid == PL_lastgotoprobe)
2726 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2729 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2730 ops[-1]->op_type == OP_DBSTATE)
2735 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2743 PP(pp_goto) /* also pp_dump */
2749 #define GOTO_DEPTH 64
2750 OP *enterops[GOTO_DEPTH];
2751 const char *label = NULL;
2752 STRLEN label_len = 0;
2753 U32 label_flags = 0;
2754 const bool do_dump = (PL_op->op_type == OP_DUMP);
2755 static const char* const must_have_label = "goto must have label";
2757 if (PL_op->op_flags & OPf_STACKED) {
2758 /* goto EXPR or goto &foo */
2760 SV * const sv = POPs;
2763 /* This egregious kludge implements goto &subroutine */
2764 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2767 CV *cv = MUTABLE_CV(SvRV(sv));
2768 AV *arg = GvAV(PL_defgv);
2772 if (!CvROOT(cv) && !CvXSUB(cv)) {
2773 const GV * const gv = CvGV(cv);
2777 /* autoloaded stub? */
2778 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2780 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2782 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2783 if (autogv && (cv = GvCV(autogv)))
2785 tmpstr = sv_newmortal();
2786 gv_efullname3(tmpstr, gv, NULL);
2787 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2789 DIE(aTHX_ "Goto undefined subroutine");
2792 /* First do some returnish stuff. */
2793 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2795 cxix = dopoptosub(cxstack_ix);
2796 if (cxix < cxstack_ix) {
2799 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2805 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2806 if (CxTYPE(cx) == CXt_EVAL) {
2809 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2810 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2812 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2813 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2815 else if (CxMULTICALL(cx))
2818 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2820 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2821 AV* av = cx->blk_sub.argarray;
2823 /* abandon the original @_ if it got reified or if it is
2824 the same as the current @_ */
2825 if (AvREAL(av) || av == arg) {
2829 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2831 else CLEAR_ARGARRAY(av);
2833 /* We donate this refcount later to the callee’s pad. */
2834 SvREFCNT_inc_simple_void(arg);
2835 if (CxTYPE(cx) == CXt_SUB &&
2836 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2837 SvREFCNT_dec(cx->blk_sub.cv);
2838 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2839 LEAVE_SCOPE(oldsave);
2841 /* A destructor called during LEAVE_SCOPE could have undefined
2842 * our precious cv. See bug #99850. */
2843 if (!CvROOT(cv) && !CvXSUB(cv)) {
2844 const GV * const gv = CvGV(cv);
2847 SV * const tmpstr = sv_newmortal();
2848 gv_efullname3(tmpstr, gv, NULL);
2849 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2852 DIE(aTHX_ "Goto undefined subroutine");
2855 /* Now do some callish stuff. */
2857 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2859 OP* const retop = cx->blk_sub.retop;
2862 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2863 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2866 PERL_UNUSED_VAR(newsp);
2867 PERL_UNUSED_VAR(gimme);
2869 /* put GvAV(defgv) back onto stack */
2871 EXTEND(SP, items+1); /* @_ could have been extended. */
2876 bool r = cBOOL(AvREAL(arg));
2877 for (index=0; index<items; index++)
2881 SV ** const svp = av_fetch(arg, index, 0);
2882 sv = svp ? *svp : NULL;
2884 else sv = AvARRAY(arg)[index];
2886 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2887 : sv_2mortal(newSVavdefelem(arg, index, 1));
2892 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2893 /* Restore old @_ */
2894 arg = GvAV(PL_defgv);
2895 GvAV(PL_defgv) = cx->blk_sub.savearray;
2899 /* XS subs don't have a CxSUB, so pop it */
2900 POPBLOCK(cx, PL_curpm);
2901 /* Push a mark for the start of arglist */
2904 (void)(*CvXSUB(cv))(aTHX_ cv);
2910 PADLIST * const padlist = CvPADLIST(cv);
2911 cx->blk_sub.cv = cv;
2912 cx->blk_sub.olddepth = CvDEPTH(cv);
2915 if (CvDEPTH(cv) < 2)
2916 SvREFCNT_inc_simple_void_NN(cv);
2918 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2919 sub_crush_depth(cv);
2920 pad_push(padlist, CvDEPTH(cv));
2922 PL_curcop = cx->blk_oldcop;
2924 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2927 CX_CURPAD_SAVE(cx->blk_sub);
2929 /* cx->blk_sub.argarray has no reference count, so we
2930 need something to hang on to our argument array so
2931 that cx->blk_sub.argarray does not end up pointing
2932 to freed memory as the result of undef *_. So put
2933 it in the callee’s pad, donating our refer-
2935 SvREFCNT_dec(PAD_SVl(0));
2936 PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2938 /* GvAV(PL_defgv) might have been modified on scope
2939 exit, so restore it. */
2940 if (arg != GvAV(PL_defgv)) {
2941 AV * const av = GvAV(PL_defgv);
2942 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2946 else SvREFCNT_dec(arg);
2947 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2948 Perl_get_db_sub(aTHX_ NULL, cv);
2950 CV * const gotocv = get_cvs("DB::goto", 0);
2952 PUSHMARK( PL_stack_sp );
2953 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2959 RETURNOP(CvSTART(cv));
2964 label = SvPV_nomg_const(sv, label_len);
2965 label_flags = SvUTF8(sv);
2968 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2969 /* goto LABEL or dump LABEL */
2970 label = cPVOP->op_pv;
2971 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2972 label_len = strlen(label);
2974 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2979 OP *gotoprobe = NULL;
2980 bool leaving_eval = FALSE;
2981 bool in_block = FALSE;
2982 PERL_CONTEXT *last_eval_cx = NULL;
2986 PL_lastgotoprobe = NULL;
2988 for (ix = cxstack_ix; ix >= 0; ix--) {
2990 switch (CxTYPE(cx)) {
2992 leaving_eval = TRUE;
2993 if (!CxTRYBLOCK(cx)) {
2994 gotoprobe = (last_eval_cx ?
2995 last_eval_cx->blk_eval.old_eval_root :
3000 /* else fall through */
3001 case CXt_LOOP_LAZYIV:
3002 case CXt_LOOP_LAZYSV:
3004 case CXt_LOOP_PLAIN:
3007 gotoprobe = cx->blk_oldcop->op_sibling;
3013 gotoprobe = cx->blk_oldcop->op_sibling;
3016 gotoprobe = PL_main_root;
3019 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3020 gotoprobe = CvROOT(cx->blk_sub.cv);
3026 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3029 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3030 CxTYPE(cx), (long) ix);
3031 gotoprobe = PL_main_root;
3035 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3036 enterops, enterops + GOTO_DEPTH);
3039 if (gotoprobe->op_sibling &&
3040 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3041 gotoprobe->op_sibling->op_sibling) {
3042 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3043 label, label_len, label_flags, enterops,
3044 enterops + GOTO_DEPTH);
3049 PL_lastgotoprobe = gotoprobe;
3052 DIE(aTHX_ "Can't find label %"UTF8f,
3053 UTF8fARG(label_flags, label_len, label));
3055 /* if we're leaving an eval, check before we pop any frames
3056 that we're not going to punt, otherwise the error
3059 if (leaving_eval && *enterops && enterops[1]) {
3061 for (i = 1; enterops[i]; i++)
3062 if (enterops[i]->op_type == OP_ENTERITER)
3063 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3066 if (*enterops && enterops[1]) {
3067 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3069 deprecate("\"goto\" to jump into a construct");
3072 /* pop unwanted frames */
3074 if (ix < cxstack_ix) {
3081 oldsave = PL_scopestack[PL_scopestack_ix];
3082 LEAVE_SCOPE(oldsave);
3085 /* push wanted frames */
3087 if (*enterops && enterops[1]) {
3088 OP * const oldop = PL_op;
3089 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3090 for (; enterops[ix]; ix++) {
3091 PL_op = enterops[ix];
3092 /* Eventually we may want to stack the needed arguments
3093 * for each op. For now, we punt on the hard ones. */
3094 if (PL_op->op_type == OP_ENTERITER)
3095 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3096 PL_op->op_ppaddr(aTHX);
3104 if (!retop) retop = PL_main_start;
3106 PL_restartop = retop;
3107 PL_do_undump = TRUE;
3111 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3112 PL_do_undump = FALSE;
3128 anum = 0; (void)POPs;
3134 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3137 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3140 PL_exit_flags |= PERL_EXIT_EXPECTED;
3142 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3143 if (anum || !(PL_minus_c && PL_madskills))
3148 PUSHs(&PL_sv_undef);
3155 S_save_lines(pTHX_ AV *array, SV *sv)
3157 const char *s = SvPVX_const(sv);
3158 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3161 PERL_ARGS_ASSERT_SAVE_LINES;
3163 while (s && s < send) {
3165 SV * const tmpstr = newSV_type(SVt_PVMG);
3167 t = (const char *)memchr(s, '\n', send - s);
3173 sv_setpvn(tmpstr, s, t - s);
3174 av_store(array, line++, tmpstr);
3182 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3184 0 is used as continue inside eval,
3186 3 is used for a die caught by an inner eval - continue inner loop
3188 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3189 establish a local jmpenv to handle exception traps.
3194 S_docatch(pTHX_ OP *o)
3198 OP * const oldop = PL_op;
3202 assert(CATCH_GET == TRUE);
3209 assert(cxstack_ix >= 0);
3210 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3211 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3216 /* die caught by an inner eval - continue inner loop */
3217 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3218 PL_restartjmpenv = NULL;
3219 PL_op = PL_restartop;
3228 assert(0); /* NOTREACHED */
3237 =for apidoc find_runcv
3239 Locate the CV corresponding to the currently executing sub or eval.
3240 If db_seqp is non_null, skip CVs that are in the DB package and populate
3241 *db_seqp with the cop sequence number at the point that the DB:: code was
3242 entered. (This allows debuggers to eval in the scope of the breakpoint
3243 rather than in the scope of the debugger itself.)
3249 Perl_find_runcv(pTHX_ U32 *db_seqp)
3251 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3254 /* If this becomes part of the API, it might need a better name. */
3256 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3264 PL_curcop == &PL_compiling
3266 : PL_curcop->cop_seq;
3268 for (si = PL_curstackinfo; si; si = si->si_prev) {
3270 for (ix = si->si_cxix; ix >= 0; ix--) {
3271 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3273 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3274 cv = cx->blk_sub.cv;
3275 /* skip DB:: code */
3276 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3277 *db_seqp = cx->blk_oldcop->cop_seq;
3280 if (cx->cx_type & CXp_SUB_RE)
3283 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3284 cv = cx->blk_eval.cv;
3287 case FIND_RUNCV_padid_eq:
3289 || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
3292 case FIND_RUNCV_level_eq:
3293 if (level++ != arg) continue;
3301 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3305 /* Run yyparse() in a setjmp wrapper. Returns:
3306 * 0: yyparse() successful
3307 * 1: yyparse() failed
3311 S_try_yyparse(pTHX_ int gramtype)
3316 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3320 ret = yyparse(gramtype) ? 1 : 0;
3327 assert(0); /* NOTREACHED */
3334 /* Compile a require/do or an eval ''.
3336 * outside is the lexically enclosing CV (if any) that invoked us.
3337 * seq is the current COP scope value.
3338 * hh is the saved hints hash, if any.
3340 * Returns a bool indicating whether the compile was successful; if so,
3341 * PL_eval_start contains the first op of the compiled code; otherwise,
3344 * This function is called from two places: pp_require and pp_entereval.
3345 * These can be distinguished by whether PL_op is entereval.
3349 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3352 OP * const saveop = PL_op;
3353 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3354 COP * const oldcurcop = PL_curcop;
3355 bool in_require = (saveop->op_type == OP_REQUIRE);
3359 PL_in_eval = (in_require
3360 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3362 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3363 ? EVAL_RE_REPARSING : 0)));
3367 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3369 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3370 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3371 cxstack[cxstack_ix].blk_gimme = gimme;
3373 CvOUTSIDE_SEQ(evalcv) = seq;
3374 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3376 /* set up a scratch pad */
3378 CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3379 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3383 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3385 /* make sure we compile in the right package */
3387 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3388 SAVEGENERICSV(PL_curstash);
3389 PL_curstash = (HV *)CopSTASH(PL_curcop);
3390 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3391 else SvREFCNT_inc_simple_void(PL_curstash);
3393 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3394 SAVESPTR(PL_beginav);
3395 PL_beginav = newAV();
3396 SAVEFREESV(PL_beginav);
3397 SAVESPTR(PL_unitcheckav);
3398 PL_unitcheckav = newAV();
3399 SAVEFREESV(PL_unitcheckav);
3402 SAVEBOOL(PL_madskills);
3406 ENTER_with_name("evalcomp");
3407 SAVESPTR(PL_compcv);
3410 /* try to compile it */
3412 PL_eval_root = NULL;
3413 PL_curcop = &PL_compiling;
3414 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3415 PL_in_eval |= EVAL_KEEPERR;
3422 hv_clear(GvHV(PL_hintgv));
3425 PL_hints = saveop->op_private & OPpEVAL_COPHH
3426 ? oldcurcop->cop_hints : saveop->op_targ;
3428 /* making 'use re eval' not be in scope when compiling the
3429 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3430 * infinite recursion when S_has_runtime_code() gives a false
3431 * positive: the second time round, HINT_RE_EVAL isn't set so we
3432 * don't bother calling S_has_runtime_code() */
3433 if (PL_in_eval & EVAL_RE_REPARSING)
3434 PL_hints &= ~HINT_RE_EVAL;
3437 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3438 SvREFCNT_dec(GvHV(PL_hintgv));
3439 GvHV(PL_hintgv) = hh;
3442 SAVECOMPILEWARNINGS();
3444 if (PL_dowarn & G_WARN_ALL_ON)
3445 PL_compiling.cop_warnings = pWARN_ALL ;
3446 else if (PL_dowarn & G_WARN_ALL_OFF)
3447 PL_compiling.cop_warnings = pWARN_NONE ;
3449 PL_compiling.cop_warnings = pWARN_STD ;
3452 PL_compiling.cop_warnings =
3453 DUP_WARNINGS(oldcurcop->cop_warnings);
3454 cophh_free(CopHINTHASH_get(&PL_compiling));
3455 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3456 /* The label, if present, is the first entry on the chain. So rather
3457 than writing a blank label in front of it (which involves an
3458 allocation), just use the next entry in the chain. */
3459 PL_compiling.cop_hints_hash
3460 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3461 /* Check the assumption that this removed the label. */
3462 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3465 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3468 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3470 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3471 * so honour CATCH_GET and trap it here if necessary */
3473 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3475 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3476 SV **newsp; /* Used by POPBLOCK. */
3478 I32 optype; /* Used by POPEVAL. */
3484 PERL_UNUSED_VAR(newsp);
3485 PERL_UNUSED_VAR(optype);
3487 /* note that if yystatus == 3, then the EVAL CX block has already
3488 * been popped, and various vars restored */
3490 if (yystatus != 3) {
3492 op_free(PL_eval_root);
3493 PL_eval_root = NULL;
3495 SP = PL_stack_base + POPMARK; /* pop original mark */
3496 POPBLOCK(cx,PL_curpm);
3498 namesv = cx->blk_eval.old_namesv;
3499 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3500 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3506 /* If cx is still NULL, it means that we didn't go in the
3507 * POPEVAL branch. */
3508 cx = &cxstack[cxstack_ix];
3509 assert(CxTYPE(cx) == CXt_EVAL);
3510 namesv = cx->blk_eval.old_namesv;
3512 (void)hv_store(GvHVn(PL_incgv),
3513 SvPVX_const(namesv),
3514 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3516 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3519 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3522 if (!*(SvPV_nolen_const(errsv))) {
3523 sv_setpvs(errsv, "Compilation error");
3526 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3531 LEAVE_with_name("evalcomp");
3533 CopLINE_set(&PL_compiling, 0);
3534 SAVEFREEOP(PL_eval_root);
3535 cv_forget_slab(evalcv);
3537 DEBUG_x(dump_eval());
3539 /* Register with debugger: */
3540 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3541 CV * const cv = get_cvs("DB::postponed", 0);
3545 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3547 call_sv(MUTABLE_SV(cv), G_DISCARD);
3551 if (PL_unitcheckav) {
3552 OP *es = PL_eval_start;
3553 call_list(PL_scopestack_ix, PL_unitcheckav);
3557 /* compiled okay, so do it */
3559 CvDEPTH(evalcv) = 1;
3560 SP = PL_stack_base + POPMARK; /* pop original mark */
3561 PL_op = saveop; /* The caller may need it. */
3562 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3569 S_check_type_and_open(pTHX_ SV *name)
3573 const char *p = SvPV_const(name, len);
3576 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3578 /* checking here captures a reasonable error message when
3579 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3580 * user gets a confusing message about looking for the .pmc file
3581 * rather than for the .pm file.
3582 * This check prevents a \0 in @INC causing problems.
3584 if (!IS_SAFE_PATHNAME(p, len, "require"))
3587 /* we use the value of errno later to see how stat() or open() failed.
3588 * We don't want it set if the stat succeeded but we still failed,
3589 * such as if the name exists, but is a directory */
3592 st_rc = PerlLIO_stat(p, &st);
3594 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3598 #if !defined(PERLIO_IS_STDIO)
3599 return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3601 return PerlIO_open(p, PERL_SCRIPT_MODE);
3605 #ifndef PERL_DISABLE_PMC
3607 S_doopen_pm(pTHX_ SV *name)
3610 const char *p = SvPV_const(name, namelen);
3612 PERL_ARGS_ASSERT_DOOPEN_PM;
3614 /* check the name before trying for the .pmc name to avoid the
3615 * warning referring to the .pmc which the user probably doesn't
3616 * know or care about
3618 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3621 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3622 SV *const pmcsv = sv_newmortal();
3625 SvSetSV_nosteal(pmcsv,name);
3626 sv_catpvn(pmcsv, "c", 1);
3628 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3629 return check_type_and_open(pmcsv);
3631 return check_type_and_open(name);
3634 # define doopen_pm(name) check_type_and_open(name)
3635 #endif /* !PERL_DISABLE_PMC */
3637 /* require doesn't search for absolute names, or when the name is
3638 explicity relative the current directory */
3639 PERL_STATIC_INLINE bool
3640 S_path_is_searchable(const char *name)
3642 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3644 if (PERL_FILE_IS_ABSOLUTE(name)
3646 || (*name == '.' && ((name[1] == '/' ||
3647 (name[1] == '.' && name[2] == '/'))
3648 || (name[1] == '\\' ||
3649 ( name[1] == '.' && name[2] == '\\')))
3652 || (*name == '.' && (name[1] == '/' ||
3653 (name[1] == '.' && name[2] == '/')))
3673 int vms_unixname = 0;
3676 const char *tryname = NULL;
3678 const I32 gimme = GIMME_V;
3679 int filter_has_file = 0;
3680 PerlIO *tryrsfp = NULL;
3681 SV *filter_cache = NULL;
3682 SV *filter_state = NULL;
3683 SV *filter_sub = NULL;
3688 bool path_searchable;
3691 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3692 sv = sv_2mortal(new_version(sv));
3693 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3694 upg_version(PL_patchlevel, TRUE);
3695 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3696 if ( vcmp(sv,PL_patchlevel) <= 0 )
3697 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3698 SVfARG(sv_2mortal(vnormal(sv))),
3699 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3703 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3706 SV * const req = SvRV(sv);
3707 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3709 /* get the left hand term */
3710 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3712 first = SvIV(*av_fetch(lav,0,0));
3713 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3714 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3715 || av_len(lav) > 1 /* FP with > 3 digits */
3716 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3718 DIE(aTHX_ "Perl %"SVf" required--this is only "
3720 SVfARG(sv_2mortal(vnormal(req))),
3721 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3724 else { /* probably 'use 5.10' or 'use 5.8' */
3729 second = SvIV(*av_fetch(lav,1,0));
3731 second /= second >= 600 ? 100 : 10;
3732 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3733 (int)first, (int)second);
3734 upg_version(hintsv, TRUE);
3736 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3737 "--this is only %"SVf", stopped",
3738 SVfARG(sv_2mortal(vnormal(req))),
3739 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3740 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3748 name = SvPV_const(sv, len);
3749 if (!(name && len > 0 && *name))
3750 DIE(aTHX_ "Null filename used");
3751 if (!IS_SAFE_PATHNAME(name, len, "require")) {
3752 DIE(aTHX_ "Can't locate %s: %s",
3753 pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3754 SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3757 TAINT_PROPER("require");
3759 path_searchable = path_is_searchable(name);
3762 /* The key in the %ENV hash is in the syntax of file passed as the argument
3763 * usually this is in UNIX format, but sometimes in VMS format, which
3764 * can result in a module being pulled in more than once.
3765 * To prevent this, the key must be stored in UNIX format if the VMS
3766 * name can be translated to UNIX.
3770 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3772 unixlen = strlen(unixname);
3778 /* if not VMS or VMS name can not be translated to UNIX, pass it
3781 unixname = (char *) name;
3784 if (PL_op->op_type == OP_REQUIRE) {
3785 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3786 unixname, unixlen, 0);
3788 if (*svp != &PL_sv_undef)
3791 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3792 "Compilation failed in require", unixname);
3796 LOADING_FILE_PROBE(unixname);
3798 /* prepare to compile file */
3800 if (!path_searchable) {
3801 /* At this point, name is SvPVX(sv) */
3803 tryrsfp = doopen_pm(sv);
3805 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3806 AV * const ar = GvAVn(PL_incgv);
3813 namesv = newSV_type(SVt_PV);
3814 for (i = 0; i <= AvFILL(ar); i++) {
3815 SV * const dirsv = *av_fetch(ar, i, TRUE);
3823 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3824 && !SvOBJECT(SvRV(loader)))
3826 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3830 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3831 PTR2UV(SvRV(dirsv)), name);
3832 tryname = SvPVX_const(namesv);
3835 if (SvPADTMP(nsv)) {
3836 nsv = sv_newmortal();
3837 SvSetSV_nosteal(nsv,sv);
3840 ENTER_with_name("call_INC");
3848 if (SvGMAGICAL(loader)) {
3849 SV *l = sv_newmortal();
3850 sv_setsv_nomg(l, loader);
3853 if (sv_isobject(loader))
3854 count = call_method("INC", G_ARRAY);
3856 count = call_sv(loader, G_ARRAY);
3866 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3867 && !isGV_with_GP(SvRV(arg))) {
3868 filter_cache = SvRV(arg);
3875 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3879 if (isGV_with_GP(arg)) {
3880 IO * const io = GvIO((const GV *)arg);
3885 tryrsfp = IoIFP(io);
3886 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3887 PerlIO_close(IoOFP(io));
3898 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3900 SvREFCNT_inc_simple_void_NN(filter_sub);
3903 filter_state = SP[i];
3904 SvREFCNT_inc_simple_void(filter_state);
3908 if (!tryrsfp && (filter_cache || filter_sub)) {
3909 tryrsfp = PerlIO_open(BIT_BUCKET,
3915 /* FREETMPS may free our filter_cache */
3916 SvREFCNT_inc_simple_void(filter_cache);
3920 LEAVE_with_name("call_INC");
3922 /* Now re-mortalize it. */
3923 sv_2mortal(filter_cache);
3925 /* Adjust file name if the hook has set an %INC entry.
3926 This needs to happen after the FREETMPS above. */
3927 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3929 tryname = SvPV_nolen_const(*svp);
3936 filter_has_file = 0;
3937 filter_cache = NULL;
3939 SvREFCNT_dec(filter_state);
3940 filter_state = NULL;
3943 SvREFCNT_dec(filter_sub);
3948 if (path_searchable) {
3953 dir = SvPV_nomg_const(dirsv, dirlen);
3959 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3963 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3966 sv_setpv(namesv, unixdir);
3967 sv_catpv(namesv, unixname);
3969 # ifdef __SYMBIAN32__
3970 if (PL_origfilename[0] &&
3971 PL_origfilename[1] == ':' &&
3972 !(dir[0] && dir[1] == ':'))
3973 Perl_sv_setpvf(aTHX_ namesv,
3978 Perl_sv_setpvf(aTHX_ namesv,
3982 /* The equivalent of
3983 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3984 but without the need to parse the format string, or
3985 call strlen on either pointer, and with the correct
3986 allocation up front. */
3988 char *tmp = SvGROW(namesv, dirlen + len + 2);
3990 memcpy(tmp, dir, dirlen);
3993 /* Avoid '<dir>//<file>' */
3994 if (!dirlen || *(tmp-1) != '/') {
3998 /* name came from an SV, so it will have a '\0' at the
3999 end that we can copy as part of this memcpy(). */
4000 memcpy(tmp, name, len + 1);
4002 SvCUR_set(namesv, dirlen + len + 1);
4007 TAINT_PROPER("require");
4008 tryname = SvPVX_const(namesv);
4009 tryrsfp = doopen_pm(namesv);
4011 if (tryname[0] == '.' && tryname[1] == '/') {
4013 while (*++tryname == '/') {}
4017 else if (errno == EMFILE || errno == EACCES) {
4018 /* no point in trying other paths if out of handles;
4019 * on the other hand, if we couldn't open one of the
4020 * files, then going on with the search could lead to
4021 * unexpected results; see perl #113422
4030 saved_errno = errno; /* sv_2mortal can realloc things */
4033 if (PL_op->op_type == OP_REQUIRE) {
4034 if(saved_errno == EMFILE || saved_errno == EACCES) {
4035 /* diag_listed_as: Can't locate %s */
4036 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno));
4038 if (namesv) { /* did we lookup @INC? */
4039 AV * const ar = GvAVn(PL_incgv);
4041 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4042 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4043 for (i = 0; i <= AvFILL(ar); i++) {
4044 sv_catpvs(inc, " ");
4045 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4047 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4048 const char *c, *e = name + len - 3;
4049 sv_catpv(msg, " (you may need to install the ");
4050 for (c = name; c < e; c++) {
4052 sv_catpvn(msg, "::", 2);
4055 sv_catpvn(msg, c, 1);
4058 sv_catpv(msg, " module)");
4060 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4061 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4063 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4064 sv_catpv(msg, " (did you run h2ph?)");
4067 /* diag_listed_as: Can't locate %s */
4069 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4073 DIE(aTHX_ "Can't locate %s", name);
4080 SETERRNO(0, SS_NORMAL);
4082 /* Assume success here to prevent recursive requirement. */
4083 /* name is never assigned to again, so len is still strlen(name) */
4084 /* Check whether a hook in @INC has already filled %INC */
4086 (void)hv_store(GvHVn(PL_incgv),
4087 unixname, unixlen, newSVpv(tryname,0),0);
4089 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4091 (void)hv_store(GvHVn(PL_incgv),
4092 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4095 ENTER_with_name("eval");
4097 SAVECOPFILE_FREE(&PL_compiling);
4098 CopFILE_set(&PL_compiling, tryname);
4099 lex_start(NULL, tryrsfp, 0);
4101 if (filter_sub || filter_cache) {
4102 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4103 than hanging another SV from it. In turn, filter_add() optionally
4104 takes the SV to use as the filter (or creates a new SV if passed
4105 NULL), so simply pass in whatever value filter_cache has. */
4106 SV * const fc = filter_cache ? newSV(0) : NULL;
4108 if (fc) sv_copypv(fc, filter_cache);
4109 datasv = filter_add(S_run_user_filter, fc);
4110 IoLINES(datasv) = filter_has_file;
4111 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4112 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4115 /* switch to eval mode */
4116 PUSHBLOCK(cx, CXt_EVAL, SP);
4118 cx->blk_eval.retop = PL_op->op_next;
4120 SAVECOPLINE(&PL_compiling);
4121 CopLINE_set(&PL_compiling, 0);
4125 /* Store and reset encoding. */
4126 encoding = PL_encoding;
4129 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4130 op = DOCATCH(PL_eval_start);
4132 op = PL_op->op_next;
4134 /* Restore encoding. */
4135 PL_encoding = encoding;
4137 LOADED_FILE_PROBE(unixname);
4142 /* This is a op added to hold the hints hash for
4143 pp_entereval. The hash can be modified by the code
4144 being eval'ed, so we return a copy instead. */
4150 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4160 const I32 gimme = GIMME_V;
4161 const U32 was = PL_breakable_sub_gen;
4162 char tbuf[TYPE_DIGITS(long) + 12];
4163 bool saved_delete = FALSE;
4164 char *tmpbuf = tbuf;
4167 U32 seq, lex_flags = 0;
4168 HV *saved_hh = NULL;
4169 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4171 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4172 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4174 else if (PL_hints & HINT_LOCALIZE_HH || (
4175 PL_op->op_private & OPpEVAL_COPHH
4176 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4178 saved_hh = cop_hints_2hv(PL_curcop, 0);
4179 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4183 /* make sure we've got a plain PV (no overload etc) before testing
4184 * for taint. Making a copy here is probably overkill, but better
4185 * safe than sorry */
4187 const char * const p = SvPV_const(sv, len);
4189 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4190 lex_flags |= LEX_START_COPIED;
4192 if (bytes && SvUTF8(sv))
4193 SvPVbyte_force(sv, len);
4195 else if (bytes && SvUTF8(sv)) {
4196 /* Don't modify someone else's scalar */
4199 (void)sv_2mortal(sv);
4200 SvPVbyte_force(sv,len);
4201 lex_flags |= LEX_START_COPIED;
4204 TAINT_IF(SvTAINTED(sv));
4205 TAINT_PROPER("eval");
4207 ENTER_with_name("eval");
4208 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4209 ? LEX_IGNORE_UTF8_HINTS
4210 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4215 /* switch to eval mode */
4217 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4218 SV * const temp_sv = sv_newmortal();
4219 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4220 (unsigned long)++PL_evalseq,
4221 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4222 tmpbuf = SvPVX(temp_sv);
4223 len = SvCUR(temp_sv);
4226 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4227 SAVECOPFILE_FREE(&PL_compiling);
4228 CopFILE_set(&PL_compiling, tmpbuf+2);
4229 SAVECOPLINE(&PL_compiling);
4230 CopLINE_set(&PL_compiling, 1);
4231 /* special case: an eval '' executed within the DB package gets lexically
4232 * placed in the first non-DB CV rather than the current CV - this
4233 * allows the debugger to execute code, find lexicals etc, in the
4234 * scope of the code being debugged. Passing &seq gets find_runcv
4235 * to do the dirty work for us */
4236 runcv = find_runcv(&seq);
4238 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4240 cx->blk_eval.retop = PL_op->op_next;
4242 /* prepare to compile string */
4244 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4245 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4247 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4248 deleting the eval's FILEGV from the stash before gv_check() runs
4249 (i.e. before run-time proper). To work around the coredump that
4250 ensues, we always turn GvMULTI_on for any globals that were
4251 introduced within evals. See force_ident(). GSAR 96-10-12 */
4252 char *const safestr = savepvn(tmpbuf, len);
4253 SAVEDELETE(PL_defstash, safestr, len);
4254 saved_delete = TRUE;
4259 if (doeval(gimme, runcv, seq, saved_hh)) {
4260 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4261 ? (PERLDB_LINE || PERLDB_SAVESRC)
4262 : PERLDB_SAVESRC_NOSUBS) {
4263 /* Retain the filegv we created. */
4264 } else if (!saved_delete) {
4265 char *const safestr = savepvn(tmpbuf, len);
4266 SAVEDELETE(PL_defstash, safestr, len);
4268 return DOCATCH(PL_eval_start);
4270 /* We have already left the scope set up earlier thanks to the LEAVE
4272 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4273 ? (PERLDB_LINE || PERLDB_SAVESRC)
4274 : PERLDB_SAVESRC_INVALID) {
4275 /* Retain the filegv we created. */
4276 } else if (!saved_delete) {
4277 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4279 return PL_op->op_next;
4291 const U8 save_flags = PL_op -> op_flags;
4299 namesv = cx->blk_eval.old_namesv;
4300 retop = cx->blk_eval.retop;
4301 evalcv = cx->blk_eval.cv;
4304 SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4305 gimme, SVs_TEMP, FALSE);
4306 PL_curpm = newpm; /* Don't pop $1 et al till now */
4309 assert(CvDEPTH(evalcv) == 1);
4311 CvDEPTH(evalcv) = 0;
4313 if (optype == OP_REQUIRE &&
4314 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4316 /* Unassume the success we assumed earlier. */
4317 (void)hv_delete(GvHVn(PL_incgv),
4318 SvPVX_const(namesv),
4319 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4321 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4323 /* die_unwind() did LEAVE, or we won't be here */
4326 LEAVE_with_name("eval");
4327 if (!(save_flags & OPf_SPECIAL)) {
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 LEAVE_with_name("eval_scope");
4350 PERL_UNUSED_VAR(newsp);
4351 PERL_UNUSED_VAR(gimme);
4352 PERL_UNUSED_VAR(optype);
4355 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4356 also needed by Perl_fold_constants. */
4358 Perl_create_eval_scope(pTHX_ U32 flags)
4361 const I32 gimme = GIMME_V;
4363 ENTER_with_name("eval_scope");
4366 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4369 PL_in_eval = EVAL_INEVAL;
4370 if (flags & G_KEEPERR)
4371 PL_in_eval |= EVAL_KEEPERR;
4374 if (flags & G_FAKINGEVAL) {
4375 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4383 PERL_CONTEXT * const cx = create_eval_scope(0);
4384 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4385 return DOCATCH(PL_op->op_next);
4400 PERL_UNUSED_VAR(optype);
4403 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
4404 SVs_PADTMP|SVs_TEMP, FALSE);
4405 PL_curpm = newpm; /* Don't pop $1 et al till now */
4407 LEAVE_with_name("eval_scope");
4416 const I32 gimme = GIMME_V;
4418 ENTER_with_name("given");
4421 if (PL_op->op_targ) {
4422 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4423 SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4424 PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4431 PUSHBLOCK(cx, CXt_GIVEN, SP);
4444 PERL_UNUSED_CONTEXT;
4447 assert(CxTYPE(cx) == CXt_GIVEN);
4450 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
4451 SVs_PADTMP|SVs_TEMP, FALSE);
4452 PL_curpm = newpm; /* Don't pop $1 et al till now */
4454 LEAVE_with_name("given");
4458 /* Helper routines used by pp_smartmatch */
4460 S_make_matcher(pTHX_ REGEXP *re)
4463 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4465 PERL_ARGS_ASSERT_MAKE_MATCHER;
4467 PM_SETRE(matcher, ReREFCNT_inc(re));
4469 SAVEFREEOP((OP *) matcher);
4470 ENTER_with_name("matcher"); SAVETMPS;
4476 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4481 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4483 PL_op = (OP *) matcher;
4486 (void) Perl_pp_match(aTHX);
4488 return (SvTRUEx(POPs));
4492 S_destroy_matcher(pTHX_ PMOP *matcher)
4496 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4497 PERL_UNUSED_ARG(matcher);
4500 LEAVE_with_name("matcher");
4503 /* Do a smart match */
4506 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4507 return do_smartmatch(NULL, NULL, 0);
4510 /* This version of do_smartmatch() implements the
4511 * table of smart matches that is found in perlsyn.
4514 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4519 bool object_on_left = FALSE;
4520 SV *e = TOPs; /* e is for 'expression' */
4521 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4523 /* Take care only to invoke mg_get() once for each argument.
4524 * Currently we do this by copying the SV if it's magical. */
4526 if (!copied && SvGMAGICAL(d))
4527 d = sv_mortalcopy(d);
4534 e = sv_mortalcopy(e);
4536 /* First of all, handle overload magic of the rightmost argument */
4539 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4540 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4542 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4549 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4552 SP -= 2; /* Pop the values */
4557 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4564 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4565 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4566 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4568 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4569 object_on_left = TRUE;
4572 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4574 if (object_on_left) {
4575 goto sm_any_sub; /* Treat objects like scalars */
4577 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4578 /* Test sub truth for each key */
4580 bool andedresults = TRUE;
4581 HV *hv = (HV*) SvRV(d);
4582 I32 numkeys = hv_iterinit(hv);
4583 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4586 while ( (he = hv_iternext(hv)) ) {
4587 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4588 ENTER_with_name("smartmatch_hash_key_test");
4591 PUSHs(hv_iterkeysv(he));
4593 c = call_sv(e, G_SCALAR);
4596 andedresults = FALSE;
4598 andedresults = SvTRUEx(POPs) && andedresults;
4600 LEAVE_with_name("smartmatch_hash_key_test");
4607 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4608 /* Test sub truth for each element */
4610 bool andedresults = TRUE;
4611 AV *av = (AV*) SvRV(d);
4612 const I32 len = av_len(av);
4613 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4616 for (i = 0; i <= len; ++i) {
4617 SV * const * const svp = av_fetch(av, i, FALSE);
4618 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4619 ENTER_with_name("smartmatch_array_elem_test");
4625 c = call_sv(e, G_SCALAR);
4628 andedresults = FALSE;
4630 andedresults = SvTRUEx(POPs) && andedresults;
4632 LEAVE_with_name("smartmatch_array_elem_test");
4641 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4642 ENTER_with_name("smartmatch_coderef");
4647 c = call_sv(e, G_SCALAR);
4651 else if (SvTEMP(TOPs))
4652 SvREFCNT_inc_void(TOPs);
4654 LEAVE_with_name("smartmatch_coderef");
4659 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4660 if (object_on_left) {
4661 goto sm_any_hash; /* Treat objects like scalars */
4663 else if (!SvOK(d)) {
4664 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4667 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4668 /* Check that the key-sets are identical */
4670 HV *other_hv = MUTABLE_HV(SvRV(d));
4672 bool other_tied = FALSE;
4673 U32 this_key_count = 0,
4674 other_key_count = 0;
4675 HV *hv = MUTABLE_HV(SvRV(e));
4677 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4678 /* Tied hashes don't know how many keys they have. */
4679 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4682 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4683 HV * const temp = other_hv;
4688 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4691 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4694 /* The hashes have the same number of keys, so it suffices
4695 to check that one is a subset of the other. */
4696 (void) hv_iterinit(hv);
4697 while ( (he = hv_iternext(hv)) ) {
4698 SV *key = hv_iterkeysv(he);
4700 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4703 if(!hv_exists_ent(other_hv, key, 0)) {
4704 (void) hv_iterinit(hv); /* reset iterator */
4710 (void) hv_iterinit(other_hv);
4711 while ( hv_iternext(other_hv) )
4715 other_key_count = HvUSEDKEYS(other_hv);
4717 if (this_key_count != other_key_count)
4722 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4723 AV * const other_av = MUTABLE_AV(SvRV(d));
4724 const SSize_t other_len = av_len(other_av) + 1;
4726 HV *hv = MUTABLE_HV(SvRV(e));
4728 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4729 for (i = 0; i < other_len; ++i) {
4730 SV ** const svp = av_fetch(other_av, i, FALSE);
4731 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4732 if (svp) { /* ??? When can this not happen? */
4733 if (hv_exists_ent(hv, *svp, 0))
4739 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4740 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4743 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4745 HV *hv = MUTABLE_HV(SvRV(e));
4747 (void) hv_iterinit(hv);
4748 while ( (he = hv_iternext(hv)) ) {
4749 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4750 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4751 (void) hv_iterinit(hv);
4752 destroy_matcher(matcher);
4756 destroy_matcher(matcher);
4762 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4763 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4770 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4771 if (object_on_left) {
4772 goto sm_any_array; /* Treat objects like scalars */
4774 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4775 AV * const other_av = MUTABLE_AV(SvRV(e));
4776 const SSize_t other_len = av_len(other_av) + 1;
4779 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4780 for (i = 0; i < other_len; ++i) {
4781 SV ** const svp = av_fetch(other_av, i, FALSE);
4783 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4784 if (svp) { /* ??? When can this not happen? */
4785 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4791 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4792 AV *other_av = MUTABLE_AV(SvRV(d));
4793 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4794 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4798 const SSize_t other_len = av_len(other_av);
4800 if (NULL == seen_this) {
4801 seen_this = newHV();
4802 (void) sv_2mortal(MUTABLE_SV(seen_this));
4804 if (NULL == seen_other) {
4805 seen_other = newHV();
4806 (void) sv_2mortal(MUTABLE_SV(seen_other));
4808 for(i = 0; i <= other_len; ++i) {
4809 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4810 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4812 if (!this_elem || !other_elem) {
4813 if ((this_elem && SvOK(*this_elem))
4814 || (other_elem && SvOK(*other_elem)))
4817 else if (hv_exists_ent(seen_this,
4818 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4819 hv_exists_ent(seen_other,
4820 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4822 if (*this_elem != *other_elem)
4826 (void)hv_store_ent(seen_this,
4827 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4829 (void)hv_store_ent(seen_other,
4830 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4836 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4837 (void) do_smartmatch(seen_this, seen_other, 0);
4839 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4848 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4849 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4852 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4853 const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
4856 for(i = 0; i <= this_len; ++i) {
4857 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4858 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4859 if (svp && matcher_matches_sv(matcher, *svp)) {
4860 destroy_matcher(matcher);
4864 destroy_matcher(matcher);
4868 else if (!SvOK(d)) {
4869 /* undef ~~ array */
4870 const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
4873 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4874 for (i = 0; i <= this_len; ++i) {
4875 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4876 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4877 if (!svp || !SvOK(*svp))
4886 const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
4888 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4889 for (i = 0; i <= this_len; ++i) {
4890 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4897 /* infinite recursion isn't supposed to happen here */
4898 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4899 (void) do_smartmatch(NULL, NULL, 1);
4901 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4910 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4911 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4912 SV *t = d; d = e; e = t;
4913 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4916 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4917 SV *t = d; d = e; e = t;
4918 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4919 goto sm_regex_array;
4922 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4924 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4926 PUSHs(matcher_matches_sv(matcher, d)
4929 destroy_matcher(matcher);
4934 /* See if there is overload magic on left */
4935 else if (object_on_left && SvAMAGIC(d)) {
4937 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4938 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4941 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4949 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4952 else if (!SvOK(d)) {
4953 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4954 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4959 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4960 DEBUG_M(if (SvNIOK(e))
4961 Perl_deb(aTHX_ " applying rule Any-Num\n");
4963 Perl_deb(aTHX_ " applying rule Num-numish\n");
4965 /* numeric comparison */
4968 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4969 (void) Perl_pp_i_eq(aTHX);
4971 (void) Perl_pp_eq(aTHX);
4979 /* As a last resort, use string comparison */
4980 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4983 return Perl_pp_seq(aTHX);
4990 const I32 gimme = GIMME_V;
4992 /* This is essentially an optimization: if the match
4993 fails, we don't want to push a context and then
4994 pop it again right away, so we skip straight
4995 to the op that follows the leavewhen.
4996 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4998 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4999 RETURNOP(cLOGOP->op_other->op_next);
5001 ENTER_with_name("when");
5004 PUSHBLOCK(cx, CXt_WHEN, SP);
5019 cxix = dopoptogiven(cxstack_ix);
5021 /* diag_listed_as: Can't "when" outside a topicalizer */
5022 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5023 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5026 assert(CxTYPE(cx) == CXt_WHEN);
5029 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
5030 SVs_PADTMP|SVs_TEMP, FALSE);
5031 PL_curpm = newpm; /* pop $1 et al */
5033 LEAVE_with_name("when");
5035 if (cxix < cxstack_ix)
5038 cx = &cxstack[cxix];
5040 if (CxFOREACH(cx)) {
5041 /* clear off anything above the scope we're re-entering */
5042 I32 inner = PL_scopestack_ix;
5045 if (PL_scopestack_ix < inner)
5046 leave_scope(PL_scopestack[PL_scopestack_ix]);
5047 PL_curcop = cx->blk_oldcop;
5050 return cx->blk_loop.my_op->op_nextop;
5054 RETURNOP(cx->blk_givwhen.leave_op);
5067 PERL_UNUSED_VAR(gimme);
5069 cxix = dopoptowhen(cxstack_ix);
5071 DIE(aTHX_ "Can't \"continue\" outside a when block");
5073 if (cxix < cxstack_ix)
5077 assert(CxTYPE(cx) == CXt_WHEN);
5080 PL_curpm = newpm; /* pop $1 et al */
5082 LEAVE_with_name("when");
5083 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5092 cxix = dopoptogiven(cxstack_ix);
5094 DIE(aTHX_ "Can't \"break\" outside a given block");
5096 cx = &cxstack[cxix];
5098 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5100 if (cxix < cxstack_ix)
5103 /* Restore the sp at the time we entered the given block */
5106 return cx->blk_givwhen.leave_op;
5110 S_doparseform(pTHX_ SV *sv)
5113 char *s = SvPV(sv, len);
5115 char *base = NULL; /* start of current field */
5116 I32 skipspaces = 0; /* number of contiguous spaces seen */
5117 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5118 bool repeat = FALSE; /* ~~ seen on this line */
5119 bool postspace = FALSE; /* a text field may need right padding */
5122 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5124 bool ischop; /* it's a ^ rather than a @ */
5125 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5126 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5130 PERL_ARGS_ASSERT_DOPARSEFORM;
5133 Perl_croak(aTHX_ "Null picture in formline");
5135 if (SvTYPE(sv) >= SVt_PVMG) {
5136 /* This might, of course, still return NULL. */
5137 mg = mg_find(sv, PERL_MAGIC_fm);
5139 sv_upgrade(sv, SVt_PVMG);
5143 /* still the same as previously-compiled string? */
5144 SV *old = mg->mg_obj;
5145 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5146 && len == SvCUR(old)
5147 && strnEQ(SvPVX(old), SvPVX(sv), len)
5149 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5153 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5154 Safefree(mg->mg_ptr);
5160 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5161 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5164 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5165 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5169 /* estimate the buffer size needed */
5170 for (base = s; s <= send; s++) {
5171 if (*s == '\n' || *s == '@' || *s == '^')
5177 Newx(fops, maxops, U32);
5182 *fpc++ = FF_LINEMARK;
5183 noblank = repeat = FALSE;
5201 case ' ': case '\t':
5208 } /* else FALL THROUGH */
5216 *fpc++ = FF_LITERAL;
5224 *fpc++ = (U32)skipspaces;
5228 *fpc++ = FF_NEWLINE;
5232 arg = fpc - linepc + 1;
5239 *fpc++ = FF_LINEMARK;
5240 noblank = repeat = FALSE;
5249 ischop = s[-1] == '^';
5255 arg = (s - base) - 1;
5257 *fpc++ = FF_LITERAL;
5263 if (*s == '*') { /* @* or ^* */
5265 *fpc++ = 2; /* skip the @* or ^* */
5267 *fpc++ = FF_LINESNGL;
5270 *fpc++ = FF_LINEGLOB;
5272 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5273 arg = ischop ? FORM_NUM_BLANK : 0;
5278 const char * const f = ++s;
5281 arg |= FORM_NUM_POINT + (s - f);
5283 *fpc++ = s - base; /* fieldsize for FETCH */
5284 *fpc++ = FF_DECIMAL;
5286 unchopnum |= ! ischop;
5288 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5289 arg = ischop ? FORM_NUM_BLANK : 0;
5291 s++; /* skip the '0' first */
5295 const char * const f = ++s;
5298 arg |= FORM_NUM_POINT + (s - f);
5300 *fpc++ = s - base; /* fieldsize for FETCH */
5301 *fpc++ = FF_0DECIMAL;
5303 unchopnum |= ! ischop;
5305 else { /* text field */
5307 bool ismore = FALSE;
5310 while (*++s == '>') ;
5311 prespace = FF_SPACE;
5313 else if (*s == '|') {
5314 while (*++s == '|') ;
5315 prespace = FF_HALFSPACE;
5320 while (*++s == '<') ;
5323 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5327 *fpc++ = s - base; /* fieldsize for FETCH */
5329 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5332 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5346 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5349 mg->mg_ptr = (char *) fops;
5350 mg->mg_len = arg * sizeof(U32);
5351 mg->mg_obj = sv_copy;
5352 mg->mg_flags |= MGf_REFCOUNTED;
5354 if (unchopnum && repeat)
5355 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5362 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5364 /* Can value be printed in fldsize chars, using %*.*f ? */
5368 int intsize = fldsize - (value < 0 ? 1 : 0);
5370 if (frcsize & FORM_NUM_POINT)
5372 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5375 while (intsize--) pwr *= 10.0;
5376 while (frcsize--) eps /= 10.0;
5379 if (value + eps >= pwr)
5382 if (value - eps <= -pwr)
5389 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5392 SV * const datasv = FILTER_DATA(idx);
5393 const int filter_has_file = IoLINES(datasv);
5394 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5395 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5400 char *prune_from = NULL;
5401 bool read_from_cache = FALSE;
5405 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5407 assert(maxlen >= 0);
5410 /* I was having segfault trouble under Linux 2.2.5 after a
5411 parse error occured. (Had to hack around it with a test
5412 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5413 not sure where the trouble is yet. XXX */
5416 SV *const cache = datasv;
5419 const char *cache_p = SvPV(cache, cache_len);
5423 /* Running in block mode and we have some cached data already.
5425 if (cache_len >= umaxlen) {
5426 /* In fact, so much data we don't even need to call
5431 const char *const first_nl =
5432 (const char *)memchr(cache_p, '\n', cache_len);
5434 take = first_nl + 1 - cache_p;
5438 sv_catpvn(buf_sv, cache_p, take);
5439 sv_chop(cache, cache_p + take);
5440 /* Definitely not EOF */
5444 sv_catsv(buf_sv, cache);
5446 umaxlen -= cache_len;
5449 read_from_cache = TRUE;
5453 /* Filter API says that the filter appends to the contents of the buffer.
5454 Usually the buffer is "", so the details don't matter. But if it's not,
5455 then clearly what it contains is already filtered by this filter, so we
5456 don't want to pass it in a second time.
5457 I'm going to use a mortal in case the upstream filter croaks. */
5458 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5459 ? sv_newmortal() : buf_sv;
5460 SvUPGRADE(upstream, SVt_PV);
5462 if (filter_has_file) {
5463 status = FILTER_READ(idx+1, upstream, 0);
5466 if (filter_sub && status >= 0) {
5470 ENTER_with_name("call_filter_sub");
5475 DEFSV_set(upstream);
5479 PUSHs(filter_state);
5482 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5492 SV * const errsv = ERRSV;
5493 if (SvTRUE_NN(errsv))
5494 err = newSVsv(errsv);
5500 LEAVE_with_name("call_filter_sub");
5503 if (SvGMAGICAL(upstream)) {
5505 if (upstream == buf_sv) mg_free(buf_sv);
5507 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5508 if(!err && SvOK(upstream)) {
5509 got_p = SvPV_nomg(upstream, got_len);
5511 if (got_len > umaxlen) {
5512 prune_from = got_p + umaxlen;
5515 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5516 if (first_nl && first_nl + 1 < got_p + got_len) {
5517 /* There's a second line here... */
5518 prune_from = first_nl + 1;
5522 if (!err && prune_from) {
5523 /* Oh. Too long. Stuff some in our cache. */
5524 STRLEN cached_len = got_p + got_len - prune_from;
5525 SV *const cache = datasv;
5528 /* Cache should be empty. */
5529 assert(!SvCUR(cache));
5532 sv_setpvn(cache, prune_from, cached_len);
5533 /* If you ask for block mode, you may well split UTF-8 characters.
5534 "If it breaks, you get to keep both parts"
5535 (Your code is broken if you don't put them back together again
5536 before something notices.) */
5537 if (SvUTF8(upstream)) {
5540 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5542 /* Cannot just use sv_setpvn, as that could free the buffer
5543 before we have a chance to assign it. */
5544 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5545 got_len - cached_len);
5547 /* Can't yet be EOF */
5552 /* If they are at EOF but buf_sv has something in it, then they may never
5553 have touched the SV upstream, so it may be undefined. If we naively
5554 concatenate it then we get a warning about use of uninitialised value.
5556 if (!err && upstream != buf_sv &&
5558 sv_catsv_nomg(buf_sv, upstream);
5560 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5563 IoLINES(datasv) = 0;
5565 SvREFCNT_dec(filter_state);
5566 IoTOP_GV(datasv) = NULL;
5569 SvREFCNT_dec(filter_sub);
5570 IoBOTTOM_GV(datasv) = NULL;
5572 filter_del(S_run_user_filter);
5578 if (status == 0 && read_from_cache) {
5579 /* If we read some data from the cache (and by getting here it implies
5580 that we emptied the cache) then we aren't yet at EOF, and mustn't
5581 report that to our caller. */
5589 * c-indentation-style: bsd
5591 * indent-tabs-mode: nil
5594 * ex: set ts=8 sts=4 sw=4 et: