3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
37 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
39 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
45 const PERL_CONTEXT *cx;
48 if (PL_op->op_private & OPpOFFBYONE) {
49 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
52 cxix = dopoptosub(cxstack_ix);
58 switch (cx->blk_gimme) {
77 PMOP *pm = (PMOP*)cLOGOP->op_other;
82 const regexp_engine *eng;
83 bool is_bare_re= FALSE;
85 if (PL_op->op_flags & OPf_STACKED) {
95 /* prevent recompiling under /o and ithreads. */
96 #if defined(USE_ITHREADS)
97 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
104 assert (re != (REGEXP*) &PL_sv_undef);
105 eng = re ? RX_ENGINE(re) : current_re_engine();
108 In the below logic: these are basically the same - check if this regcomp is part of a split.
110 (PL_op->op_pmflags & PMf_split )
111 (PL_op->op_next->op_type == OP_PUSHRE)
113 We could add a new mask for this and copy the PMf_split, if we did
114 some bit definition fiddling first.
116 For now we leave this
119 new_re = (eng->op_comp
121 : &Perl_re_op_compile
122 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
124 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
126 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
128 if (pm->op_pmflags & PMf_HAS_CV)
129 ReANY(new_re)->qr_anoncv
130 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
134 /* The match's LHS's get-magic might need to access this op's regexp
135 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
136 get-magic now before we replace the regexp. Hopefully this hack can
137 be replaced with the approach described at
138 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
140 if (pm->op_type == OP_MATCH) {
142 const bool was_tainted = TAINT_get;
143 if (pm->op_flags & OPf_STACKED)
145 else if (pm->op_private & OPpTARGET_MY)
146 lhs = PAD_SV(pm->op_targ);
149 /* Restore the previous value of PL_tainted (which may have been
150 modified by get-magic), to avoid incorrectly setting the
151 RXf_TAINTED flag with RX_TAINT_on further down. */
152 TAINT_set(was_tainted);
153 #ifdef NO_TAINT_SUPPORT
154 PERL_UNUSED_VAR(was_tainted);
157 tmp = reg_temp_copy(NULL, new_re);
158 ReREFCNT_dec(new_re);
164 PM_SETRE(pm, new_re);
168 if (TAINTING_get && TAINT_get) {
169 SvTAINTED_on((SV*)new_re);
173 #if !defined(USE_ITHREADS)
174 /* can't change the optree at runtime either */
175 /* PMf_KEEP is handled differently under threads to avoid these problems */
176 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
178 if (pm->op_pmflags & PMf_KEEP) {
179 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
180 cLOGOP->op_first->op_next = PL_op->op_next;
192 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
193 PMOP * const pm = (PMOP*) cLOGOP->op_other;
194 SV * const dstr = cx->sb_dstr;
197 char *orig = cx->sb_orig;
198 REGEXP * const rx = cx->sb_rx;
200 REGEXP *old = PM_GETRE(pm);
207 PM_SETRE(pm,ReREFCNT_inc(rx));
210 rxres_restore(&cx->sb_rxres, rx);
212 if (cx->sb_iters++) {
213 const I32 saviters = cx->sb_iters;
214 if (cx->sb_iters > cx->sb_maxiters)
215 DIE(aTHX_ "Substitution loop");
217 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
219 /* See "how taint works" above pp_subst() */
221 cx->sb_rxtainted |= SUBST_TAINT_REPL;
222 sv_catsv_nomg(dstr, POPs);
223 if (CxONCE(cx) || s < orig ||
224 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
225 (s == m), cx->sb_targ, NULL,
226 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
228 SV *targ = cx->sb_targ;
230 assert(cx->sb_strend >= s);
231 if(cx->sb_strend > s) {
232 if (DO_UTF8(dstr) && !SvUTF8(targ))
233 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
235 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
237 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
238 cx->sb_rxtainted |= SUBST_TAINT_PAT;
240 if (pm->op_pmflags & PMf_NONDESTRUCT) {
242 /* From here on down we're using the copy, and leaving the
243 original untouched. */
247 SV_CHECK_THINKFIRST_COW_DROP(targ);
248 if (isGV(targ)) Perl_croak_no_modify();
250 SvPV_set(targ, SvPVX(dstr));
251 SvCUR_set(targ, SvCUR(dstr));
252 SvLEN_set(targ, SvLEN(dstr));
255 SvPV_set(dstr, NULL);
258 mPUSHi(saviters - 1);
260 (void)SvPOK_only_UTF8(targ);
263 /* update the taint state of various various variables in
264 * preparation for final exit.
265 * See "how taint works" above pp_subst() */
267 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
268 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
269 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
271 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
273 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
274 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
276 SvTAINTED_on(TOPs); /* taint return value */
277 /* needed for mg_set below */
279 cBOOL(cx->sb_rxtainted &
280 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
284 /* PL_tainted must be correctly set for this mg_set */
287 LEAVE_SCOPE(cx->sb_oldsave);
290 RETURNOP(pm->op_next);
291 assert(0); /* NOTREACHED */
293 cx->sb_iters = saviters;
295 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
298 assert(!RX_SUBOFFSET(rx));
299 cx->sb_orig = orig = RX_SUBBEG(rx);
301 cx->sb_strend = s + (cx->sb_strend - m);
303 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
305 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
306 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
308 sv_catpvn_nomg(dstr, s, m-s);
310 cx->sb_s = RX_OFFS(rx)[0].end + orig;
311 { /* Update the pos() information. */
313 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
315 if (!(mg = mg_find_mglob(sv))) {
316 mg = sv_magicext_mglob(sv);
319 MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
322 (void)ReREFCNT_inc(rx);
323 /* update the taint state of various various variables in preparation
324 * for calling the code block.
325 * See "how taint works" above pp_subst() */
327 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
328 cx->sb_rxtainted |= SUBST_TAINT_PAT;
330 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
331 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
332 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
334 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
336 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
337 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
338 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
339 ? cx->sb_dstr : cx->sb_targ);
342 rxres_save(&cx->sb_rxres, rx);
344 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
348 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
353 PERL_ARGS_ASSERT_RXRES_SAVE;
356 if (!p || p[1] < RX_NPARENS(rx)) {
358 i = 7 + (RX_NPARENS(rx)+1) * 2;
360 i = 6 + (RX_NPARENS(rx)+1) * 2;
369 /* what (if anything) to free on croak */
370 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
371 RX_MATCH_COPIED_off(rx);
372 *p++ = RX_NPARENS(rx);
375 *p++ = PTR2UV(RX_SAVED_COPY(rx));
376 RX_SAVED_COPY(rx) = NULL;
379 *p++ = PTR2UV(RX_SUBBEG(rx));
380 *p++ = (UV)RX_SUBLEN(rx);
381 *p++ = (UV)RX_SUBOFFSET(rx);
382 *p++ = (UV)RX_SUBCOFFSET(rx);
383 for (i = 0; i <= RX_NPARENS(rx); ++i) {
384 *p++ = (UV)RX_OFFS(rx)[i].start;
385 *p++ = (UV)RX_OFFS(rx)[i].end;
390 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
395 PERL_ARGS_ASSERT_RXRES_RESTORE;
398 RX_MATCH_COPY_FREE(rx);
399 RX_MATCH_COPIED_set(rx, *p);
401 RX_NPARENS(rx) = *p++;
404 if (RX_SAVED_COPY(rx))
405 SvREFCNT_dec (RX_SAVED_COPY(rx));
406 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
410 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
411 RX_SUBLEN(rx) = (I32)(*p++);
412 RX_SUBOFFSET(rx) = (I32)*p++;
413 RX_SUBCOFFSET(rx) = (I32)*p++;
414 for (i = 0; i <= RX_NPARENS(rx); ++i) {
415 RX_OFFS(rx)[i].start = (I32)(*p++);
416 RX_OFFS(rx)[i].end = (I32)(*p++);
421 S_rxres_free(pTHX_ void **rsp)
423 UV * const p = (UV*)*rsp;
425 PERL_ARGS_ASSERT_RXRES_FREE;
429 void *tmp = INT2PTR(char*,*p);
432 U32 i = 9 + p[1] * 2;
434 U32 i = 8 + p[1] * 2;
439 SvREFCNT_dec (INT2PTR(SV*,p[2]));
442 PoisonFree(p, i, sizeof(UV));
451 #define FORM_NUM_BLANK (1<<30)
452 #define FORM_NUM_POINT (1<<29)
456 dSP; dMARK; dORIGMARK;
457 SV * const tmpForm = *++MARK;
458 SV *formsv; /* contains text of original format */
459 U32 *fpc; /* format ops program counter */
460 char *t; /* current append position in target string */
461 const char *f; /* current position in format string */
463 SV *sv = NULL; /* current item */
464 const char *item = NULL;/* string value of current item */
465 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
466 I32 itembytes = 0; /* as itemsize, but length in bytes */
467 I32 fieldsize = 0; /* width of current field */
468 I32 lines = 0; /* number of lines that have been output */
469 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
470 const char *chophere = NULL; /* where to chop current item */
471 STRLEN linemark = 0; /* pos of start of line in output */
473 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
474 STRLEN len; /* length of current sv */
475 STRLEN linemax; /* estimate of output size in bytes */
476 bool item_is_utf8 = FALSE;
477 bool targ_is_utf8 = FALSE;
480 U8 *source; /* source of bytes to append */
481 STRLEN to_copy; /* how may bytes to append */
482 char trans; /* what chars to translate */
484 mg = doparseform(tmpForm);
486 fpc = (U32*)mg->mg_ptr;
487 /* the actual string the format was compiled from.
488 * with overload etc, this may not match tmpForm */
492 SvPV_force(PL_formtarget, len);
493 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
494 SvTAINTED_on(PL_formtarget);
495 if (DO_UTF8(PL_formtarget))
497 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
498 t = SvGROW(PL_formtarget, len + linemax + 1);
499 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
501 f = SvPV_const(formsv, len);
505 const char *name = "???";
508 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
509 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
510 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
511 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
512 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
514 case FF_CHECKNL: name = "CHECKNL"; break;
515 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
516 case FF_SPACE: name = "SPACE"; break;
517 case FF_HALFSPACE: name = "HALFSPACE"; break;
518 case FF_ITEM: name = "ITEM"; break;
519 case FF_CHOP: name = "CHOP"; break;
520 case FF_LINEGLOB: name = "LINEGLOB"; break;
521 case FF_NEWLINE: name = "NEWLINE"; break;
522 case FF_MORE: name = "MORE"; break;
523 case FF_LINEMARK: name = "LINEMARK"; break;
524 case FF_END: name = "END"; break;
525 case FF_0DECIMAL: name = "0DECIMAL"; break;
526 case FF_LINESNGL: name = "LINESNGL"; break;
529 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
531 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
534 case FF_LINEMARK: /* start (or end) of a line */
535 linemark = t - SvPVX(PL_formtarget);
540 case FF_LITERAL: /* append <arg> literal chars */
545 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
548 case FF_SKIP: /* skip <arg> chars in format */
552 case FF_FETCH: /* get next item and set field size to <arg> */
561 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
564 SvTAINTED_on(PL_formtarget);
567 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
569 const char *s = item = SvPV_const(sv, len);
570 const char *send = s + len;
573 item_is_utf8 = DO_UTF8(sv);
585 if (itemsize == fieldsize)
588 itembytes = s - item;
592 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
594 const char *s = item = SvPV_const(sv, len);
595 const char *send = s + len;
599 item_is_utf8 = DO_UTF8(sv);
601 /* look for a legal split position */
609 /* provisional split point */
613 /* we delay testing fieldsize until after we've
614 * processed the possible split char directly
615 * following the last field char; so if fieldsize=3
616 * and item="a b cdef", we consume "a b", not "a".
617 * Ditto further down.
619 if (size == fieldsize)
623 if (strchr(PL_chopset, *s)) {
624 /* provisional split point */
625 /* for a non-space split char, we include
626 * the split char; hence the '+1' */
630 if (size == fieldsize)
642 if (!chophere || s == send) {
646 itembytes = chophere - item;
651 case FF_SPACE: /* append padding space (diff of field, item size) */
652 arg = fieldsize - itemsize;
660 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
661 arg = fieldsize - itemsize;
670 case FF_ITEM: /* append a text item, while blanking ctrl chars */
676 case FF_CHOP: /* (for ^*) chop the current item */
678 const char *s = chophere;
686 /* tied, overloaded or similar strangeness.
687 * Do it the hard way */
688 sv_setpvn(sv, s, len - (s-item));
693 case FF_LINESNGL: /* process ^* */
697 case FF_LINEGLOB: /* process @* */
699 const bool oneline = fpc[-1] == FF_LINESNGL;
700 const char *s = item = SvPV_const(sv, len);
701 const char *const send = s + len;
703 item_is_utf8 = DO_UTF8(sv);
714 to_copy = s - item - 1;
728 /* append to_copy bytes from source to PL_formstring.
729 * item_is_utf8 implies source is utf8.
730 * if trans, translate certain characters during the copy */
735 SvCUR_set(PL_formtarget,
736 t - SvPVX_const(PL_formtarget));
738 if (targ_is_utf8 && !item_is_utf8) {
739 source = tmp = bytes_to_utf8(source, &to_copy);
741 if (item_is_utf8 && !targ_is_utf8) {
743 /* Upgrade targ to UTF8, and then we reduce it to
744 a problem we have a simple solution for.
745 Don't need get magic. */
746 sv_utf8_upgrade_nomg(PL_formtarget);
748 /* re-calculate linemark */
749 s = (U8*)SvPVX(PL_formtarget);
750 /* the bytes we initially allocated to append the
751 * whole line may have been gobbled up during the
752 * upgrade, so allocate a whole new line's worth
757 linemark = s - (U8*)SvPVX(PL_formtarget);
759 /* Easy. They agree. */
760 assert (item_is_utf8 == targ_is_utf8);
763 /* @* and ^* are the only things that can exceed
764 * the linemax, so grow by the output size, plus
765 * a whole new form's worth in case of any further
767 grow = linemax + to_copy;
769 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
770 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
772 Copy(source, t, to_copy, char);
774 /* blank out ~ or control chars, depending on trans.
775 * works on bytes not chars, so relies on not
776 * matching utf8 continuation bytes */
778 U8 *send = s + to_copy;
781 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
788 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
794 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
797 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
800 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
803 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
805 /* If the field is marked with ^ and the value is undefined,
807 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
815 /* overflow evidence */
816 if (num_overflow(value, fieldsize, arg)) {
822 /* Formats aren't yet marked for locales, so assume "yes". */
824 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
826 DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
827 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
830 const char* qfmt = quadmath_format_single(fmt);
833 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
834 len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
836 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
841 /* we generate fmt ourselves so it is safe */
842 GCC_DIAG_IGNORE(-Wformat-nonliteral);
843 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
846 PERL_MY_SNPRINTF_POST_GUARD(len, max);
847 RESTORE_LC_NUMERIC();
852 case FF_NEWLINE: /* delete trailing spaces, then append \n */
854 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
859 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
862 if (arg) { /* repeat until fields exhausted? */
868 t = SvPVX(PL_formtarget) + linemark;
873 case FF_MORE: /* replace long end of string with '...' */
875 const char *s = chophere;
876 const char *send = item + len;
878 while (isSPACE(*s) && (s < send))
883 arg = fieldsize - itemsize;
890 if (strnEQ(s1," ",3)) {
891 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
901 case FF_END: /* tidy up, then return */
903 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
905 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
907 SvUTF8_on(PL_formtarget);
908 FmLINES(PL_formtarget) += lines;
910 if (fpc[-1] == FF_BLANK)
911 RETURNOP(cLISTOP->op_first);
923 if (PL_stack_base + *PL_markstack_ptr == SP) {
925 if (GIMME_V == G_SCALAR)
927 RETURNOP(PL_op->op_next->op_next);
929 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
930 Perl_pp_pushmark(aTHX); /* push dst */
931 Perl_pp_pushmark(aTHX); /* push src */
932 ENTER_with_name("grep"); /* enter outer scope */
935 if (PL_op->op_private & OPpGREP_LEX)
936 SAVESPTR(PAD_SVl(PL_op->op_targ));
939 ENTER_with_name("grep_item"); /* enter inner scope */
942 src = PL_stack_base[*PL_markstack_ptr];
944 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
948 if (PL_op->op_private & OPpGREP_LEX)
949 PAD_SVl(PL_op->op_targ) = src;
954 if (PL_op->op_type == OP_MAPSTART)
955 Perl_pp_pushmark(aTHX); /* push top */
956 return ((LOGOP*)PL_op->op_next)->op_other;
962 const I32 gimme = GIMME_V;
963 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
969 /* first, move source pointer to the next item in the source list */
970 ++PL_markstack_ptr[-1];
972 /* if there are new items, push them into the destination list */
973 if (items && gimme != G_VOID) {
974 /* might need to make room back there first */
975 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
976 /* XXX this implementation is very pessimal because the stack
977 * is repeatedly extended for every set of items. Is possible
978 * to do this without any stack extension or copying at all
979 * by maintaining a separate list over which the map iterates
980 * (like foreach does). --gsar */
982 /* everything in the stack after the destination list moves
983 * towards the end the stack by the amount of room needed */
984 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
986 /* items to shift up (accounting for the moved source pointer) */
987 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
989 /* This optimization is by Ben Tilly and it does
990 * things differently from what Sarathy (gsar)
991 * is describing. The downside of this optimization is
992 * that leaves "holes" (uninitialized and hopefully unused areas)
993 * to the Perl stack, but on the other hand this
994 * shouldn't be a problem. If Sarathy's idea gets
995 * implemented, this optimization should become
996 * irrelevant. --jhi */
998 shift = count; /* Avoid shifting too often --Ben Tilly */
1002 dst = (SP += shift);
1003 PL_markstack_ptr[-1] += shift;
1004 *PL_markstack_ptr += shift;
1008 /* copy the new items down to the destination list */
1009 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1010 if (gimme == G_ARRAY) {
1011 /* add returned items to the collection (making mortal copies
1012 * if necessary), then clear the current temps stack frame
1013 * *except* for those items. We do this splicing the items
1014 * into the start of the tmps frame (so some items may be on
1015 * the tmps stack twice), then moving PL_tmps_floor above
1016 * them, then freeing the frame. That way, the only tmps that
1017 * accumulate over iterations are the return values for map.
1018 * We have to do to this way so that everything gets correctly
1019 * freed if we die during the map.
1023 /* make space for the slice */
1024 EXTEND_MORTAL(items);
1025 tmpsbase = PL_tmps_floor + 1;
1026 Move(PL_tmps_stack + tmpsbase,
1027 PL_tmps_stack + tmpsbase + items,
1028 PL_tmps_ix - PL_tmps_floor,
1030 PL_tmps_ix += items;
1035 sv = sv_mortalcopy(sv);
1037 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1039 /* clear the stack frame except for the items */
1040 PL_tmps_floor += items;
1042 /* FREETMPS may have cleared the TEMP flag on some of the items */
1045 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1048 /* scalar context: we don't care about which values map returns
1049 * (we use undef here). And so we certainly don't want to do mortal
1050 * copies of meaningless values. */
1051 while (items-- > 0) {
1053 *dst-- = &PL_sv_undef;
1061 LEAVE_with_name("grep_item"); /* exit inner scope */
1064 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1066 (void)POPMARK; /* pop top */
1067 LEAVE_with_name("grep"); /* exit outer scope */
1068 (void)POPMARK; /* pop src */
1069 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1070 (void)POPMARK; /* pop dst */
1071 SP = PL_stack_base + POPMARK; /* pop original mark */
1072 if (gimme == G_SCALAR) {
1073 if (PL_op->op_private & OPpGREP_LEX) {
1074 SV* sv = sv_newmortal();
1075 sv_setiv(sv, items);
1083 else if (gimme == G_ARRAY)
1090 ENTER_with_name("grep_item"); /* enter inner scope */
1093 /* set $_ to the new source item */
1094 src = PL_stack_base[PL_markstack_ptr[-1]];
1095 if (SvPADTMP(src)) {
1096 src = sv_mortalcopy(src);
1099 if (PL_op->op_private & OPpGREP_LEX)
1100 PAD_SVl(PL_op->op_targ) = src;
1104 RETURNOP(cLOGOP->op_other);
1112 if (GIMME == G_ARRAY)
1114 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1115 return cLOGOP->op_other;
1124 if (GIMME == G_ARRAY) {
1125 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1129 SV * const targ = PAD_SV(PL_op->op_targ);
1132 if (PL_op->op_private & OPpFLIP_LINENUM) {
1133 if (GvIO(PL_last_in_gv)) {
1134 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1137 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1139 flip = SvIV(sv) == SvIV(GvSV(gv));
1145 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1146 if (PL_op->op_flags & OPf_SPECIAL) {
1154 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1157 sv_setpvs(TARG, "");
1163 /* This code tries to decide if "$left .. $right" should use the
1164 magical string increment, or if the range is numeric (we make
1165 an exception for .."0" [#18165]). AMS 20021031. */
1167 #define RANGE_IS_NUMERIC(left,right) ( \
1168 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1169 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1170 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1171 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1172 && (!SvOK(right) || looks_like_number(right))))
1178 if (GIMME == G_ARRAY) {
1184 if (RANGE_IS_NUMERIC(left,right)) {
1186 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1187 (SvOK(right) && (SvIOK(right)
1188 ? SvIsUV(right) && SvUV(right) > IV_MAX
1189 : SvNV_nomg(right) > IV_MAX)))
1190 DIE(aTHX_ "Range iterator outside integer range");
1191 i = SvIV_nomg(left);
1192 j = SvIV_nomg(right);
1194 /* Dance carefully around signed max. */
1195 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1198 /* The wraparound of signed integers is undefined
1199 * behavior, but here we aim for count >=1, and
1200 * negative count is just wrong. */
1205 Perl_croak(aTHX_ "Out of memory during list extend");
1212 SV * const sv = sv_2mortal(newSViv(i++));
1218 const char * const lpv = SvPV_nomg_const(left, llen);
1219 const char * const tmps = SvPV_nomg_const(right, len);
1221 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1222 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1224 if (strEQ(SvPVX_const(sv),tmps))
1226 sv = sv_2mortal(newSVsv(sv));
1233 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1237 if (PL_op->op_private & OPpFLIP_LINENUM) {
1238 if (GvIO(PL_last_in_gv)) {
1239 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1242 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1243 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1251 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1252 sv_catpvs(targ, "E0");
1262 static const char * const context_name[] = {
1264 NULL, /* CXt_WHEN never actually needs "block" */
1265 NULL, /* CXt_BLOCK never actually needs "block" */
1266 NULL, /* CXt_GIVEN never actually needs "block" */
1267 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1268 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1269 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1270 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1278 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1282 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1284 for (i = cxstack_ix; i >= 0; i--) {
1285 const PERL_CONTEXT * const cx = &cxstack[i];
1286 switch (CxTYPE(cx)) {
1292 /* diag_listed_as: Exiting subroutine via %s */
1293 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1294 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1295 if (CxTYPE(cx) == CXt_NULL)
1298 case CXt_LOOP_LAZYIV:
1299 case CXt_LOOP_LAZYSV:
1301 case CXt_LOOP_PLAIN:
1303 STRLEN cx_label_len = 0;
1304 U32 cx_label_flags = 0;
1305 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1307 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1310 (const U8*)cx_label, cx_label_len,
1311 (const U8*)label, len) == 0)
1313 (const U8*)label, len,
1314 (const U8*)cx_label, cx_label_len) == 0)
1315 : (len == cx_label_len && ((cx_label == label)
1316 || memEQ(cx_label, label, len))) )) {
1317 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1318 (long)i, cx_label));
1321 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1332 Perl_dowantarray(pTHX)
1334 const I32 gimme = block_gimme();
1335 return (gimme == G_VOID) ? G_SCALAR : gimme;
1339 Perl_block_gimme(pTHX)
1341 const I32 cxix = dopoptosub(cxstack_ix);
1345 switch (cxstack[cxix].blk_gimme) {
1353 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1355 NOT_REACHED; /* NOTREACHED */
1359 Perl_is_lvalue_sub(pTHX)
1361 const I32 cxix = dopoptosub(cxstack_ix);
1362 assert(cxix >= 0); /* We should only be called from inside subs */
1364 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1365 return CxLVAL(cxstack + cxix);
1370 /* only used by PUSHSUB */
1372 Perl_was_lvalue_sub(pTHX)
1374 const I32 cxix = dopoptosub(cxstack_ix-1);
1375 assert(cxix >= 0); /* We should only be called from inside subs */
1377 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1378 return CxLVAL(cxstack + cxix);
1384 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1388 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1390 PERL_UNUSED_CONTEXT;
1393 for (i = startingblock; i >= 0; i--) {
1394 const PERL_CONTEXT * const cx = &cxstk[i];
1395 switch (CxTYPE(cx)) {
1399 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1400 * twice; the first for the normal foo() call, and the second
1401 * for a faked up re-entry into the sub to execute the
1402 * code block. Hide this faked entry from the world. */
1403 if (cx->cx_type & CXp_SUB_RE_FAKE)
1408 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1416 S_dopoptoeval(pTHX_ I32 startingblock)
1419 for (i = startingblock; i >= 0; i--) {
1420 const PERL_CONTEXT *cx = &cxstack[i];
1421 switch (CxTYPE(cx)) {
1425 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1433 S_dopoptoloop(pTHX_ I32 startingblock)
1436 for (i = startingblock; i >= 0; i--) {
1437 const PERL_CONTEXT * const cx = &cxstack[i];
1438 switch (CxTYPE(cx)) {
1444 /* diag_listed_as: Exiting subroutine via %s */
1445 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1446 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1447 if ((CxTYPE(cx)) == CXt_NULL)
1450 case CXt_LOOP_LAZYIV:
1451 case CXt_LOOP_LAZYSV:
1453 case CXt_LOOP_PLAIN:
1454 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1462 S_dopoptogiven(pTHX_ I32 startingblock)
1465 for (i = startingblock; i >= 0; i--) {
1466 const PERL_CONTEXT *cx = &cxstack[i];
1467 switch (CxTYPE(cx)) {
1471 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1473 case CXt_LOOP_PLAIN:
1474 assert(!CxFOREACHDEF(cx));
1476 case CXt_LOOP_LAZYIV:
1477 case CXt_LOOP_LAZYSV:
1479 if (CxFOREACHDEF(cx)) {
1480 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1489 S_dopoptowhen(pTHX_ I32 startingblock)
1492 for (i = startingblock; i >= 0; i--) {
1493 const PERL_CONTEXT *cx = &cxstack[i];
1494 switch (CxTYPE(cx)) {
1498 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1506 Perl_dounwind(pTHX_ I32 cxix)
1510 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1513 while (cxstack_ix > cxix) {
1515 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1516 DEBUG_CX("UNWIND"); \
1517 /* Note: we don't need to restore the base context info till the end. */
1518 switch (CxTYPE(cx)) {
1521 continue; /* not break */
1529 case CXt_LOOP_LAZYIV:
1530 case CXt_LOOP_LAZYSV:
1532 case CXt_LOOP_PLAIN:
1543 PERL_UNUSED_VAR(optype);
1547 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)
1570 SV *exceptsv = sv_mortalcopy(msv);
1571 U8 in_eval = PL_in_eval;
1572 PERL_ARGS_ASSERT_DIE_UNWIND;
1579 * Historically, perl used to set ERRSV ($@) early in the die
1580 * process and rely on it not getting clobbered during unwinding.
1581 * That sucked, because it was liable to get clobbered, so the
1582 * setting of ERRSV used to emit the exception from eval{} has
1583 * been moved to much later, after unwinding (see just before
1584 * JMPENV_JUMP below). However, some modules were relying on the
1585 * early setting, by examining $@ during unwinding to use it as
1586 * a flag indicating whether the current unwinding was caused by
1587 * an exception. It was never a reliable flag for that purpose,
1588 * being totally open to false positives even without actual
1589 * clobberage, but was useful enough for production code to
1590 * semantically rely on it.
1592 * We'd like to have a proper introspective interface that
1593 * explicitly describes the reason for whatever unwinding
1594 * operations are currently in progress, so that those modules
1595 * work reliably and $@ isn't further overloaded. But we don't
1596 * have one yet. In its absence, as a stopgap measure, ERRSV is
1597 * now *additionally* set here, before unwinding, to serve as the
1598 * (unreliable) flag that it used to.
1600 * This behaviour is temporary, and should be removed when a
1601 * proper way to detect exceptional unwinding has been developed.
1602 * As of 2010-12, the authors of modules relying on the hack
1603 * are aware of the issue, because the modules failed on
1604 * perls 5.13.{1..7} which had late setting of $@ without this
1605 * early-setting hack.
1607 if (!(in_eval & EVAL_KEEPERR)) {
1608 SvTEMP_off(exceptsv);
1609 sv_setsv(ERRSV, exceptsv);
1612 if (in_eval & EVAL_KEEPERR) {
1613 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1617 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1618 && PL_curstackinfo->si_prev)
1632 JMPENV *restartjmpenv;
1635 if (cxix < cxstack_ix)
1638 POPBLOCK(cx,PL_curpm);
1639 if (CxTYPE(cx) != CXt_EVAL) {
1641 const char* message = SvPVx_const(exceptsv, msglen);
1642 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1643 PerlIO_write(Perl_error_log, message, msglen);
1647 namesv = cx->blk_eval.old_namesv;
1649 oldcop = cx->blk_oldcop;
1651 restartjmpenv = cx->blk_eval.cur_top_env;
1652 restartop = cx->blk_eval.retop;
1654 if (gimme == G_SCALAR)
1655 *++newsp = &PL_sv_undef;
1656 PL_stack_sp = newsp;
1660 if (optype == OP_REQUIRE) {
1661 assert (PL_curcop == oldcop);
1662 (void)hv_store(GvHVn(PL_incgv),
1663 SvPVX_const(namesv),
1664 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1666 /* note that unlike pp_entereval, pp_require isn't
1667 * supposed to trap errors. So now that we've popped the
1668 * EVAL that pp_require pushed, and processed the error
1669 * message, rethrow the error */
1670 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1671 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1674 if (!(in_eval & EVAL_KEEPERR))
1675 sv_setsv(ERRSV, exceptsv);
1676 PL_restartjmpenv = restartjmpenv;
1677 PL_restartop = restartop;
1679 assert(0); /* NOTREACHED */
1683 write_to_stderr(exceptsv);
1685 assert(0); /* NOTREACHED */
1691 if (SvTRUE(left) != SvTRUE(right))
1699 =head1 CV Manipulation Functions
1701 =for apidoc caller_cx
1703 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1704 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1705 information returned to Perl by C<caller>. Note that XSUBs don't get a
1706 stack frame, so C<caller_cx(0, NULL)> will return information for the
1707 immediately-surrounding Perl code.
1709 This function skips over the automatic calls to C<&DB::sub> made on the
1710 behalf of the debugger. If the stack frame requested was a sub called by
1711 C<DB::sub>, the return value will be the frame for the call to
1712 C<DB::sub>, since that has the correct line number/etc. for the call
1713 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1714 frame for the sub call itself.
1719 const PERL_CONTEXT *
1720 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1722 I32 cxix = dopoptosub(cxstack_ix);
1723 const PERL_CONTEXT *cx;
1724 const PERL_CONTEXT *ccstack = cxstack;
1725 const PERL_SI *top_si = PL_curstackinfo;
1728 /* we may be in a higher stacklevel, so dig down deeper */
1729 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1730 top_si = top_si->si_prev;
1731 ccstack = top_si->si_cxstack;
1732 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1736 /* caller() should not report the automatic calls to &DB::sub */
1737 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1738 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1742 cxix = dopoptosub_at(ccstack, cxix - 1);
1745 cx = &ccstack[cxix];
1746 if (dbcxp) *dbcxp = cx;
1748 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1749 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1750 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1751 field below is defined for any cx. */
1752 /* caller() should not report the automatic calls to &DB::sub */
1753 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1754 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, OP_SIBLING(cx->blk_oldcop),
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 /* So is ccstack[dbcxix]. */
1822 if (CvHASGV(dbcx->blk_sub.cv)) {
1823 PUSHs(cv_name(dbcx->blk_sub.cv, 0));
1824 PUSHs(boolSV(CxHASARGS(cx)));
1827 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1828 PUSHs(boolSV(CxHASARGS(cx)));
1832 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1835 gimme = (I32)cx->blk_gimme;
1836 if (gimme == G_VOID)
1837 PUSHs(&PL_sv_undef);
1839 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1840 if (CxTYPE(cx) == CXt_EVAL) {
1842 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1843 SV *cur_text = cx->blk_eval.cur_text;
1844 if (SvCUR(cur_text) >= 2) {
1845 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1846 SvUTF8(cur_text)|SVs_TEMP));
1849 /* I think this is will always be "", but be sure */
1850 PUSHs(sv_2mortal(newSVsv(cur_text)));
1856 else if (cx->blk_eval.old_namesv) {
1857 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1860 /* eval BLOCK (try blocks have old_namesv == 0) */
1862 PUSHs(&PL_sv_undef);
1863 PUSHs(&PL_sv_undef);
1867 PUSHs(&PL_sv_undef);
1868 PUSHs(&PL_sv_undef);
1870 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1871 && CopSTASH_eq(PL_curcop, PL_debstash))
1873 AV * const ary = cx->blk_sub.argarray;
1874 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1876 Perl_init_dbargs(aTHX);
1878 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1879 av_extend(PL_dbargs, AvFILLp(ary) + off);
1880 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1881 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1883 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1886 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1888 if (old_warnings == pWARN_NONE)
1889 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1890 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1891 mask = &PL_sv_undef ;
1892 else if (old_warnings == pWARN_ALL ||
1893 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1894 /* Get the bit mask for $warnings::Bits{all}, because
1895 * it could have been extended by warnings::register */
1897 HV * const bits = get_hv("warnings::Bits", 0);
1898 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1899 mask = newSVsv(*bits_all);
1902 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1906 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1910 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1911 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1921 if (MAXARG < 1 || (!TOPs && !POPs))
1922 tmps = NULL, len = 0;
1924 tmps = SvPVx_const(POPs, len);
1925 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1930 /* like pp_nextstate, but used instead when the debugger is active */
1934 PL_curcop = (COP*)PL_op;
1935 TAINT_NOT; /* Each statement is presumed innocent */
1936 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1941 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1942 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1946 const I32 gimme = G_ARRAY;
1948 GV * const gv = PL_DBgv;
1951 if (gv && isGV_with_GP(gv))
1954 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1955 DIE(aTHX_ "No DB::DB routine defined");
1957 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1958 /* don't do recursive DB::DB call */
1972 (void)(*CvXSUB(cv))(aTHX_ cv);
1978 PUSHBLOCK(cx, CXt_SUB, SP);
1980 cx->blk_sub.retop = PL_op->op_next;
1982 if (CvDEPTH(cv) >= 2) {
1983 PERL_STACK_OVERFLOW_CHECK();
1984 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1987 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1988 RETURNOP(CvSTART(cv));
1995 /* S_leave_common: Common code that many functions in this file use on
1998 /* SVs on the stack that have any of the flags passed in are left as is.
1999 Other SVs are protected via the mortals stack if lvalue is true, and
2002 Also, taintedness is cleared.
2006 S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
2007 U32 flags, bool lvalue)
2010 PERL_ARGS_ASSERT_LEAVE_COMMON;
2013 if (flags & SVs_PADTMP) {
2014 flags &= ~SVs_PADTMP;
2017 if (gimme == G_SCALAR) {
2019 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2022 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2023 : sv_mortalcopy(*SP);
2025 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2028 *++MARK = &PL_sv_undef;
2032 else if (gimme == G_ARRAY) {
2033 /* in case LEAVE wipes old return values */
2034 while (++MARK <= SP) {
2035 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2039 ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
2040 : sv_mortalcopy(*MARK);
2041 TAINT_NOT; /* Each item is independent */
2044 /* When this function was called with MARK == newsp, we reach this
2045 * point with SP == newsp. */
2055 I32 gimme = GIMME_V;
2057 ENTER_with_name("block");
2060 PUSHBLOCK(cx, CXt_BLOCK, SP);
2073 if (PL_op->op_flags & OPf_SPECIAL) {
2074 cx = &cxstack[cxstack_ix];
2075 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2080 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2082 SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
2083 PL_op->op_private & OPpLVALUE);
2084 PL_curpm = newpm; /* Don't pop $1 et al till now */
2086 LEAVE_with_name("block");
2095 const I32 gimme = GIMME_V;
2096 void *itervar; /* location of the iteration variable */
2097 U8 cxtype = CXt_LOOP_FOR;
2099 ENTER_with_name("loop1");
2102 if (PL_op->op_targ) { /* "my" variable */
2103 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2104 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2105 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2106 SVs_PADSTALE, SVs_PADSTALE);
2108 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2110 itervar = PL_comppad;
2112 itervar = &PAD_SVl(PL_op->op_targ);
2115 else { /* symbol table variable */
2116 GV * const gv = MUTABLE_GV(POPs);
2117 SV** svp = &GvSV(gv);
2118 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2120 itervar = (void *)gv;
2123 if (PL_op->op_private & OPpITER_DEF)
2124 cxtype |= CXp_FOR_DEF;
2126 ENTER_with_name("loop2");
2128 PUSHBLOCK(cx, cxtype, SP);
2129 PUSHLOOP_FOR(cx, itervar, MARK);
2130 if (PL_op->op_flags & OPf_STACKED) {
2131 SV *maybe_ary = POPs;
2132 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2134 SV * const right = maybe_ary;
2137 if (RANGE_IS_NUMERIC(sv,right)) {
2139 cx->cx_type &= ~CXTYPEMASK;
2140 cx->cx_type |= CXt_LOOP_LAZYIV;
2141 /* Make sure that no-one re-orders cop.h and breaks our
2143 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2144 #ifdef NV_PRESERVES_UV
2145 if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) < (NV)IV_MIN) ||
2148 (SvOK(right) && (((nv = SvNV_nomg(right)) > (NV)IV_MAX) ||
2149 (nv < (NV)IV_MIN))))
2151 if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) <= (NV)IV_MIN)
2154 ((nv > (NV)UV_MAX) ||
2155 (SvUV_nomg(sv) > (UV)IV_MAX)))))
2157 (SvOK(right) && (((nv = SvNV_nomg(right)) <= (NV)IV_MIN)
2160 ((nv > (NV)UV_MAX) ||
2161 (SvUV_nomg(right) > (UV)IV_MAX))
2164 DIE(aTHX_ "Range iterator outside integer range");
2165 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2166 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2168 /* for correct -Dstv display */
2169 cx->blk_oldsp = sp - PL_stack_base;
2173 cx->cx_type &= ~CXTYPEMASK;
2174 cx->cx_type |= CXt_LOOP_LAZYSV;
2175 /* Make sure that no-one re-orders cop.h and breaks our
2177 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2178 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2179 cx->blk_loop.state_u.lazysv.end = right;
2180 SvREFCNT_inc(right);
2181 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2182 /* This will do the upgrade to SVt_PV, and warn if the value
2183 is uninitialised. */
2184 (void) SvPV_nolen_const(right);
2185 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2186 to replace !SvOK() with a pointer to "". */
2188 SvREFCNT_dec(right);
2189 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2193 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2194 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2195 SvREFCNT_inc(maybe_ary);
2196 cx->blk_loop.state_u.ary.ix =
2197 (PL_op->op_private & OPpITER_REVERSED) ?
2198 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2202 else { /* iterating over items on the stack */
2203 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2204 if (PL_op->op_private & OPpITER_REVERSED) {
2205 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2208 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2219 const I32 gimme = GIMME_V;
2221 ENTER_with_name("loop1");
2223 ENTER_with_name("loop2");
2225 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2226 PUSHLOOP_PLAIN(cx, SP);
2241 assert(CxTYPE_is_LOOP(cx));
2243 newsp = PL_stack_base + cx->blk_loop.resetsp;
2245 SP = leave_common(newsp, SP, MARK, gimme, 0,
2246 PL_op->op_private & OPpLVALUE);
2249 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2250 PL_curpm = newpm; /* ... and pop $1 et al */
2252 LEAVE_with_name("loop2");
2253 LEAVE_with_name("loop1");
2259 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2260 PERL_CONTEXT *cx, PMOP *newpm)
2262 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2263 if (gimme == G_SCALAR) {
2264 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2266 const char *what = NULL;
2268 assert(MARK+1 == SP);
2269 if ((SvPADTMP(TOPs) ||
2270 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2273 !SvSMAGICAL(TOPs)) {
2275 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2276 : "a readonly value" : "a temporary";
2281 /* sub:lvalue{} will take us here. */
2290 "Can't return %s from lvalue subroutine", what
2295 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2296 if (!SvPADTMP(*SP)) {
2297 *++newsp = SvREFCNT_inc(*SP);
2302 /* FREETMPS could clobber it */
2303 SV *sv = SvREFCNT_inc(*SP);
2305 *++newsp = sv_mortalcopy(sv);
2312 ? sv_mortalcopy(*SP)
2314 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2319 *++newsp = &PL_sv_undef;
2321 if (CxLVAL(cx) & OPpDEREF) {
2324 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2328 else if (gimme == G_ARRAY) {
2329 assert (!(CxLVAL(cx) & OPpDEREF));
2330 if (ref || !CxLVAL(cx))
2331 while (++MARK <= SP)
2333 SvFLAGS(*MARK) & SVs_PADTMP
2334 ? sv_mortalcopy(*MARK)
2337 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2338 else while (++MARK <= SP) {
2339 if (*MARK != &PL_sv_undef
2341 || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2346 /* Might be flattened array after $#array = */
2353 /* diag_listed_as: Can't return %s from lvalue subroutine */
2355 "Can't return a %s from lvalue subroutine",
2356 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2362 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2365 PL_stack_sp = newsp;
2372 bool popsub2 = FALSE;
2373 bool clear_errsv = FALSE;
2383 const I32 cxix = dopoptosub(cxstack_ix);
2386 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2387 * sort block, which is a CXt_NULL
2390 PL_stack_base[1] = *PL_stack_sp;
2391 PL_stack_sp = PL_stack_base + 1;
2395 DIE(aTHX_ "Can't return outside a subroutine");
2397 if (cxix < cxstack_ix)
2400 if (CxMULTICALL(&cxstack[cxix])) {
2401 gimme = cxstack[cxix].blk_gimme;
2402 if (gimme == G_VOID)
2403 PL_stack_sp = PL_stack_base;
2404 else if (gimme == G_SCALAR) {
2405 PL_stack_base[1] = *PL_stack_sp;
2406 PL_stack_sp = PL_stack_base + 1;
2412 switch (CxTYPE(cx)) {
2415 lval = !!CvLVALUE(cx->blk_sub.cv);
2416 retop = cx->blk_sub.retop;
2417 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2420 if (!(PL_in_eval & EVAL_KEEPERR))
2423 namesv = cx->blk_eval.old_namesv;
2424 retop = cx->blk_eval.retop;
2427 if (optype == OP_REQUIRE &&
2428 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2430 /* Unassume the success we assumed earlier. */
2431 (void)hv_delete(GvHVn(PL_incgv),
2432 SvPVX_const(namesv),
2433 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2435 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2439 retop = cx->blk_sub.retop;
2443 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2447 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2449 if (gimme == G_SCALAR) {
2452 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2453 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2454 && !SvMAGICAL(TOPs)) {
2455 *++newsp = SvREFCNT_inc(*SP);
2460 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2462 *++newsp = sv_mortalcopy(sv);
2466 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2467 && !SvMAGICAL(*SP)) {
2471 *++newsp = sv_mortalcopy(*SP);
2474 *++newsp = sv_mortalcopy(*SP);
2477 *++newsp = &PL_sv_undef;
2479 else if (gimme == G_ARRAY) {
2480 while (++MARK <= SP) {
2481 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2482 && !SvGMAGICAL(*MARK)
2483 ? *MARK : sv_mortalcopy(*MARK);
2484 TAINT_NOT; /* Each item is independent */
2487 PL_stack_sp = newsp;
2491 /* Stack values are safe: */
2494 POPSUB(cx,sv); /* release CV and @_ ... */
2498 PL_curpm = newpm; /* ... and pop $1 et al */
2507 /* This duplicates parts of pp_leavesub, so that it can share code with
2518 if (CxMULTICALL(&cxstack[cxstack_ix]))
2522 cxstack_ix++; /* temporarily protect top context */
2526 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2529 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2531 PL_curpm = newpm; /* ... and pop $1 et al */
2534 return cx->blk_sub.retop;
2538 S_unwind_loop(pTHX_ const char * const opname)
2541 if (PL_op->op_flags & OPf_SPECIAL) {
2542 cxix = dopoptoloop(cxstack_ix);
2544 /* diag_listed_as: Can't "last" outside a loop block */
2545 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2550 const char * const label =
2551 PL_op->op_flags & OPf_STACKED
2552 ? SvPV(TOPs,label_len)
2553 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2554 const U32 label_flags =
2555 PL_op->op_flags & OPf_STACKED
2557 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2559 cxix = dopoptolabel(label, label_len, label_flags);
2561 /* diag_listed_as: Label not found for "last %s" */
2562 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2564 SVfARG(PL_op->op_flags & OPf_STACKED
2565 && !SvGMAGICAL(TOPp1s)
2567 : newSVpvn_flags(label,
2569 label_flags | SVs_TEMP)));
2571 if (cxix < cxstack_ix)
2587 S_unwind_loop(aTHX_ "last");
2590 cxstack_ix++; /* temporarily protect top context */
2591 switch (CxTYPE(cx)) {
2592 case CXt_LOOP_LAZYIV:
2593 case CXt_LOOP_LAZYSV:
2595 case CXt_LOOP_PLAIN:
2597 newsp = PL_stack_base + cx->blk_loop.resetsp;
2598 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2602 nextop = cx->blk_sub.retop;
2606 nextop = cx->blk_eval.retop;
2610 nextop = cx->blk_sub.retop;
2613 DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2617 PL_stack_sp = newsp;
2621 /* Stack values are safe: */
2623 case CXt_LOOP_LAZYIV:
2624 case CXt_LOOP_PLAIN:
2625 case CXt_LOOP_LAZYSV:
2627 POPLOOP(cx); /* release loop vars ... */
2631 POPSUB(cx,sv); /* release CV and @_ ... */
2634 PL_curpm = newpm; /* ... and pop $1 et al */
2637 PERL_UNUSED_VAR(optype);
2638 PERL_UNUSED_VAR(gimme);
2645 const I32 inner = PL_scopestack_ix;
2647 S_unwind_loop(aTHX_ "next");
2649 /* clear off anything above the scope we're re-entering, but
2650 * save the rest until after a possible continue block */
2652 if (PL_scopestack_ix < inner)
2653 leave_scope(PL_scopestack[PL_scopestack_ix]);
2654 PL_curcop = cx->blk_oldcop;
2656 return (cx)->blk_loop.my_op->op_nextop;
2661 const I32 cxix = S_unwind_loop(aTHX_ "redo");
2664 OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2666 if (redo_op->op_type == OP_ENTER) {
2667 /* pop one less context to avoid $x being freed in while (my $x..) */
2669 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2670 redo_op = redo_op->op_next;
2674 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2675 LEAVE_SCOPE(oldsave);
2677 PL_curcop = cx->blk_oldcop;
2683 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2686 static const char* const too_deep = "Target of goto is too deeply nested";
2688 PERL_ARGS_ASSERT_DOFINDLABEL;
2691 Perl_croak(aTHX_ "%s", too_deep);
2692 if (o->op_type == OP_LEAVE ||
2693 o->op_type == OP_SCOPE ||
2694 o->op_type == OP_LEAVELOOP ||
2695 o->op_type == OP_LEAVESUB ||
2696 o->op_type == OP_LEAVETRY)
2698 *ops++ = cUNOPo->op_first;
2700 Perl_croak(aTHX_ "%s", too_deep);
2703 if (o->op_flags & OPf_KIDS) {
2705 /* First try all the kids at this level, since that's likeliest. */
2706 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2707 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2708 STRLEN kid_label_len;
2709 U32 kid_label_flags;
2710 const char *kid_label = CopLABEL_len_flags(kCOP,
2711 &kid_label_len, &kid_label_flags);
2713 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2716 (const U8*)kid_label, kid_label_len,
2717 (const U8*)label, len) == 0)
2719 (const U8*)label, len,
2720 (const U8*)kid_label, kid_label_len) == 0)
2721 : ( len == kid_label_len && ((kid_label == label)
2722 || memEQ(kid_label, label, len)))))
2726 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2727 if (kid == PL_lastgotoprobe)
2729 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2732 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2733 ops[-1]->op_type == OP_DBSTATE)
2738 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2747 /* also used for: pp_dump() */
2755 #define GOTO_DEPTH 64
2756 OP *enterops[GOTO_DEPTH];
2757 const char *label = NULL;
2758 STRLEN label_len = 0;
2759 U32 label_flags = 0;
2760 const bool do_dump = (PL_op->op_type == OP_DUMP);
2761 static const char* const must_have_label = "goto must have label";
2763 if (PL_op->op_flags & OPf_STACKED) {
2764 /* goto EXPR or goto &foo */
2766 SV * const sv = POPs;
2769 /* This egregious kludge implements goto &subroutine */
2770 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2773 CV *cv = MUTABLE_CV(SvRV(sv));
2774 AV *arg = GvAV(PL_defgv);
2778 if (!CvROOT(cv) && !CvXSUB(cv)) {
2779 const GV * const gv = CvGV(cv);
2783 /* autoloaded stub? */
2784 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2786 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2788 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2789 if (autogv && (cv = GvCV(autogv)))
2791 tmpstr = sv_newmortal();
2792 gv_efullname3(tmpstr, gv, NULL);
2793 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2795 DIE(aTHX_ "Goto undefined subroutine");
2798 /* First do some returnish stuff. */
2799 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2801 cxix = dopoptosub(cxstack_ix);
2802 if (cxix < cxstack_ix) {
2805 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2811 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2812 if (CxTYPE(cx) == CXt_EVAL) {
2815 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2816 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2818 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2819 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2821 else if (CxMULTICALL(cx))
2824 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2826 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2827 AV* av = cx->blk_sub.argarray;
2829 /* abandon the original @_ if it got reified or if it is
2830 the same as the current @_ */
2831 if (AvREAL(av) || av == arg) {
2835 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2837 else CLEAR_ARGARRAY(av);
2839 /* We donate this refcount later to the callee’s pad. */
2840 SvREFCNT_inc_simple_void(arg);
2841 if (CxTYPE(cx) == CXt_SUB &&
2842 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2843 SvREFCNT_dec(cx->blk_sub.cv);
2844 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2845 LEAVE_SCOPE(oldsave);
2847 /* A destructor called during LEAVE_SCOPE could have undefined
2848 * our precious cv. See bug #99850. */
2849 if (!CvROOT(cv) && !CvXSUB(cv)) {
2850 const GV * const gv = CvGV(cv);
2853 SV * const tmpstr = sv_newmortal();
2854 gv_efullname3(tmpstr, gv, NULL);
2855 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2858 DIE(aTHX_ "Goto undefined subroutine");
2861 /* Now do some callish stuff. */
2863 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2865 OP* const retop = cx->blk_sub.retop;
2868 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2869 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2872 PERL_UNUSED_VAR(newsp);
2873 PERL_UNUSED_VAR(gimme);
2875 /* put GvAV(defgv) back onto stack */
2877 EXTEND(SP, items+1); /* @_ could have been extended. */
2882 bool r = cBOOL(AvREAL(arg));
2883 for (index=0; index<items; index++)
2887 SV ** const svp = av_fetch(arg, index, 0);
2888 sv = svp ? *svp : NULL;
2890 else sv = AvARRAY(arg)[index];
2892 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2893 : sv_2mortal(newSVavdefelem(arg, index, 1));
2898 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2899 /* Restore old @_ */
2900 arg = GvAV(PL_defgv);
2901 GvAV(PL_defgv) = cx->blk_sub.savearray;
2905 /* XS subs don't have a CxSUB, so pop it */
2906 POPBLOCK(cx, PL_curpm);
2907 /* Push a mark for the start of arglist */
2910 (void)(*CvXSUB(cv))(aTHX_ cv);
2916 PADLIST * const padlist = CvPADLIST(cv);
2917 cx->blk_sub.cv = cv;
2918 cx->blk_sub.olddepth = CvDEPTH(cv);
2921 if (CvDEPTH(cv) < 2)
2922 SvREFCNT_inc_simple_void_NN(cv);
2924 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2925 sub_crush_depth(cv);
2926 pad_push(padlist, CvDEPTH(cv));
2928 PL_curcop = cx->blk_oldcop;
2930 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2933 CX_CURPAD_SAVE(cx->blk_sub);
2935 /* cx->blk_sub.argarray has no reference count, so we
2936 need something to hang on to our argument array so
2937 that cx->blk_sub.argarray does not end up pointing
2938 to freed memory as the result of undef *_. So put
2939 it in the callee’s pad, donating our refer-
2942 SvREFCNT_dec(PAD_SVl(0));
2943 PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2946 /* GvAV(PL_defgv) might have been modified on scope
2947 exit, so restore it. */
2948 if (arg != GvAV(PL_defgv)) {
2949 AV * const av = GvAV(PL_defgv);
2950 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2954 else SvREFCNT_dec(arg);
2955 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2956 Perl_get_db_sub(aTHX_ NULL, cv);
2958 CV * const gotocv = get_cvs("DB::goto", 0);
2960 PUSHMARK( PL_stack_sp );
2961 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2967 RETURNOP(CvSTART(cv));
2972 label = SvPV_nomg_const(sv, label_len);
2973 label_flags = SvUTF8(sv);
2976 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2977 /* goto LABEL or dump LABEL */
2978 label = cPVOP->op_pv;
2979 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2980 label_len = strlen(label);
2982 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2987 OP *gotoprobe = NULL;
2988 bool leaving_eval = FALSE;
2989 bool in_block = FALSE;
2990 PERL_CONTEXT *last_eval_cx = NULL;
2994 PL_lastgotoprobe = NULL;
2996 for (ix = cxstack_ix; ix >= 0; ix--) {
2998 switch (CxTYPE(cx)) {
3000 leaving_eval = TRUE;
3001 if (!CxTRYBLOCK(cx)) {
3002 gotoprobe = (last_eval_cx ?
3003 last_eval_cx->blk_eval.old_eval_root :
3008 /* else fall through */
3009 case CXt_LOOP_LAZYIV:
3010 case CXt_LOOP_LAZYSV:
3012 case CXt_LOOP_PLAIN:
3015 gotoprobe = OP_SIBLING(cx->blk_oldcop);
3021 gotoprobe = OP_SIBLING(cx->blk_oldcop);
3024 gotoprobe = PL_main_root;
3027 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3028 gotoprobe = CvROOT(cx->blk_sub.cv);
3034 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3037 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3038 CxTYPE(cx), (long) ix);
3039 gotoprobe = PL_main_root;
3045 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3046 enterops, enterops + GOTO_DEPTH);
3049 if ( (sibl1 = OP_SIBLING(gotoprobe)) &&
3050 sibl1->op_type == OP_UNSTACK &&
3051 (sibl2 = OP_SIBLING(sibl1)))
3053 retop = dofindlabel(sibl2,
3054 label, label_len, label_flags, enterops,
3055 enterops + GOTO_DEPTH);
3060 PL_lastgotoprobe = gotoprobe;
3063 DIE(aTHX_ "Can't find label %"UTF8f,
3064 UTF8fARG(label_flags, label_len, label));
3066 /* if we're leaving an eval, check before we pop any frames
3067 that we're not going to punt, otherwise the error
3070 if (leaving_eval && *enterops && enterops[1]) {
3072 for (i = 1; enterops[i]; i++)
3073 if (enterops[i]->op_type == OP_ENTERITER)
3074 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3077 if (*enterops && enterops[1]) {
3078 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3080 deprecate("\"goto\" to jump into a construct");
3083 /* pop unwanted frames */
3085 if (ix < cxstack_ix) {
3089 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3092 oldsave = PL_scopestack[PL_scopestack_ix];
3093 LEAVE_SCOPE(oldsave);
3096 /* push wanted frames */
3098 if (*enterops && enterops[1]) {
3099 OP * const oldop = PL_op;
3100 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3101 for (; enterops[ix]; ix++) {
3102 PL_op = enterops[ix];
3103 /* Eventually we may want to stack the needed arguments
3104 * for each op. For now, we punt on the hard ones. */
3105 if (PL_op->op_type == OP_ENTERITER)
3106 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3107 PL_op->op_ppaddr(aTHX);
3115 if (!retop) retop = PL_main_start;
3117 PL_restartop = retop;
3118 PL_do_undump = TRUE;
3122 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3123 PL_do_undump = FALSE;
3138 anum = 0; (void)POPs;
3144 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3147 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3150 PL_exit_flags |= PERL_EXIT_EXPECTED;
3152 PUSHs(&PL_sv_undef);
3159 S_save_lines(pTHX_ AV *array, SV *sv)
3161 const char *s = SvPVX_const(sv);
3162 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3165 PERL_ARGS_ASSERT_SAVE_LINES;
3167 while (s && s < send) {
3169 SV * const tmpstr = newSV_type(SVt_PVMG);
3171 t = (const char *)memchr(s, '\n', send - s);
3177 sv_setpvn(tmpstr, s, t - s);
3178 av_store(array, line++, tmpstr);
3186 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3188 0 is used as continue inside eval,
3190 3 is used for a die caught by an inner eval - continue inner loop
3192 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3193 establish a local jmpenv to handle exception traps.
3198 S_docatch(pTHX_ OP *o)
3201 OP * const oldop = PL_op;
3205 assert(CATCH_GET == TRUE);
3212 assert(cxstack_ix >= 0);
3213 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3214 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3219 /* die caught by an inner eval - continue inner loop */
3220 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3221 PL_restartjmpenv = NULL;
3222 PL_op = PL_restartop;
3231 assert(0); /* NOTREACHED */
3240 =for apidoc find_runcv
3242 Locate the CV corresponding to the currently executing sub or eval.
3243 If db_seqp is non_null, skip CVs that are in the DB package and populate
3244 *db_seqp with the cop sequence number at the point that the DB:: code was
3245 entered. (This allows debuggers to eval in the scope of the breakpoint
3246 rather than in the scope of the debugger itself.)
3252 Perl_find_runcv(pTHX_ U32 *db_seqp)
3254 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3257 /* If this becomes part of the API, it might need a better name. */
3259 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3266 PL_curcop == &PL_compiling
3268 : PL_curcop->cop_seq;
3270 for (si = PL_curstackinfo; si; si = si->si_prev) {
3272 for (ix = si->si_cxix; ix >= 0; ix--) {
3273 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3275 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3276 cv = cx->blk_sub.cv;
3277 /* skip DB:: code */
3278 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3279 *db_seqp = cx->blk_oldcop->cop_seq;
3282 if (cx->cx_type & CXp_SUB_RE)
3285 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3286 cv = cx->blk_eval.cv;
3289 case FIND_RUNCV_padid_eq:
3291 || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
3294 case FIND_RUNCV_level_eq:
3295 if (level++ != arg) continue;
3303 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3307 /* Run yyparse() in a setjmp wrapper. Returns:
3308 * 0: yyparse() successful
3309 * 1: yyparse() failed
3313 S_try_yyparse(pTHX_ int gramtype)
3318 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3322 ret = yyparse(gramtype) ? 1 : 0;
3329 assert(0); /* NOTREACHED */
3336 /* Compile a require/do or an eval ''.
3338 * outside is the lexically enclosing CV (if any) that invoked us.
3339 * seq is the current COP scope value.
3340 * hh is the saved hints hash, if any.
3342 * Returns a bool indicating whether the compile was successful; if so,
3343 * PL_eval_start contains the first op of the compiled code; otherwise,
3346 * This function is called from two places: pp_require and pp_entereval.
3347 * These can be distinguished by whether PL_op is entereval.
3351 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3354 OP * const saveop = PL_op;
3355 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3356 COP * const oldcurcop = PL_curcop;
3357 bool in_require = (saveop->op_type == OP_REQUIRE);
3361 PL_in_eval = (in_require
3362 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3364 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3365 ? EVAL_RE_REPARSING : 0)));
3369 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3371 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3372 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3373 cxstack[cxstack_ix].blk_gimme = gimme;
3375 CvOUTSIDE_SEQ(evalcv) = seq;
3376 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3378 /* set up a scratch pad */
3380 CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3381 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3384 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3386 /* make sure we compile in the right package */
3388 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3389 SAVEGENERICSV(PL_curstash);
3390 PL_curstash = (HV *)CopSTASH(PL_curcop);
3391 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3392 else SvREFCNT_inc_simple_void(PL_curstash);
3394 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3395 SAVESPTR(PL_beginav);
3396 PL_beginav = newAV();
3397 SAVEFREESV(PL_beginav);
3398 SAVESPTR(PL_unitcheckav);
3399 PL_unitcheckav = newAV();
3400 SAVEFREESV(PL_unitcheckav);
3403 ENTER_with_name("evalcomp");
3404 SAVESPTR(PL_compcv);
3407 /* try to compile it */
3409 PL_eval_root = NULL;
3410 PL_curcop = &PL_compiling;
3411 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3412 PL_in_eval |= EVAL_KEEPERR;
3419 hv_clear(GvHV(PL_hintgv));
3422 PL_hints = saveop->op_private & OPpEVAL_COPHH
3423 ? oldcurcop->cop_hints : saveop->op_targ;
3425 /* making 'use re eval' not be in scope when compiling the
3426 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3427 * infinite recursion when S_has_runtime_code() gives a false
3428 * positive: the second time round, HINT_RE_EVAL isn't set so we
3429 * don't bother calling S_has_runtime_code() */
3430 if (PL_in_eval & EVAL_RE_REPARSING)
3431 PL_hints &= ~HINT_RE_EVAL;
3434 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3435 SvREFCNT_dec(GvHV(PL_hintgv));
3436 GvHV(PL_hintgv) = hh;
3439 SAVECOMPILEWARNINGS();
3441 if (PL_dowarn & G_WARN_ALL_ON)
3442 PL_compiling.cop_warnings = pWARN_ALL ;
3443 else if (PL_dowarn & G_WARN_ALL_OFF)
3444 PL_compiling.cop_warnings = pWARN_NONE ;
3446 PL_compiling.cop_warnings = pWARN_STD ;
3449 PL_compiling.cop_warnings =
3450 DUP_WARNINGS(oldcurcop->cop_warnings);
3451 cophh_free(CopHINTHASH_get(&PL_compiling));
3452 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3453 /* The label, if present, is the first entry on the chain. So rather
3454 than writing a blank label in front of it (which involves an
3455 allocation), just use the next entry in the chain. */
3456 PL_compiling.cop_hints_hash
3457 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3458 /* Check the assumption that this removed the label. */
3459 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3462 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3465 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3467 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3468 * so honour CATCH_GET and trap it here if necessary */
3470 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3472 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3473 SV **newsp; /* Used by POPBLOCK. */
3475 I32 optype; /* Used by POPEVAL. */
3481 PERL_UNUSED_VAR(newsp);
3482 PERL_UNUSED_VAR(optype);
3484 /* note that if yystatus == 3, then the EVAL CX block has already
3485 * been popped, and various vars restored */
3487 if (yystatus != 3) {
3489 op_free(PL_eval_root);
3490 PL_eval_root = NULL;
3492 SP = PL_stack_base + POPMARK; /* pop original mark */
3493 POPBLOCK(cx,PL_curpm);
3495 namesv = cx->blk_eval.old_namesv;
3496 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3497 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3503 /* If cx is still NULL, it means that we didn't go in the
3504 * POPEVAL branch. */
3505 cx = &cxstack[cxstack_ix];
3506 assert(CxTYPE(cx) == CXt_EVAL);
3507 namesv = cx->blk_eval.old_namesv;
3509 (void)hv_store(GvHVn(PL_incgv),
3510 SvPVX_const(namesv),
3511 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3513 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3516 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3519 if (!*(SvPV_nolen_const(errsv))) {
3520 sv_setpvs(errsv, "Compilation error");
3523 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3528 LEAVE_with_name("evalcomp");
3530 CopLINE_set(&PL_compiling, 0);
3531 SAVEFREEOP(PL_eval_root);
3532 cv_forget_slab(evalcv);
3534 DEBUG_x(dump_eval());
3536 /* Register with debugger: */
3537 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3538 CV * const cv = get_cvs("DB::postponed", 0);
3542 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3544 call_sv(MUTABLE_SV(cv), G_DISCARD);
3548 if (PL_unitcheckav) {
3549 OP *es = PL_eval_start;
3550 call_list(PL_scopestack_ix, PL_unitcheckav);
3554 /* compiled okay, so do it */
3556 CvDEPTH(evalcv) = 1;
3557 SP = PL_stack_base + POPMARK; /* pop original mark */
3558 PL_op = saveop; /* The caller may need it. */
3559 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3566 S_check_type_and_open(pTHX_ SV *name)
3570 const char *p = SvPV_const(name, len);
3573 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3575 /* checking here captures a reasonable error message when
3576 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3577 * user gets a confusing message about looking for the .pmc file
3578 * rather than for the .pm file.
3579 * This check prevents a \0 in @INC causing problems.
3581 if (!IS_SAFE_PATHNAME(p, len, "require"))
3584 /* we use the value of errno later to see how stat() or open() failed.
3585 * We don't want it set if the stat succeeded but we still failed,
3586 * such as if the name exists, but is a directory */
3589 st_rc = PerlLIO_stat(p, &st);
3591 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3595 #if !defined(PERLIO_IS_STDIO)
3596 return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3598 return PerlIO_open(p, PERL_SCRIPT_MODE);
3602 #ifndef PERL_DISABLE_PMC
3604 S_doopen_pm(pTHX_ SV *name)
3607 const char *p = SvPV_const(name, namelen);
3609 PERL_ARGS_ASSERT_DOOPEN_PM;
3611 /* check the name before trying for the .pmc name to avoid the
3612 * warning referring to the .pmc which the user probably doesn't
3613 * know or care about
3615 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3618 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3619 SV *const pmcsv = sv_newmortal();
3622 SvSetSV_nosteal(pmcsv,name);
3623 sv_catpvs(pmcsv, "c");
3625 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3626 return check_type_and_open(pmcsv);
3628 return check_type_and_open(name);
3631 # define doopen_pm(name) check_type_and_open(name)
3632 #endif /* !PERL_DISABLE_PMC */
3634 /* require doesn't search for absolute names, or when the name is
3635 explicity relative the current directory */
3636 PERL_STATIC_INLINE bool
3637 S_path_is_searchable(const char *name)
3639 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3641 if (PERL_FILE_IS_ABSOLUTE(name)
3643 || (*name == '.' && ((name[1] == '/' ||
3644 (name[1] == '.' && name[2] == '/'))
3645 || (name[1] == '\\' ||
3646 ( name[1] == '.' && name[2] == '\\')))
3649 || (*name == '.' && (name[1] == '/' ||
3650 (name[1] == '.' && name[2] == '/')))
3661 /* also used for: pp_dofile() */
3673 int vms_unixname = 0;
3676 const char *tryname = NULL;
3678 const I32 gimme = GIMME_V;
3679 int filter_has_file = 0;
3680 PerlIO *tryrsfp = NULL;
3681 SV *filter_cache = NULL;
3682 SV *filter_state = NULL;
3683 SV *filter_sub = NULL;
3688 bool path_searchable;
3692 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3693 sv = sv_2mortal(new_version(sv));
3694 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3695 upg_version(PL_patchlevel, TRUE);
3696 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3697 if ( vcmp(sv,PL_patchlevel) <= 0 )
3698 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3699 SVfARG(sv_2mortal(vnormal(sv))),
3700 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3704 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3707 SV * const req = SvRV(sv);
3708 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3710 /* get the left hand term */
3711 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3713 first = SvIV(*av_fetch(lav,0,0));
3714 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3715 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3716 || av_tindex(lav) > 1 /* FP with > 3 digits */
3717 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3719 DIE(aTHX_ "Perl %"SVf" required--this is only "
3721 SVfARG(sv_2mortal(vnormal(req))),
3722 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3725 else { /* probably 'use 5.10' or 'use 5.8' */
3729 if (av_tindex(lav)>=1)
3730 second = SvIV(*av_fetch(lav,1,0));
3732 second /= second >= 600 ? 100 : 10;
3733 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3734 (int)first, (int)second);
3735 upg_version(hintsv, TRUE);
3737 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3738 "--this is only %"SVf", stopped",
3739 SVfARG(sv_2mortal(vnormal(req))),
3740 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3741 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3750 DIE(aTHX_ "Missing or undefined argument to require");
3751 name = SvPV_nomg_const(sv, len);
3752 if (!(name && len > 0 && *name))
3753 DIE(aTHX_ "Missing or undefined argument to require");
3755 if (!IS_SAFE_PATHNAME(name, len, "require")) {
3756 DIE(aTHX_ "Can't locate %s: %s",
3757 pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3758 SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3761 TAINT_PROPER("require");
3763 path_searchable = path_is_searchable(name);
3766 /* The key in the %ENV hash is in the syntax of file passed as the argument
3767 * usually this is in UNIX format, but sometimes in VMS format, which
3768 * can result in a module being pulled in more than once.
3769 * To prevent this, the key must be stored in UNIX format if the VMS
3770 * name can be translated to UNIX.
3774 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3776 unixlen = strlen(unixname);
3782 /* if not VMS or VMS name can not be translated to UNIX, pass it
3785 unixname = (char *) name;
3788 if (PL_op->op_type == OP_REQUIRE) {
3789 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3790 unixname, unixlen, 0);
3792 if (*svp != &PL_sv_undef)
3795 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3796 "Compilation failed in require", unixname);
3800 LOADING_FILE_PROBE(unixname);
3802 /* prepare to compile file */
3804 if (!path_searchable) {
3805 /* At this point, name is SvPVX(sv) */
3807 tryrsfp = doopen_pm(sv);
3809 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3810 AV * const ar = GvAVn(PL_incgv);
3817 namesv = newSV_type(SVt_PV);
3818 for (i = 0; i <= AvFILL(ar); i++) {
3819 SV * const dirsv = *av_fetch(ar, i, TRUE);
3827 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3828 && !SvOBJECT(SvRV(loader)))
3830 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3834 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3835 PTR2UV(SvRV(dirsv)), name);
3836 tryname = SvPVX_const(namesv);
3839 if (SvPADTMP(nsv)) {
3840 nsv = sv_newmortal();
3841 SvSetSV_nosteal(nsv,sv);
3844 ENTER_with_name("call_INC");
3852 if (SvGMAGICAL(loader)) {
3853 SV *l = sv_newmortal();
3854 sv_setsv_nomg(l, loader);
3857 if (sv_isobject(loader))
3858 count = call_method("INC", G_ARRAY);
3860 count = call_sv(loader, G_ARRAY);
3870 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3871 && !isGV_with_GP(SvRV(arg))) {
3872 filter_cache = SvRV(arg);
3879 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3883 if (isGV_with_GP(arg)) {
3884 IO * const io = GvIO((const GV *)arg);
3889 tryrsfp = IoIFP(io);
3890 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3891 PerlIO_close(IoOFP(io));
3902 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3904 SvREFCNT_inc_simple_void_NN(filter_sub);
3907 filter_state = SP[i];
3908 SvREFCNT_inc_simple_void(filter_state);
3912 if (!tryrsfp && (filter_cache || filter_sub)) {
3913 tryrsfp = PerlIO_open(BIT_BUCKET,
3919 /* FREETMPS may free our filter_cache */
3920 SvREFCNT_inc_simple_void(filter_cache);
3924 LEAVE_with_name("call_INC");
3926 /* Now re-mortalize it. */
3927 sv_2mortal(filter_cache);
3929 /* Adjust file name if the hook has set an %INC entry.
3930 This needs to happen after the FREETMPS above. */
3931 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3933 tryname = SvPV_nolen_const(*svp);
3940 filter_has_file = 0;
3941 filter_cache = NULL;
3943 SvREFCNT_dec_NN(filter_state);
3944 filter_state = NULL;
3947 SvREFCNT_dec_NN(filter_sub);
3952 if (path_searchable) {
3957 dir = SvPV_nomg_const(dirsv, dirlen);
3963 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3967 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3970 sv_setpv(namesv, unixdir);
3971 sv_catpv(namesv, unixname);
3973 # ifdef __SYMBIAN32__
3974 if (PL_origfilename[0] &&
3975 PL_origfilename[1] == ':' &&
3976 !(dir[0] && dir[1] == ':'))
3977 Perl_sv_setpvf(aTHX_ namesv,
3982 Perl_sv_setpvf(aTHX_ namesv,
3986 /* The equivalent of
3987 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3988 but without the need to parse the format string, or
3989 call strlen on either pointer, and with the correct
3990 allocation up front. */
3992 char *tmp = SvGROW(namesv, dirlen + len + 2);
3994 memcpy(tmp, dir, dirlen);
3997 /* Avoid '<dir>//<file>' */
3998 if (!dirlen || *(tmp-1) != '/') {
4001 /* So SvCUR_set reports the correct length below */
4005 /* name came from an SV, so it will have a '\0' at the
4006 end that we can copy as part of this memcpy(). */
4007 memcpy(tmp, name, len + 1);
4009 SvCUR_set(namesv, dirlen + len + 1);
4014 TAINT_PROPER("require");
4015 tryname = SvPVX_const(namesv);
4016 tryrsfp = doopen_pm(namesv);
4018 if (tryname[0] == '.' && tryname[1] == '/') {
4020 while (*++tryname == '/') {}
4024 else if (errno == EMFILE || errno == EACCES) {
4025 /* no point in trying other paths if out of handles;
4026 * on the other hand, if we couldn't open one of the
4027 * files, then going on with the search could lead to
4028 * unexpected results; see perl #113422
4037 saved_errno = errno; /* sv_2mortal can realloc things */
4040 if (PL_op->op_type == OP_REQUIRE) {
4041 if(saved_errno == EMFILE || saved_errno == EACCES) {
4042 /* diag_listed_as: Can't locate %s */
4043 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno));
4045 if (namesv) { /* did we lookup @INC? */
4046 AV * const ar = GvAVn(PL_incgv);
4048 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4049 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4050 for (i = 0; i <= AvFILL(ar); i++) {
4051 sv_catpvs(inc, " ");
4052 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4054 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4055 const char *c, *e = name + len - 3;
4056 sv_catpv(msg, " (you may need to install the ");
4057 for (c = name; c < e; c++) {
4059 sv_catpvs(msg, "::");
4062 sv_catpvn(msg, c, 1);
4065 sv_catpv(msg, " module)");
4067 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4068 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4070 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4071 sv_catpv(msg, " (did you run h2ph?)");
4074 /* diag_listed_as: Can't locate %s */
4076 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4080 DIE(aTHX_ "Can't locate %s", name);
4087 SETERRNO(0, SS_NORMAL);
4089 /* Assume success here to prevent recursive requirement. */
4090 /* name is never assigned to again, so len is still strlen(name) */
4091 /* Check whether a hook in @INC has already filled %INC */
4093 (void)hv_store(GvHVn(PL_incgv),
4094 unixname, unixlen, newSVpv(tryname,0),0);
4096 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4098 (void)hv_store(GvHVn(PL_incgv),
4099 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4102 ENTER_with_name("eval");
4104 SAVECOPFILE_FREE(&PL_compiling);
4105 CopFILE_set(&PL_compiling, tryname);
4106 lex_start(NULL, tryrsfp, 0);
4108 if (filter_sub || filter_cache) {
4109 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4110 than hanging another SV from it. In turn, filter_add() optionally
4111 takes the SV to use as the filter (or creates a new SV if passed
4112 NULL), so simply pass in whatever value filter_cache has. */
4113 SV * const fc = filter_cache ? newSV(0) : NULL;
4115 if (fc) sv_copypv(fc, filter_cache);
4116 datasv = filter_add(S_run_user_filter, fc);
4117 IoLINES(datasv) = filter_has_file;
4118 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4119 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4122 /* switch to eval mode */
4123 PUSHBLOCK(cx, CXt_EVAL, SP);
4125 cx->blk_eval.retop = PL_op->op_next;
4127 SAVECOPLINE(&PL_compiling);
4128 CopLINE_set(&PL_compiling, 0);
4132 /* Store and reset encoding. */
4133 encoding = PL_encoding;
4136 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4137 op = DOCATCH(PL_eval_start);
4139 op = PL_op->op_next;
4141 /* Restore encoding. */
4142 PL_encoding = encoding;
4144 LOADED_FILE_PROBE(unixname);
4149 /* This is a op added to hold the hints hash for
4150 pp_entereval. The hash can be modified by the code
4151 being eval'ed, so we return a copy instead. */
4156 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4166 const I32 gimme = GIMME_V;
4167 const U32 was = PL_breakable_sub_gen;
4168 char tbuf[TYPE_DIGITS(long) + 12];
4169 bool saved_delete = FALSE;
4170 char *tmpbuf = tbuf;
4173 U32 seq, lex_flags = 0;
4174 HV *saved_hh = NULL;
4175 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4177 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4178 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4180 else if (PL_hints & HINT_LOCALIZE_HH || (
4181 PL_op->op_private & OPpEVAL_COPHH
4182 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4184 saved_hh = cop_hints_2hv(PL_curcop, 0);
4185 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4189 /* make sure we've got a plain PV (no overload etc) before testing
4190 * for taint. Making a copy here is probably overkill, but better
4191 * safe than sorry */
4193 const char * const p = SvPV_const(sv, len);
4195 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4196 lex_flags |= LEX_START_COPIED;
4198 if (bytes && SvUTF8(sv))
4199 SvPVbyte_force(sv, len);
4201 else if (bytes && SvUTF8(sv)) {
4202 /* Don't modify someone else's scalar */
4205 (void)sv_2mortal(sv);
4206 SvPVbyte_force(sv,len);
4207 lex_flags |= LEX_START_COPIED;
4210 TAINT_IF(SvTAINTED(sv));
4211 TAINT_PROPER("eval");
4213 ENTER_with_name("eval");
4214 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4215 ? LEX_IGNORE_UTF8_HINTS
4216 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4221 /* switch to eval mode */
4223 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4224 SV * const temp_sv = sv_newmortal();
4225 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4226 (unsigned long)++PL_evalseq,
4227 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4228 tmpbuf = SvPVX(temp_sv);
4229 len = SvCUR(temp_sv);
4232 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4233 SAVECOPFILE_FREE(&PL_compiling);
4234 CopFILE_set(&PL_compiling, tmpbuf+2);
4235 SAVECOPLINE(&PL_compiling);
4236 CopLINE_set(&PL_compiling, 1);
4237 /* special case: an eval '' executed within the DB package gets lexically
4238 * placed in the first non-DB CV rather than the current CV - this
4239 * allows the debugger to execute code, find lexicals etc, in the
4240 * scope of the code being debugged. Passing &seq gets find_runcv
4241 * to do the dirty work for us */
4242 runcv = find_runcv(&seq);
4244 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4246 cx->blk_eval.retop = PL_op->op_next;
4248 /* prepare to compile string */
4250 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4251 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4253 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4254 deleting the eval's FILEGV from the stash before gv_check() runs
4255 (i.e. before run-time proper). To work around the coredump that
4256 ensues, we always turn GvMULTI_on for any globals that were
4257 introduced within evals. See force_ident(). GSAR 96-10-12 */
4258 char *const safestr = savepvn(tmpbuf, len);
4259 SAVEDELETE(PL_defstash, safestr, len);
4260 saved_delete = TRUE;
4265 if (doeval(gimme, runcv, seq, saved_hh)) {
4266 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4267 ? (PERLDB_LINE || PERLDB_SAVESRC)
4268 : PERLDB_SAVESRC_NOSUBS) {
4269 /* Retain the filegv we created. */
4270 } else if (!saved_delete) {
4271 char *const safestr = savepvn(tmpbuf, len);
4272 SAVEDELETE(PL_defstash, safestr, len);
4274 return DOCATCH(PL_eval_start);
4276 /* We have already left the scope set up earlier thanks to the LEAVE
4278 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4279 ? (PERLDB_LINE || PERLDB_SAVESRC)
4280 : PERLDB_SAVESRC_INVALID) {
4281 /* Retain the filegv we created. */
4282 } else if (!saved_delete) {
4283 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4285 return PL_op->op_next;
4297 const U8 save_flags = PL_op -> op_flags;
4305 namesv = cx->blk_eval.old_namesv;
4306 retop = cx->blk_eval.retop;
4307 evalcv = cx->blk_eval.cv;
4309 SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
4310 gimme, SVs_TEMP, FALSE);
4311 PL_curpm = newpm; /* Don't pop $1 et al till now */
4314 assert(CvDEPTH(evalcv) == 1);
4316 CvDEPTH(evalcv) = 0;
4318 if (optype == OP_REQUIRE &&
4319 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4321 /* Unassume the success we assumed earlier. */
4322 (void)hv_delete(GvHVn(PL_incgv),
4323 SvPVX_const(namesv),
4324 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4326 Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4327 NOT_REACHED; /* NOTREACHED */
4328 /* die_unwind() did LEAVE, or we won't be here */
4331 LEAVE_with_name("eval");
4332 if (!(save_flags & OPf_SPECIAL)) {
4340 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4341 close to the related Perl_create_eval_scope. */
4343 Perl_delete_eval_scope(pTHX)
4354 LEAVE_with_name("eval_scope");
4355 PERL_UNUSED_VAR(newsp);
4356 PERL_UNUSED_VAR(gimme);
4357 PERL_UNUSED_VAR(optype);
4360 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4361 also needed by Perl_fold_constants. */
4363 Perl_create_eval_scope(pTHX_ U32 flags)
4366 const I32 gimme = GIMME_V;
4368 ENTER_with_name("eval_scope");
4371 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4374 PL_in_eval = EVAL_INEVAL;
4375 if (flags & G_KEEPERR)
4376 PL_in_eval |= EVAL_KEEPERR;
4379 if (flags & G_FAKINGEVAL) {
4380 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4387 PERL_CONTEXT * const cx = create_eval_scope(0);
4388 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4389 return DOCATCH(PL_op->op_next);
4404 PERL_UNUSED_VAR(optype);
4406 SP = leave_common(newsp, SP, newsp, gimme,
4407 SVs_PADTMP|SVs_TEMP, FALSE);
4408 PL_curpm = newpm; /* Don't pop $1 et al till now */
4410 LEAVE_with_name("eval_scope");
4419 const I32 gimme = GIMME_V;
4421 ENTER_with_name("given");
4424 if (PL_op->op_targ) {
4425 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4426 SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4427 PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4434 PUSHBLOCK(cx, CXt_GIVEN, SP);
4447 PERL_UNUSED_CONTEXT;
4450 assert(CxTYPE(cx) == CXt_GIVEN);
4452 SP = leave_common(newsp, SP, newsp, gimme,
4453 SVs_PADTMP|SVs_TEMP, FALSE);
4454 PL_curpm = newpm; /* Don't pop $1 et al till now */
4456 LEAVE_with_name("given");
4460 /* Helper routines used by pp_smartmatch */
4462 S_make_matcher(pTHX_ REGEXP *re)
4464 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4466 PERL_ARGS_ASSERT_MAKE_MATCHER;
4468 PM_SETRE(matcher, ReREFCNT_inc(re));
4470 SAVEFREEOP((OP *) matcher);
4471 ENTER_with_name("matcher"); SAVETMPS;
4477 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4481 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4483 PL_op = (OP *) matcher;
4486 (void) Perl_pp_match(aTHX);
4488 return (SvTRUEx(POPs));
4492 S_destroy_matcher(pTHX_ PMOP *matcher)
4494 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4495 PERL_UNUSED_ARG(matcher);
4498 LEAVE_with_name("matcher");
4501 /* Do a smart match */
4504 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4505 return do_smartmatch(NULL, NULL, 0);
4508 /* This version of do_smartmatch() implements the
4509 * table of smart matches that is found in perlsyn.
4512 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4516 bool object_on_left = FALSE;
4517 SV *e = TOPs; /* e is for 'expression' */
4518 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4520 /* Take care only to invoke mg_get() once for each argument.
4521 * Currently we do this by copying the SV if it's magical. */
4523 if (!copied && SvGMAGICAL(d))
4524 d = sv_mortalcopy(d);
4531 e = sv_mortalcopy(e);
4533 /* First of all, handle overload magic of the rightmost argument */
4536 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4537 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4539 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4546 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4549 SP -= 2; /* Pop the values */
4554 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4561 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4562 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4563 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4565 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4566 object_on_left = TRUE;
4569 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4571 if (object_on_left) {
4572 goto sm_any_sub; /* Treat objects like scalars */
4574 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4575 /* Test sub truth for each key */
4577 bool andedresults = TRUE;
4578 HV *hv = (HV*) SvRV(d);
4579 I32 numkeys = hv_iterinit(hv);
4580 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4583 while ( (he = hv_iternext(hv)) ) {
4584 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4585 ENTER_with_name("smartmatch_hash_key_test");
4588 PUSHs(hv_iterkeysv(he));
4590 c = call_sv(e, G_SCALAR);
4593 andedresults = FALSE;
4595 andedresults = SvTRUEx(POPs) && andedresults;
4597 LEAVE_with_name("smartmatch_hash_key_test");
4604 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4605 /* Test sub truth for each element */
4607 bool andedresults = TRUE;
4608 AV *av = (AV*) SvRV(d);
4609 const I32 len = av_tindex(av);
4610 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4613 for (i = 0; i <= len; ++i) {
4614 SV * const * const svp = av_fetch(av, i, FALSE);
4615 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4616 ENTER_with_name("smartmatch_array_elem_test");
4622 c = call_sv(e, G_SCALAR);
4625 andedresults = FALSE;
4627 andedresults = SvTRUEx(POPs) && andedresults;
4629 LEAVE_with_name("smartmatch_array_elem_test");
4638 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4639 ENTER_with_name("smartmatch_coderef");
4644 c = call_sv(e, G_SCALAR);
4648 else if (SvTEMP(TOPs))
4649 SvREFCNT_inc_void(TOPs);
4651 LEAVE_with_name("smartmatch_coderef");
4656 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4657 if (object_on_left) {
4658 goto sm_any_hash; /* Treat objects like scalars */
4660 else if (!SvOK(d)) {
4661 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4664 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4665 /* Check that the key-sets are identical */
4667 HV *other_hv = MUTABLE_HV(SvRV(d));
4670 U32 this_key_count = 0,
4671 other_key_count = 0;
4672 HV *hv = MUTABLE_HV(SvRV(e));
4674 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4675 /* Tied hashes don't know how many keys they have. */
4676 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4677 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4681 HV * const temp = other_hv;
4687 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4691 /* The hashes have the same number of keys, so it suffices
4692 to check that one is a subset of the other. */
4693 (void) hv_iterinit(hv);
4694 while ( (he = hv_iternext(hv)) ) {
4695 SV *key = hv_iterkeysv(he);
4697 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4700 if(!hv_exists_ent(other_hv, key, 0)) {
4701 (void) hv_iterinit(hv); /* reset iterator */
4707 (void) hv_iterinit(other_hv);
4708 while ( hv_iternext(other_hv) )
4712 other_key_count = HvUSEDKEYS(other_hv);
4714 if (this_key_count != other_key_count)
4719 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4720 AV * const other_av = MUTABLE_AV(SvRV(d));
4721 const SSize_t other_len = av_tindex(other_av) + 1;
4723 HV *hv = MUTABLE_HV(SvRV(e));
4725 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4726 for (i = 0; i < other_len; ++i) {
4727 SV ** const svp = av_fetch(other_av, i, FALSE);
4728 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4729 if (svp) { /* ??? When can this not happen? */
4730 if (hv_exists_ent(hv, *svp, 0))
4736 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4737 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4740 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4742 HV *hv = MUTABLE_HV(SvRV(e));
4744 (void) hv_iterinit(hv);
4745 while ( (he = hv_iternext(hv)) ) {
4746 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4747 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4748 (void) hv_iterinit(hv);
4749 destroy_matcher(matcher);
4753 destroy_matcher(matcher);
4759 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4760 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4767 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4768 if (object_on_left) {
4769 goto sm_any_array; /* Treat objects like scalars */
4771 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4772 AV * const other_av = MUTABLE_AV(SvRV(e));
4773 const SSize_t other_len = av_tindex(other_av) + 1;
4776 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4777 for (i = 0; i < other_len; ++i) {
4778 SV ** const svp = av_fetch(other_av, i, FALSE);
4780 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4781 if (svp) { /* ??? When can this not happen? */
4782 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4788 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4789 AV *other_av = MUTABLE_AV(SvRV(d));
4790 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4791 if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4795 const SSize_t other_len = av_tindex(other_av);
4797 if (NULL == seen_this) {
4798 seen_this = newHV();
4799 (void) sv_2mortal(MUTABLE_SV(seen_this));
4801 if (NULL == seen_other) {
4802 seen_other = newHV();
4803 (void) sv_2mortal(MUTABLE_SV(seen_other));
4805 for(i = 0; i <= other_len; ++i) {
4806 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4807 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4809 if (!this_elem || !other_elem) {
4810 if ((this_elem && SvOK(*this_elem))
4811 || (other_elem && SvOK(*other_elem)))
4814 else if (hv_exists_ent(seen_this,
4815 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4816 hv_exists_ent(seen_other,
4817 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4819 if (*this_elem != *other_elem)
4823 (void)hv_store_ent(seen_this,
4824 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4826 (void)hv_store_ent(seen_other,
4827 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4833 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4834 (void) do_smartmatch(seen_this, seen_other, 0);
4836 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4845 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4846 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4849 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4850 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4853 for(i = 0; i <= this_len; ++i) {
4854 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4855 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4856 if (svp && matcher_matches_sv(matcher, *svp)) {
4857 destroy_matcher(matcher);
4861 destroy_matcher(matcher);
4865 else if (!SvOK(d)) {
4866 /* undef ~~ array */
4867 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4870 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4871 for (i = 0; i <= this_len; ++i) {
4872 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4873 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4874 if (!svp || !SvOK(*svp))
4883 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4885 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4886 for (i = 0; i <= this_len; ++i) {
4887 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4894 /* infinite recursion isn't supposed to happen here */
4895 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4896 (void) do_smartmatch(NULL, NULL, 1);
4898 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4907 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4908 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4909 SV *t = d; d = e; e = t;
4910 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4913 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4914 SV *t = d; d = e; e = t;
4915 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4916 goto sm_regex_array;
4919 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4921 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4923 PUSHs(matcher_matches_sv(matcher, d)
4926 destroy_matcher(matcher);
4931 /* See if there is overload magic on left */
4932 else if (object_on_left && SvAMAGIC(d)) {
4934 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4935 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4938 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4946 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4949 else if (!SvOK(d)) {
4950 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4951 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4956 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4957 DEBUG_M(if (SvNIOK(e))
4958 Perl_deb(aTHX_ " applying rule Any-Num\n");
4960 Perl_deb(aTHX_ " applying rule Num-numish\n");
4962 /* numeric comparison */
4965 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4966 (void) Perl_pp_i_eq(aTHX);
4968 (void) Perl_pp_eq(aTHX);
4976 /* As a last resort, use string comparison */
4977 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4980 return Perl_pp_seq(aTHX);
4987 const I32 gimme = GIMME_V;
4989 /* This is essentially an optimization: if the match
4990 fails, we don't want to push a context and then
4991 pop it again right away, so we skip straight
4992 to the op that follows the leavewhen.
4993 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4995 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4996 RETURNOP(cLOGOP->op_other->op_next);
4998 ENTER_with_name("when");
5001 PUSHBLOCK(cx, CXt_WHEN, SP);
5016 cxix = dopoptogiven(cxstack_ix);
5018 /* diag_listed_as: Can't "when" outside a topicalizer */
5019 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5020 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5023 assert(CxTYPE(cx) == CXt_WHEN);
5025 SP = leave_common(newsp, SP, newsp, gimme,
5026 SVs_PADTMP|SVs_TEMP, FALSE);
5027 PL_curpm = newpm; /* pop $1 et al */
5029 LEAVE_with_name("when");
5031 if (cxix < cxstack_ix)
5034 cx = &cxstack[cxix];
5036 if (CxFOREACH(cx)) {
5037 /* clear off anything above the scope we're re-entering */
5038 I32 inner = PL_scopestack_ix;
5041 if (PL_scopestack_ix < inner)
5042 leave_scope(PL_scopestack[PL_scopestack_ix]);
5043 PL_curcop = cx->blk_oldcop;
5046 return cx->blk_loop.my_op->op_nextop;
5050 RETURNOP(cx->blk_givwhen.leave_op);
5063 PERL_UNUSED_VAR(gimme);
5065 cxix = dopoptowhen(cxstack_ix);
5067 DIE(aTHX_ "Can't \"continue\" outside a when block");
5069 if (cxix < cxstack_ix)
5073 assert(CxTYPE(cx) == CXt_WHEN);
5076 PL_curpm = newpm; /* pop $1 et al */
5078 LEAVE_with_name("when");
5079 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5087 cxix = dopoptogiven(cxstack_ix);
5089 DIE(aTHX_ "Can't \"break\" outside a given block");
5091 cx = &cxstack[cxix];
5093 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5095 if (cxix < cxstack_ix)
5098 /* Restore the sp at the time we entered the given block */
5101 return cx->blk_givwhen.leave_op;
5105 S_doparseform(pTHX_ SV *sv)
5108 char *s = SvPV(sv, len);
5110 char *base = NULL; /* start of current field */
5111 I32 skipspaces = 0; /* number of contiguous spaces seen */
5112 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5113 bool repeat = FALSE; /* ~~ seen on this line */
5114 bool postspace = FALSE; /* a text field may need right padding */
5117 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5119 bool ischop; /* it's a ^ rather than a @ */
5120 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5121 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5125 PERL_ARGS_ASSERT_DOPARSEFORM;
5128 Perl_croak(aTHX_ "Null picture in formline");
5130 if (SvTYPE(sv) >= SVt_PVMG) {
5131 /* This might, of course, still return NULL. */
5132 mg = mg_find(sv, PERL_MAGIC_fm);
5134 sv_upgrade(sv, SVt_PVMG);
5138 /* still the same as previously-compiled string? */
5139 SV *old = mg->mg_obj;
5140 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5141 && len == SvCUR(old)
5142 && strnEQ(SvPVX(old), SvPVX(sv), len)
5144 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5148 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5149 Safefree(mg->mg_ptr);
5155 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5156 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5159 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5160 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5164 /* estimate the buffer size needed */
5165 for (base = s; s <= send; s++) {
5166 if (*s == '\n' || *s == '@' || *s == '^')
5172 Newx(fops, maxops, U32);
5177 *fpc++ = FF_LINEMARK;
5178 noblank = repeat = FALSE;
5196 case ' ': case '\t':
5203 } /* else FALL THROUGH */
5211 *fpc++ = FF_LITERAL;
5219 *fpc++ = (U32)skipspaces;
5223 *fpc++ = FF_NEWLINE;
5227 arg = fpc - linepc + 1;
5234 *fpc++ = FF_LINEMARK;
5235 noblank = repeat = FALSE;
5244 ischop = s[-1] == '^';
5250 arg = (s - base) - 1;
5252 *fpc++ = FF_LITERAL;
5258 if (*s == '*') { /* @* or ^* */
5260 *fpc++ = 2; /* skip the @* or ^* */
5262 *fpc++ = FF_LINESNGL;
5265 *fpc++ = FF_LINEGLOB;
5267 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5268 arg = ischop ? FORM_NUM_BLANK : 0;
5273 const char * const f = ++s;
5276 arg |= FORM_NUM_POINT + (s - f);
5278 *fpc++ = s - base; /* fieldsize for FETCH */
5279 *fpc++ = FF_DECIMAL;
5281 unchopnum |= ! ischop;
5283 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5284 arg = ischop ? FORM_NUM_BLANK : 0;
5286 s++; /* skip the '0' first */
5290 const char * const f = ++s;
5293 arg |= FORM_NUM_POINT + (s - f);
5295 *fpc++ = s - base; /* fieldsize for FETCH */
5296 *fpc++ = FF_0DECIMAL;
5298 unchopnum |= ! ischop;
5300 else { /* text field */
5302 bool ismore = FALSE;
5305 while (*++s == '>') ;
5306 prespace = FF_SPACE;
5308 else if (*s == '|') {
5309 while (*++s == '|') ;
5310 prespace = FF_HALFSPACE;
5315 while (*++s == '<') ;
5318 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5322 *fpc++ = s - base; /* fieldsize for FETCH */
5324 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5327 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5341 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5344 mg->mg_ptr = (char *) fops;
5345 mg->mg_len = arg * sizeof(U32);
5346 mg->mg_obj = sv_copy;
5347 mg->mg_flags |= MGf_REFCOUNTED;
5349 if (unchopnum && repeat)
5350 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5357 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5359 /* Can value be printed in fldsize chars, using %*.*f ? */
5363 int intsize = fldsize - (value < 0 ? 1 : 0);
5365 if (frcsize & FORM_NUM_POINT)
5367 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5370 while (intsize--) pwr *= 10.0;
5371 while (frcsize--) eps /= 10.0;
5374 if (value + eps >= pwr)
5377 if (value - eps <= -pwr)
5384 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: