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 STORE_NUMERIC_STANDARD_SET_LOCAL();
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_NUMERIC_STANDARD();
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. (allows debuggers to eval in the scope of the breakpoint rather
3243 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) && !defined(USE_SFIO)
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;
3678 const char *tryname = NULL;
3680 const I32 gimme = GIMME_V;
3681 int filter_has_file = 0;
3682 PerlIO *tryrsfp = NULL;
3683 SV *filter_cache = NULL;
3684 SV *filter_state = NULL;
3685 SV *filter_sub = NULL;
3690 bool path_searchable;
3693 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3694 sv = sv_2mortal(new_version(sv));
3695 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3696 upg_version(PL_patchlevel, TRUE);
3697 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3698 if ( vcmp(sv,PL_patchlevel) <= 0 )
3699 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3700 SVfARG(sv_2mortal(vnormal(sv))),
3701 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3705 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3708 SV * const req = SvRV(sv);
3709 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3711 /* get the left hand term */
3712 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3714 first = SvIV(*av_fetch(lav,0,0));
3715 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3716 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3717 || av_len(lav) > 1 /* FP with > 3 digits */
3718 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3720 DIE(aTHX_ "Perl %"SVf" required--this is only "
3722 SVfARG(sv_2mortal(vnormal(req))),
3723 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3726 else { /* probably 'use 5.10' or 'use 5.8' */
3731 second = SvIV(*av_fetch(lav,1,0));
3733 second /= second >= 600 ? 100 : 10;
3734 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3735 (int)first, (int)second);
3736 upg_version(hintsv, TRUE);
3738 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3739 "--this is only %"SVf", stopped",
3740 SVfARG(sv_2mortal(vnormal(req))),
3741 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3742 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3750 name = SvPV_const(sv, len);
3751 if (!(name && len > 0 && *name))
3752 DIE(aTHX_ "Null filename used");
3753 if (!IS_SAFE_PATHNAME(name, len, "require")) {
3754 DIE(aTHX_ "Can't locate %s: %s",
3755 pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3756 SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3759 TAINT_PROPER("require");
3761 path_searchable = path_is_searchable(name);
3764 /* The key in the %ENV hash is in the syntax of file passed as the argument
3765 * usually this is in UNIX format, but sometimes in VMS format, which
3766 * can result in a module being pulled in more than once.
3767 * To prevent this, the key must be stored in UNIX format if the VMS
3768 * name can be translated to UNIX.
3771 if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))
3772 && (unixname = tounixspec(name, unixnamebuf)) != NULL) {
3773 unixlen = strlen(unixname);
3779 /* if not VMS or VMS name can not be translated to UNIX, pass it
3782 unixname = (char *) name;
3785 if (PL_op->op_type == OP_REQUIRE) {
3786 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3787 unixname, unixlen, 0);
3789 if (*svp != &PL_sv_undef)
3792 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3793 "Compilation failed in require", unixname);
3797 LOADING_FILE_PROBE(unixname);
3799 /* prepare to compile file */
3801 if (!path_searchable) {
3802 /* At this point, name is SvPVX(sv) */
3804 tryrsfp = doopen_pm(sv);
3806 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3807 AV * const ar = GvAVn(PL_incgv);
3814 namesv = newSV_type(SVt_PV);
3815 for (i = 0; i <= AvFILL(ar); i++) {
3816 SV * const dirsv = *av_fetch(ar, i, TRUE);
3818 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3825 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3826 && !sv_isobject(loader))
3828 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3831 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3832 PTR2UV(SvRV(dirsv)), name);
3833 tryname = SvPVX_const(namesv);
3836 ENTER_with_name("call_INC");
3838 if (SvPADTMP(nsv)) {
3839 nsv = sv_newmortal();
3840 SvSetSV_nosteal(nsv,sv);
3848 if (sv_isobject(loader))
3849 count = call_method("INC", G_ARRAY);
3851 count = call_sv(loader, G_ARRAY);
3861 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3862 && !isGV_with_GP(SvRV(arg))) {
3863 filter_cache = SvRV(arg);
3870 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3874 if (isGV_with_GP(arg)) {
3875 IO * const io = GvIO((const GV *)arg);
3880 tryrsfp = IoIFP(io);
3881 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3882 PerlIO_close(IoOFP(io));
3893 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3895 SvREFCNT_inc_simple_void_NN(filter_sub);
3898 filter_state = SP[i];
3899 SvREFCNT_inc_simple_void(filter_state);
3903 if (!tryrsfp && (filter_cache || filter_sub)) {
3904 tryrsfp = PerlIO_open(BIT_BUCKET,
3910 /* FREETMPS may free our filter_cache */
3911 SvREFCNT_inc_simple_void(filter_cache);
3915 LEAVE_with_name("call_INC");
3917 /* Now re-mortalize it. */
3918 sv_2mortal(filter_cache);
3920 /* Adjust file name if the hook has set an %INC entry.
3921 This needs to happen after the FREETMPS above. */
3922 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3924 tryname = SvPV_nolen_const(*svp);
3931 filter_has_file = 0;
3932 filter_cache = NULL;
3934 SvREFCNT_dec(filter_state);
3935 filter_state = NULL;
3938 SvREFCNT_dec(filter_sub);
3943 if (path_searchable) {
3948 dir = SvPV_const(dirsv, dirlen);
3954 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3957 if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL)
3958 || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL))
3960 sv_setpv(namesv, unixdir);
3961 sv_catpv(namesv, unixname);
3963 # ifdef __SYMBIAN32__
3964 if (PL_origfilename[0] &&
3965 PL_origfilename[1] == ':' &&
3966 !(dir[0] && dir[1] == ':'))
3967 Perl_sv_setpvf(aTHX_ namesv,
3972 Perl_sv_setpvf(aTHX_ namesv,
3976 /* The equivalent of
3977 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3978 but without the need to parse the format string, or
3979 call strlen on either pointer, and with the correct
3980 allocation up front. */
3982 char *tmp = SvGROW(namesv, dirlen + len + 2);
3984 memcpy(tmp, dir, dirlen);
3987 /* Avoid '<dir>//<file>' */
3988 if (!dirlen || *(tmp-1) != '/') {
3992 /* name came from an SV, so it will have a '\0' at the
3993 end that we can copy as part of this memcpy(). */
3994 memcpy(tmp, name, len + 1);
3996 SvCUR_set(namesv, dirlen + len + 1);
4001 TAINT_PROPER("require");
4002 tryname = SvPVX_const(namesv);
4003 tryrsfp = doopen_pm(namesv);
4005 if (tryname[0] == '.' && tryname[1] == '/') {
4007 while (*++tryname == '/') {}
4011 else if (errno == EMFILE || errno == EACCES) {
4012 /* no point in trying other paths if out of handles;
4013 * on the other hand, if we couldn't open one of the
4014 * files, then going on with the search could lead to
4015 * unexpected results; see perl #113422
4024 saved_errno = errno; /* sv_2mortal can realloc things */
4027 if (PL_op->op_type == OP_REQUIRE) {
4028 if(saved_errno == EMFILE || saved_errno == EACCES) {
4029 /* diag_listed_as: Can't locate %s */
4030 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno));
4032 if (namesv) { /* did we lookup @INC? */
4033 AV * const ar = GvAVn(PL_incgv);
4035 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4036 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4037 for (i = 0; i <= AvFILL(ar); i++) {
4038 sv_catpvs(inc, " ");
4039 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4041 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4042 const char *c, *e = name + len - 3;
4043 sv_catpv(msg, " (you may need to install the ");
4044 for (c = name; c < e; c++) {
4046 sv_catpvn(msg, "::", 2);
4049 sv_catpvn(msg, c, 1);
4052 sv_catpv(msg, " module)");
4054 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4055 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4057 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4058 sv_catpv(msg, " (did you run h2ph?)");
4061 /* diag_listed_as: Can't locate %s */
4063 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4067 DIE(aTHX_ "Can't locate %s", name);
4074 SETERRNO(0, SS_NORMAL);
4076 /* Assume success here to prevent recursive requirement. */
4077 /* name is never assigned to again, so len is still strlen(name) */
4078 /* Check whether a hook in @INC has already filled %INC */
4080 (void)hv_store(GvHVn(PL_incgv),
4081 unixname, unixlen, newSVpv(tryname,0),0);
4083 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4085 (void)hv_store(GvHVn(PL_incgv),
4086 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4089 ENTER_with_name("eval");
4091 SAVECOPFILE_FREE(&PL_compiling);
4092 CopFILE_set(&PL_compiling, tryname);
4093 lex_start(NULL, tryrsfp, 0);
4095 if (filter_sub || filter_cache) {
4096 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4097 than hanging another SV from it. In turn, filter_add() optionally
4098 takes the SV to use as the filter (or creates a new SV if passed
4099 NULL), so simply pass in whatever value filter_cache has. */
4100 SV * const fc = filter_cache ? newSV(0) : NULL;
4102 if (fc) sv_copypv(fc, filter_cache);
4103 datasv = filter_add(S_run_user_filter, fc);
4104 IoLINES(datasv) = filter_has_file;
4105 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4106 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4109 /* switch to eval mode */
4110 PUSHBLOCK(cx, CXt_EVAL, SP);
4112 cx->blk_eval.retop = PL_op->op_next;
4114 SAVECOPLINE(&PL_compiling);
4115 CopLINE_set(&PL_compiling, 0);
4119 /* Store and reset encoding. */
4120 encoding = PL_encoding;
4123 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4124 op = DOCATCH(PL_eval_start);
4126 op = PL_op->op_next;
4128 /* Restore encoding. */
4129 PL_encoding = encoding;
4131 LOADED_FILE_PROBE(unixname);
4136 /* This is a op added to hold the hints hash for
4137 pp_entereval. The hash can be modified by the code
4138 being eval'ed, so we return a copy instead. */
4144 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4154 const I32 gimme = GIMME_V;
4155 const U32 was = PL_breakable_sub_gen;
4156 char tbuf[TYPE_DIGITS(long) + 12];
4157 bool saved_delete = FALSE;
4158 char *tmpbuf = tbuf;
4161 U32 seq, lex_flags = 0;
4162 HV *saved_hh = NULL;
4163 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4165 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4166 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4168 else if (PL_hints & HINT_LOCALIZE_HH || (
4169 PL_op->op_private & OPpEVAL_COPHH
4170 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4172 saved_hh = cop_hints_2hv(PL_curcop, 0);
4173 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4177 /* make sure we've got a plain PV (no overload etc) before testing
4178 * for taint. Making a copy here is probably overkill, but better
4179 * safe than sorry */
4181 const char * const p = SvPV_const(sv, len);
4183 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4184 lex_flags |= LEX_START_COPIED;
4186 if (bytes && SvUTF8(sv))
4187 SvPVbyte_force(sv, len);
4189 else if (bytes && SvUTF8(sv)) {
4190 /* Don't modify someone else's scalar */
4193 (void)sv_2mortal(sv);
4194 SvPVbyte_force(sv,len);
4195 lex_flags |= LEX_START_COPIED;
4198 TAINT_IF(SvTAINTED(sv));
4199 TAINT_PROPER("eval");
4201 ENTER_with_name("eval");
4202 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4203 ? LEX_IGNORE_UTF8_HINTS
4204 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4209 /* switch to eval mode */
4211 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4212 SV * const temp_sv = sv_newmortal();
4213 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4214 (unsigned long)++PL_evalseq,
4215 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4216 tmpbuf = SvPVX(temp_sv);
4217 len = SvCUR(temp_sv);
4220 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4221 SAVECOPFILE_FREE(&PL_compiling);
4222 CopFILE_set(&PL_compiling, tmpbuf+2);
4223 SAVECOPLINE(&PL_compiling);
4224 CopLINE_set(&PL_compiling, 1);
4225 /* special case: an eval '' executed within the DB package gets lexically
4226 * placed in the first non-DB CV rather than the current CV - this
4227 * allows the debugger to execute code, find lexicals etc, in the
4228 * scope of the code being debugged. Passing &seq gets find_runcv
4229 * to do the dirty work for us */
4230 runcv = find_runcv(&seq);
4232 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4234 cx->blk_eval.retop = PL_op->op_next;
4236 /* prepare to compile string */
4238 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4239 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4241 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4242 deleting the eval's FILEGV from the stash before gv_check() runs
4243 (i.e. before run-time proper). To work around the coredump that
4244 ensues, we always turn GvMULTI_on for any globals that were
4245 introduced within evals. See force_ident(). GSAR 96-10-12 */
4246 char *const safestr = savepvn(tmpbuf, len);
4247 SAVEDELETE(PL_defstash, safestr, len);
4248 saved_delete = TRUE;
4253 if (doeval(gimme, runcv, seq, saved_hh)) {
4254 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4255 ? (PERLDB_LINE || PERLDB_SAVESRC)
4256 : PERLDB_SAVESRC_NOSUBS) {
4257 /* Retain the filegv we created. */
4258 } else if (!saved_delete) {
4259 char *const safestr = savepvn(tmpbuf, len);
4260 SAVEDELETE(PL_defstash, safestr, len);
4262 return DOCATCH(PL_eval_start);
4264 /* We have already left the scope set up earlier thanks to the LEAVE
4266 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4267 ? (PERLDB_LINE || PERLDB_SAVESRC)
4268 : PERLDB_SAVESRC_INVALID) {
4269 /* Retain the filegv we created. */
4270 } else if (!saved_delete) {
4271 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4273 return PL_op->op_next;
4285 const U8 save_flags = PL_op -> op_flags;
4293 namesv = cx->blk_eval.old_namesv;
4294 retop = cx->blk_eval.retop;
4295 evalcv = cx->blk_eval.cv;
4298 SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4299 gimme, SVs_TEMP, FALSE);
4300 PL_curpm = newpm; /* Don't pop $1 et al till now */
4303 assert(CvDEPTH(evalcv) == 1);
4305 CvDEPTH(evalcv) = 0;
4307 if (optype == OP_REQUIRE &&
4308 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4310 /* Unassume the success we assumed earlier. */
4311 (void)hv_delete(GvHVn(PL_incgv),
4312 SvPVX_const(namesv),
4313 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4315 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4317 /* die_unwind() did LEAVE, or we won't be here */
4320 LEAVE_with_name("eval");
4321 if (!(save_flags & OPf_SPECIAL)) {
4329 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4330 close to the related Perl_create_eval_scope. */
4332 Perl_delete_eval_scope(pTHX)
4343 LEAVE_with_name("eval_scope");
4344 PERL_UNUSED_VAR(newsp);
4345 PERL_UNUSED_VAR(gimme);
4346 PERL_UNUSED_VAR(optype);
4349 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4350 also needed by Perl_fold_constants. */
4352 Perl_create_eval_scope(pTHX_ U32 flags)
4355 const I32 gimme = GIMME_V;
4357 ENTER_with_name("eval_scope");
4360 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4363 PL_in_eval = EVAL_INEVAL;
4364 if (flags & G_KEEPERR)
4365 PL_in_eval |= EVAL_KEEPERR;
4368 if (flags & G_FAKINGEVAL) {
4369 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4377 PERL_CONTEXT * const cx = create_eval_scope(0);
4378 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4379 return DOCATCH(PL_op->op_next);
4394 PERL_UNUSED_VAR(optype);
4397 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
4398 SVs_PADTMP|SVs_TEMP, FALSE);
4399 PL_curpm = newpm; /* Don't pop $1 et al till now */
4401 LEAVE_with_name("eval_scope");
4410 const I32 gimme = GIMME_V;
4412 ENTER_with_name("given");
4415 if (PL_op->op_targ) {
4416 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4417 SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4418 PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4425 PUSHBLOCK(cx, CXt_GIVEN, SP);
4438 PERL_UNUSED_CONTEXT;
4441 assert(CxTYPE(cx) == CXt_GIVEN);
4444 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
4445 SVs_PADTMP|SVs_TEMP, FALSE);
4446 PL_curpm = newpm; /* Don't pop $1 et al till now */
4448 LEAVE_with_name("given");
4452 /* Helper routines used by pp_smartmatch */
4454 S_make_matcher(pTHX_ REGEXP *re)
4457 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4459 PERL_ARGS_ASSERT_MAKE_MATCHER;
4461 PM_SETRE(matcher, ReREFCNT_inc(re));
4463 SAVEFREEOP((OP *) matcher);
4464 ENTER_with_name("matcher"); SAVETMPS;
4470 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4475 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4477 PL_op = (OP *) matcher;
4480 (void) Perl_pp_match(aTHX);
4482 return (SvTRUEx(POPs));
4486 S_destroy_matcher(pTHX_ PMOP *matcher)
4490 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4491 PERL_UNUSED_ARG(matcher);
4494 LEAVE_with_name("matcher");
4497 /* Do a smart match */
4500 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4501 return do_smartmatch(NULL, NULL, 0);
4504 /* This version of do_smartmatch() implements the
4505 * table of smart matches that is found in perlsyn.
4508 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4513 bool object_on_left = FALSE;
4514 SV *e = TOPs; /* e is for 'expression' */
4515 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4517 /* Take care only to invoke mg_get() once for each argument.
4518 * Currently we do this by copying the SV if it's magical. */
4520 if (!copied && SvGMAGICAL(d))
4521 d = sv_mortalcopy(d);
4528 e = sv_mortalcopy(e);
4530 /* First of all, handle overload magic of the rightmost argument */
4533 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4534 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4536 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4543 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4546 SP -= 2; /* Pop the values */
4551 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4558 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4559 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4560 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4562 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4563 object_on_left = TRUE;
4566 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4568 if (object_on_left) {
4569 goto sm_any_sub; /* Treat objects like scalars */
4571 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4572 /* Test sub truth for each key */
4574 bool andedresults = TRUE;
4575 HV *hv = (HV*) SvRV(d);
4576 I32 numkeys = hv_iterinit(hv);
4577 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4580 while ( (he = hv_iternext(hv)) ) {
4581 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4582 ENTER_with_name("smartmatch_hash_key_test");
4585 PUSHs(hv_iterkeysv(he));
4587 c = call_sv(e, G_SCALAR);
4590 andedresults = FALSE;
4592 andedresults = SvTRUEx(POPs) && andedresults;
4594 LEAVE_with_name("smartmatch_hash_key_test");
4601 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4602 /* Test sub truth for each element */
4604 bool andedresults = TRUE;
4605 AV *av = (AV*) SvRV(d);
4606 const I32 len = av_len(av);
4607 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4610 for (i = 0; i <= len; ++i) {
4611 SV * const * const svp = av_fetch(av, i, FALSE);
4612 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4613 ENTER_with_name("smartmatch_array_elem_test");
4619 c = call_sv(e, G_SCALAR);
4622 andedresults = FALSE;
4624 andedresults = SvTRUEx(POPs) && andedresults;
4626 LEAVE_with_name("smartmatch_array_elem_test");
4635 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4636 ENTER_with_name("smartmatch_coderef");
4641 c = call_sv(e, G_SCALAR);
4645 else if (SvTEMP(TOPs))
4646 SvREFCNT_inc_void(TOPs);
4648 LEAVE_with_name("smartmatch_coderef");
4653 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4654 if (object_on_left) {
4655 goto sm_any_hash; /* Treat objects like scalars */
4657 else if (!SvOK(d)) {
4658 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4661 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4662 /* Check that the key-sets are identical */
4664 HV *other_hv = MUTABLE_HV(SvRV(d));
4666 bool other_tied = FALSE;
4667 U32 this_key_count = 0,
4668 other_key_count = 0;
4669 HV *hv = MUTABLE_HV(SvRV(e));
4671 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4672 /* Tied hashes don't know how many keys they have. */
4673 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4676 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4677 HV * const temp = other_hv;
4682 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4685 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4688 /* The hashes have the same number of keys, so it suffices
4689 to check that one is a subset of the other. */
4690 (void) hv_iterinit(hv);
4691 while ( (he = hv_iternext(hv)) ) {
4692 SV *key = hv_iterkeysv(he);
4694 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4697 if(!hv_exists_ent(other_hv, key, 0)) {
4698 (void) hv_iterinit(hv); /* reset iterator */
4704 (void) hv_iterinit(other_hv);
4705 while ( hv_iternext(other_hv) )
4709 other_key_count = HvUSEDKEYS(other_hv);
4711 if (this_key_count != other_key_count)
4716 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4717 AV * const other_av = MUTABLE_AV(SvRV(d));
4718 const SSize_t other_len = av_len(other_av) + 1;
4720 HV *hv = MUTABLE_HV(SvRV(e));
4722 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4723 for (i = 0; i < other_len; ++i) {
4724 SV ** const svp = av_fetch(other_av, i, FALSE);
4725 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4726 if (svp) { /* ??? When can this not happen? */
4727 if (hv_exists_ent(hv, *svp, 0))
4733 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4734 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4737 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4739 HV *hv = MUTABLE_HV(SvRV(e));
4741 (void) hv_iterinit(hv);
4742 while ( (he = hv_iternext(hv)) ) {
4743 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4744 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4745 (void) hv_iterinit(hv);
4746 destroy_matcher(matcher);
4750 destroy_matcher(matcher);
4756 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4757 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4764 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4765 if (object_on_left) {
4766 goto sm_any_array; /* Treat objects like scalars */
4768 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4769 AV * const other_av = MUTABLE_AV(SvRV(e));
4770 const SSize_t other_len = av_len(other_av) + 1;
4773 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4774 for (i = 0; i < other_len; ++i) {
4775 SV ** const svp = av_fetch(other_av, i, FALSE);
4777 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4778 if (svp) { /* ??? When can this not happen? */
4779 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4785 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4786 AV *other_av = MUTABLE_AV(SvRV(d));
4787 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4788 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4792 const SSize_t other_len = av_len(other_av);
4794 if (NULL == seen_this) {
4795 seen_this = newHV();
4796 (void) sv_2mortal(MUTABLE_SV(seen_this));
4798 if (NULL == seen_other) {
4799 seen_other = newHV();
4800 (void) sv_2mortal(MUTABLE_SV(seen_other));
4802 for(i = 0; i <= other_len; ++i) {
4803 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4804 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4806 if (!this_elem || !other_elem) {
4807 if ((this_elem && SvOK(*this_elem))
4808 || (other_elem && SvOK(*other_elem)))
4811 else if (hv_exists_ent(seen_this,
4812 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4813 hv_exists_ent(seen_other,
4814 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4816 if (*this_elem != *other_elem)
4820 (void)hv_store_ent(seen_this,
4821 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4823 (void)hv_store_ent(seen_other,
4824 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4830 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4831 (void) do_smartmatch(seen_this, seen_other, 0);
4833 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4842 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4843 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4846 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4847 const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
4850 for(i = 0; i <= this_len; ++i) {
4851 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4852 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4853 if (svp && matcher_matches_sv(matcher, *svp)) {
4854 destroy_matcher(matcher);
4858 destroy_matcher(matcher);
4862 else if (!SvOK(d)) {
4863 /* undef ~~ array */
4864 const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
4867 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4868 for (i = 0; i <= this_len; ++i) {
4869 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4870 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4871 if (!svp || !SvOK(*svp))
4880 const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
4882 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4883 for (i = 0; i <= this_len; ++i) {
4884 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4891 /* infinite recursion isn't supposed to happen here */
4892 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4893 (void) do_smartmatch(NULL, NULL, 1);
4895 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4904 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4905 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4906 SV *t = d; d = e; e = t;
4907 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4910 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4911 SV *t = d; d = e; e = t;
4912 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4913 goto sm_regex_array;
4916 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4918 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4920 PUSHs(matcher_matches_sv(matcher, d)
4923 destroy_matcher(matcher);
4928 /* See if there is overload magic on left */
4929 else if (object_on_left && SvAMAGIC(d)) {
4931 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4932 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4935 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4943 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4946 else if (!SvOK(d)) {
4947 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4948 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4953 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4954 DEBUG_M(if (SvNIOK(e))
4955 Perl_deb(aTHX_ " applying rule Any-Num\n");
4957 Perl_deb(aTHX_ " applying rule Num-numish\n");
4959 /* numeric comparison */
4962 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4963 (void) Perl_pp_i_eq(aTHX);
4965 (void) Perl_pp_eq(aTHX);
4973 /* As a last resort, use string comparison */
4974 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4977 return Perl_pp_seq(aTHX);
4984 const I32 gimme = GIMME_V;
4986 /* This is essentially an optimization: if the match
4987 fails, we don't want to push a context and then
4988 pop it again right away, so we skip straight
4989 to the op that follows the leavewhen.
4990 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4992 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4993 RETURNOP(cLOGOP->op_other->op_next);
4995 ENTER_with_name("when");
4998 PUSHBLOCK(cx, CXt_WHEN, SP);
5013 cxix = dopoptogiven(cxstack_ix);
5015 /* diag_listed_as: Can't "when" outside a topicalizer */
5016 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5017 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5020 assert(CxTYPE(cx) == CXt_WHEN);
5023 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
5024 SVs_PADTMP|SVs_TEMP, FALSE);
5025 PL_curpm = newpm; /* pop $1 et al */
5027 LEAVE_with_name("when");
5029 if (cxix < cxstack_ix)
5032 cx = &cxstack[cxix];
5034 if (CxFOREACH(cx)) {
5035 /* clear off anything above the scope we're re-entering */
5036 I32 inner = PL_scopestack_ix;
5039 if (PL_scopestack_ix < inner)
5040 leave_scope(PL_scopestack[PL_scopestack_ix]);
5041 PL_curcop = cx->blk_oldcop;
5044 return cx->blk_loop.my_op->op_nextop;
5048 RETURNOP(cx->blk_givwhen.leave_op);
5061 PERL_UNUSED_VAR(gimme);
5063 cxix = dopoptowhen(cxstack_ix);
5065 DIE(aTHX_ "Can't \"continue\" outside a when block");
5067 if (cxix < cxstack_ix)
5071 assert(CxTYPE(cx) == CXt_WHEN);
5074 PL_curpm = newpm; /* pop $1 et al */
5076 LEAVE_with_name("when");
5077 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5086 cxix = dopoptogiven(cxstack_ix);
5088 DIE(aTHX_ "Can't \"break\" outside a given block");
5090 cx = &cxstack[cxix];
5092 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5094 if (cxix < cxstack_ix)
5097 /* Restore the sp at the time we entered the given block */
5100 return cx->blk_givwhen.leave_op;
5104 S_doparseform(pTHX_ SV *sv)
5107 char *s = SvPV(sv, len);
5109 char *base = NULL; /* start of current field */
5110 I32 skipspaces = 0; /* number of contiguous spaces seen */
5111 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5112 bool repeat = FALSE; /* ~~ seen on this line */
5113 bool postspace = FALSE; /* a text field may need right padding */
5116 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5118 bool ischop; /* it's a ^ rather than a @ */
5119 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5120 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5124 PERL_ARGS_ASSERT_DOPARSEFORM;
5127 Perl_croak(aTHX_ "Null picture in formline");
5129 if (SvTYPE(sv) >= SVt_PVMG) {
5130 /* This might, of course, still return NULL. */
5131 mg = mg_find(sv, PERL_MAGIC_fm);
5133 sv_upgrade(sv, SVt_PVMG);
5137 /* still the same as previously-compiled string? */
5138 SV *old = mg->mg_obj;
5139 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5140 && len == SvCUR(old)
5141 && strnEQ(SvPVX(old), SvPVX(sv), len)
5143 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5147 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5148 Safefree(mg->mg_ptr);
5154 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5155 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5158 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5159 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5163 /* estimate the buffer size needed */
5164 for (base = s; s <= send; s++) {
5165 if (*s == '\n' || *s == '@' || *s == '^')
5171 Newx(fops, maxops, U32);
5176 *fpc++ = FF_LINEMARK;
5177 noblank = repeat = FALSE;
5195 case ' ': case '\t':
5202 } /* else FALL THROUGH */
5210 *fpc++ = FF_LITERAL;
5218 *fpc++ = (U32)skipspaces;
5222 *fpc++ = FF_NEWLINE;
5226 arg = fpc - linepc + 1;
5233 *fpc++ = FF_LINEMARK;
5234 noblank = repeat = FALSE;
5243 ischop = s[-1] == '^';
5249 arg = (s - base) - 1;
5251 *fpc++ = FF_LITERAL;
5257 if (*s == '*') { /* @* or ^* */
5259 *fpc++ = 2; /* skip the @* or ^* */
5261 *fpc++ = FF_LINESNGL;
5264 *fpc++ = FF_LINEGLOB;
5266 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5267 arg = ischop ? FORM_NUM_BLANK : 0;
5272 const char * const f = ++s;
5275 arg |= FORM_NUM_POINT + (s - f);
5277 *fpc++ = s - base; /* fieldsize for FETCH */
5278 *fpc++ = FF_DECIMAL;
5280 unchopnum |= ! ischop;
5282 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5283 arg = ischop ? FORM_NUM_BLANK : 0;
5285 s++; /* skip the '0' first */
5289 const char * const f = ++s;
5292 arg |= FORM_NUM_POINT + (s - f);
5294 *fpc++ = s - base; /* fieldsize for FETCH */
5295 *fpc++ = FF_0DECIMAL;
5297 unchopnum |= ! ischop;
5299 else { /* text field */
5301 bool ismore = FALSE;
5304 while (*++s == '>') ;
5305 prespace = FF_SPACE;
5307 else if (*s == '|') {
5308 while (*++s == '|') ;
5309 prespace = FF_HALFSPACE;
5314 while (*++s == '<') ;
5317 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5321 *fpc++ = s - base; /* fieldsize for FETCH */
5323 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5326 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5340 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5343 mg->mg_ptr = (char *) fops;
5344 mg->mg_len = arg * sizeof(U32);
5345 mg->mg_obj = sv_copy;
5346 mg->mg_flags |= MGf_REFCOUNTED;
5348 if (unchopnum && repeat)
5349 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5356 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5358 /* Can value be printed in fldsize chars, using %*.*f ? */
5362 int intsize = fldsize - (value < 0 ? 1 : 0);
5364 if (frcsize & FORM_NUM_POINT)
5366 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5369 while (intsize--) pwr *= 10.0;
5370 while (frcsize--) eps /= 10.0;
5373 if (value + eps >= pwr)
5376 if (value - eps <= -pwr)
5383 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5386 SV * const datasv = FILTER_DATA(idx);
5387 const int filter_has_file = IoLINES(datasv);
5388 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5389 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5394 char *prune_from = NULL;
5395 bool read_from_cache = FALSE;
5399 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5401 assert(maxlen >= 0);
5404 /* I was having segfault trouble under Linux 2.2.5 after a
5405 parse error occured. (Had to hack around it with a test
5406 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5407 not sure where the trouble is yet. XXX */
5410 SV *const cache = datasv;
5413 const char *cache_p = SvPV(cache, cache_len);
5417 /* Running in block mode and we have some cached data already.
5419 if (cache_len >= umaxlen) {
5420 /* In fact, so much data we don't even need to call
5425 const char *const first_nl =
5426 (const char *)memchr(cache_p, '\n', cache_len);
5428 take = first_nl + 1 - cache_p;
5432 sv_catpvn(buf_sv, cache_p, take);
5433 sv_chop(cache, cache_p + take);
5434 /* Definitely not EOF */
5438 sv_catsv(buf_sv, cache);
5440 umaxlen -= cache_len;
5443 read_from_cache = TRUE;
5447 /* Filter API says that the filter appends to the contents of the buffer.
5448 Usually the buffer is "", so the details don't matter. But if it's not,
5449 then clearly what it contains is already filtered by this filter, so we
5450 don't want to pass it in a second time.
5451 I'm going to use a mortal in case the upstream filter croaks. */
5452 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5453 ? sv_newmortal() : buf_sv;
5454 SvUPGRADE(upstream, SVt_PV);
5456 if (filter_has_file) {
5457 status = FILTER_READ(idx+1, upstream, 0);
5460 if (filter_sub && status >= 0) {
5464 ENTER_with_name("call_filter_sub");
5469 DEFSV_set(upstream);
5473 PUSHs(filter_state);
5476 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5486 SV * const errsv = ERRSV;
5487 if (SvTRUE_NN(errsv))
5488 err = newSVsv(errsv);
5494 LEAVE_with_name("call_filter_sub");
5497 if (SvGMAGICAL(upstream)) {
5499 if (upstream == buf_sv) mg_free(buf_sv);
5501 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5502 if(!err && SvOK(upstream)) {
5503 got_p = SvPV_nomg(upstream, got_len);
5505 if (got_len > umaxlen) {
5506 prune_from = got_p + umaxlen;
5509 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5510 if (first_nl && first_nl + 1 < got_p + got_len) {
5511 /* There's a second line here... */
5512 prune_from = first_nl + 1;
5516 if (!err && prune_from) {
5517 /* Oh. Too long. Stuff some in our cache. */
5518 STRLEN cached_len = got_p + got_len - prune_from;
5519 SV *const cache = datasv;
5522 /* Cache should be empty. */
5523 assert(!SvCUR(cache));
5526 sv_setpvn(cache, prune_from, cached_len);
5527 /* If you ask for block mode, you may well split UTF-8 characters.
5528 "If it breaks, you get to keep both parts"
5529 (Your code is broken if you don't put them back together again
5530 before something notices.) */
5531 if (SvUTF8(upstream)) {
5534 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5536 /* Cannot just use sv_setpvn, as that could free the buffer
5537 before we have a chance to assign it. */
5538 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5539 got_len - cached_len);
5541 /* Can't yet be EOF */
5546 /* If they are at EOF but buf_sv has something in it, then they may never
5547 have touched the SV upstream, so it may be undefined. If we naively
5548 concatenate it then we get a warning about use of uninitialised value.
5550 if (!err && upstream != buf_sv &&
5552 sv_catsv_nomg(buf_sv, upstream);
5554 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5557 IoLINES(datasv) = 0;
5559 SvREFCNT_dec(filter_state);
5560 IoTOP_GV(datasv) = NULL;
5563 SvREFCNT_dec(filter_sub);
5564 IoBOTTOM_GV(datasv) = NULL;
5566 filter_del(S_run_user_filter);
5572 if (status == 0 && read_from_cache) {
5573 /* If we read some data from the cache (and by getting here it implies
5574 that we emptied the cache) then we aren't yet at EOF, and mustn't
5575 report that to our caller. */
5583 * c-indentation-style: bsd
5585 * indent-tabs-mode: nil
5588 * ex: set ts=8 sts=4 sw=4 et: