3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
37 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
39 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
45 const PERL_CONTEXT *cx;
48 if (PL_op->op_private & OPpOFFBYONE) {
49 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
52 cxix = dopoptosub(cxstack_ix);
58 switch (cx->blk_gimme) {
77 PMOP *pm = (PMOP*)cLOGOP->op_other;
82 const regexp_engine *eng;
83 bool is_bare_re= FALSE;
85 if (PL_op->op_flags & OPf_STACKED) {
95 /* prevent recompiling under /o and ithreads. */
96 #if defined(USE_ITHREADS)
97 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
104 assert (re != (REGEXP*) &PL_sv_undef);
105 eng = re ? RX_ENGINE(re) : current_re_engine();
108 In the below logic: these are basically the same - check if this regcomp is part of a split.
110 (PL_op->op_pmflags & PMf_split )
111 (PL_op->op_next->op_type == OP_PUSHRE)
113 We could add a new mask for this and copy the PMf_split, if we did
114 some bit definition fiddling first.
116 For now we leave this
119 new_re = (eng->op_comp
121 : &Perl_re_op_compile
122 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
124 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
126 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
128 if (pm->op_pmflags & PMf_HAS_CV)
129 ReANY(new_re)->qr_anoncv
130 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
134 /* The match's LHS's get-magic might need to access this op's regexp
135 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
136 get-magic now before we replace the regexp. Hopefully this hack can
137 be replaced with the approach described at
138 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
140 if (pm->op_type == OP_MATCH) {
142 const bool was_tainted = TAINT_get;
143 if (pm->op_flags & OPf_STACKED)
145 else if (pm->op_targ)
146 lhs = PAD_SV(pm->op_targ);
149 /* Restore the previous value of PL_tainted (which may have been
150 modified by get-magic), to avoid incorrectly setting the
151 RXf_TAINTED flag with RX_TAINT_on further down. */
152 TAINT_set(was_tainted);
153 #ifdef NO_TAINT_SUPPORT
154 PERL_UNUSED_VAR(was_tainted);
157 tmp = reg_temp_copy(NULL, new_re);
158 ReREFCNT_dec(new_re);
164 PM_SETRE(pm, new_re);
168 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 SSize_t 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 NOT_REACHED; /* 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 */
677 if (sv != &PL_sv_no) {
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_V == G_ARRAY)
1114 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1115 return cLOGOP->op_other;
1124 if (GIMME_V == 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_V == 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 NOT_REACHED; /* NOTREACHED */
1683 write_to_stderr(exceptsv);
1685 NOT_REACHED; /* 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;
1765 I32 gimme = GIMME_V;
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, OpSIBLING(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, 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 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
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 if (LIKELY(isGV(TOPs))) { /* 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;
2121 save_aliased_sv(gv);
2124 SV * const sv = POPs;
2125 assert(SvTYPE(sv) == SVt_PVMG);
2126 assert(SvMAGIC(sv));
2127 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2128 itervar = (void *)sv;
2129 cxtype |= CXp_FOR_LVREF;
2132 if (PL_op->op_private & OPpITER_DEF)
2133 cxtype |= CXp_FOR_DEF;
2135 ENTER_with_name("loop2");
2137 PUSHBLOCK(cx, cxtype, SP);
2138 PUSHLOOP_FOR(cx, itervar, MARK);
2139 if (PL_op->op_flags & OPf_STACKED) {
2140 SV *maybe_ary = POPs;
2141 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2143 SV * const right = maybe_ary;
2144 if (UNLIKELY(cxtype & CXp_FOR_LVREF))
2145 DIE(aTHX_ "Assigned value is not a reference");
2148 if (RANGE_IS_NUMERIC(sv,right)) {
2150 cx->cx_type &= ~CXTYPEMASK;
2151 cx->cx_type |= CXt_LOOP_LAZYIV;
2152 /* Make sure that no-one re-orders cop.h and breaks our
2154 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2155 #ifdef NV_PRESERVES_UV
2156 if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) < (NV)IV_MIN) ||
2159 (SvOK(right) && (((nv = SvNV_nomg(right)) > (NV)IV_MAX) ||
2160 (nv < (NV)IV_MIN))))
2162 if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) <= (NV)IV_MIN)
2165 ((nv > (NV)UV_MAX) ||
2166 (SvUV_nomg(sv) > (UV)IV_MAX)))))
2168 (SvOK(right) && (((nv = SvNV_nomg(right)) <= (NV)IV_MIN)
2171 ((nv > (NV)UV_MAX) ||
2172 (SvUV_nomg(right) > (UV)IV_MAX))
2175 DIE(aTHX_ "Range iterator outside integer range");
2176 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2177 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2179 /* for correct -Dstv display */
2180 cx->blk_oldsp = sp - PL_stack_base;
2184 cx->cx_type &= ~CXTYPEMASK;
2185 cx->cx_type |= CXt_LOOP_LAZYSV;
2186 /* Make sure that no-one re-orders cop.h and breaks our
2188 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2189 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2190 cx->blk_loop.state_u.lazysv.end = right;
2191 SvREFCNT_inc(right);
2192 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2193 /* This will do the upgrade to SVt_PV, and warn if the value
2194 is uninitialised. */
2195 (void) SvPV_nolen_const(right);
2196 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2197 to replace !SvOK() with a pointer to "". */
2199 SvREFCNT_dec(right);
2200 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2204 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2205 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2206 SvREFCNT_inc(maybe_ary);
2207 cx->blk_loop.state_u.ary.ix =
2208 (PL_op->op_private & OPpITER_REVERSED) ?
2209 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2213 else { /* iterating over items on the stack */
2214 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2215 if (PL_op->op_private & OPpITER_REVERSED) {
2216 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2219 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2230 const I32 gimme = GIMME_V;
2232 ENTER_with_name("loop1");
2234 ENTER_with_name("loop2");
2236 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2237 PUSHLOOP_PLAIN(cx, SP);
2252 assert(CxTYPE_is_LOOP(cx));
2254 newsp = PL_stack_base + cx->blk_loop.resetsp;
2256 SP = leave_common(newsp, SP, MARK, gimme, 0,
2257 PL_op->op_private & OPpLVALUE);
2260 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2261 PL_curpm = newpm; /* ... and pop $1 et al */
2263 LEAVE_with_name("loop2");
2264 LEAVE_with_name("loop1");
2270 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2271 PERL_CONTEXT *cx, PMOP *newpm)
2273 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2274 if (gimme == G_SCALAR) {
2275 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2277 const char *what = NULL;
2279 assert(MARK+1 == SP);
2280 if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
2281 !SvSMAGICAL(TOPs)) {
2283 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2284 : "a readonly value" : "a temporary";
2289 /* sub:lvalue{} will take us here. */
2298 "Can't return %s from lvalue subroutine", what
2303 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2304 if (!SvPADTMP(*SP)) {
2305 *++newsp = SvREFCNT_inc(*SP);
2310 /* FREETMPS could clobber it */
2311 SV *sv = SvREFCNT_inc(*SP);
2313 *++newsp = sv_mortalcopy(sv);
2320 ? sv_mortalcopy(*SP)
2322 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2327 *++newsp = &PL_sv_undef;
2329 if (CxLVAL(cx) & OPpDEREF) {
2332 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2336 else if (gimme == G_ARRAY) {
2337 assert (!(CxLVAL(cx) & OPpDEREF));
2338 if (ref || !CxLVAL(cx))
2339 while (++MARK <= SP)
2341 SvFLAGS(*MARK) & SVs_PADTMP
2342 ? sv_mortalcopy(*MARK)
2345 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2346 else while (++MARK <= SP) {
2347 if (*MARK != &PL_sv_undef
2348 && (SvPADTMP(*MARK) || SvREADONLY(*MARK))
2350 const bool ro = cBOOL( SvREADONLY(*MARK) );
2352 /* Might be flattened array after $#array = */
2359 /* diag_listed_as: Can't return %s from lvalue subroutine */
2361 "Can't return a %s from lvalue subroutine",
2362 ro ? "readonly value" : "temporary");
2368 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2371 PL_stack_sp = newsp;
2378 bool popsub2 = FALSE;
2379 bool clear_errsv = FALSE;
2389 const I32 cxix = dopoptosub(cxstack_ix);
2392 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2393 * sort block, which is a CXt_NULL
2396 PL_stack_base[1] = *PL_stack_sp;
2397 PL_stack_sp = PL_stack_base + 1;
2401 DIE(aTHX_ "Can't return outside a subroutine");
2403 if (cxix < cxstack_ix)
2406 if (CxMULTICALL(&cxstack[cxix])) {
2407 gimme = cxstack[cxix].blk_gimme;
2408 if (gimme == G_VOID)
2409 PL_stack_sp = PL_stack_base;
2410 else if (gimme == G_SCALAR) {
2411 PL_stack_base[1] = *PL_stack_sp;
2412 PL_stack_sp = PL_stack_base + 1;
2418 switch (CxTYPE(cx)) {
2421 lval = !!CvLVALUE(cx->blk_sub.cv);
2422 retop = cx->blk_sub.retop;
2423 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2426 if (!(PL_in_eval & EVAL_KEEPERR))
2429 namesv = cx->blk_eval.old_namesv;
2430 retop = cx->blk_eval.retop;
2433 if (optype == OP_REQUIRE &&
2434 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2436 /* Unassume the success we assumed earlier. */
2437 (void)hv_delete(GvHVn(PL_incgv),
2438 SvPVX_const(namesv),
2439 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2441 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2445 retop = cx->blk_sub.retop;
2449 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2453 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2455 if (gimme == G_SCALAR) {
2458 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2459 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2460 && !SvMAGICAL(TOPs)) {
2461 *++newsp = SvREFCNT_inc(*SP);
2466 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2468 *++newsp = sv_mortalcopy(sv);
2472 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2473 && !SvMAGICAL(*SP)) {
2477 *++newsp = sv_mortalcopy(*SP);
2480 *++newsp = sv_mortalcopy(*SP);
2483 *++newsp = &PL_sv_undef;
2485 else if (gimme == G_ARRAY) {
2486 while (++MARK <= SP) {
2487 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2488 && !SvGMAGICAL(*MARK)
2489 ? *MARK : sv_mortalcopy(*MARK);
2490 TAINT_NOT; /* Each item is independent */
2493 PL_stack_sp = newsp;
2497 /* Stack values are safe: */
2500 POPSUB(cx,sv); /* release CV and @_ ... */
2504 PL_curpm = newpm; /* ... and pop $1 et al */
2513 /* This duplicates parts of pp_leavesub, so that it can share code with
2524 if (CxMULTICALL(&cxstack[cxstack_ix]))
2528 cxstack_ix++; /* temporarily protect top context */
2532 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2535 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2537 PL_curpm = newpm; /* ... and pop $1 et al */
2540 return cx->blk_sub.retop;
2544 S_unwind_loop(pTHX_ const char * const opname)
2547 if (PL_op->op_flags & OPf_SPECIAL) {
2548 cxix = dopoptoloop(cxstack_ix);
2550 /* diag_listed_as: Can't "last" outside a loop block */
2551 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2556 const char * const label =
2557 PL_op->op_flags & OPf_STACKED
2558 ? SvPV(TOPs,label_len)
2559 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2560 const U32 label_flags =
2561 PL_op->op_flags & OPf_STACKED
2563 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2565 cxix = dopoptolabel(label, label_len, label_flags);
2567 /* diag_listed_as: Label not found for "last %s" */
2568 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2570 SVfARG(PL_op->op_flags & OPf_STACKED
2571 && !SvGMAGICAL(TOPp1s)
2573 : newSVpvn_flags(label,
2575 label_flags | SVs_TEMP)));
2577 if (cxix < cxstack_ix)
2593 S_unwind_loop(aTHX_ "last");
2596 cxstack_ix++; /* temporarily protect top context */
2597 switch (CxTYPE(cx)) {
2598 case CXt_LOOP_LAZYIV:
2599 case CXt_LOOP_LAZYSV:
2601 case CXt_LOOP_PLAIN:
2603 newsp = PL_stack_base + cx->blk_loop.resetsp;
2604 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2608 nextop = cx->blk_sub.retop;
2612 nextop = cx->blk_eval.retop;
2616 nextop = cx->blk_sub.retop;
2619 DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2623 PL_stack_sp = newsp;
2627 /* Stack values are safe: */
2629 case CXt_LOOP_LAZYIV:
2630 case CXt_LOOP_PLAIN:
2631 case CXt_LOOP_LAZYSV:
2633 POPLOOP(cx); /* release loop vars ... */
2637 POPSUB(cx,sv); /* release CV and @_ ... */
2640 PL_curpm = newpm; /* ... and pop $1 et al */
2643 PERL_UNUSED_VAR(optype);
2644 PERL_UNUSED_VAR(gimme);
2651 const I32 inner = PL_scopestack_ix;
2653 S_unwind_loop(aTHX_ "next");
2655 /* clear off anything above the scope we're re-entering, but
2656 * save the rest until after a possible continue block */
2658 if (PL_scopestack_ix < inner)
2659 leave_scope(PL_scopestack[PL_scopestack_ix]);
2660 PL_curcop = cx->blk_oldcop;
2662 return (cx)->blk_loop.my_op->op_nextop;
2667 const I32 cxix = S_unwind_loop(aTHX_ "redo");
2670 OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2672 if (redo_op->op_type == OP_ENTER) {
2673 /* pop one less context to avoid $x being freed in while (my $x..) */
2675 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2676 redo_op = redo_op->op_next;
2680 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2681 LEAVE_SCOPE(oldsave);
2683 PL_curcop = cx->blk_oldcop;
2689 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2692 static const char* const too_deep = "Target of goto is too deeply nested";
2694 PERL_ARGS_ASSERT_DOFINDLABEL;
2697 Perl_croak(aTHX_ "%s", too_deep);
2698 if (o->op_type == OP_LEAVE ||
2699 o->op_type == OP_SCOPE ||
2700 o->op_type == OP_LEAVELOOP ||
2701 o->op_type == OP_LEAVESUB ||
2702 o->op_type == OP_LEAVETRY)
2704 *ops++ = cUNOPo->op_first;
2706 Perl_croak(aTHX_ "%s", too_deep);
2709 if (o->op_flags & OPf_KIDS) {
2711 /* First try all the kids at this level, since that's likeliest. */
2712 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2713 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2714 STRLEN kid_label_len;
2715 U32 kid_label_flags;
2716 const char *kid_label = CopLABEL_len_flags(kCOP,
2717 &kid_label_len, &kid_label_flags);
2719 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2722 (const U8*)kid_label, kid_label_len,
2723 (const U8*)label, len) == 0)
2725 (const U8*)label, len,
2726 (const U8*)kid_label, kid_label_len) == 0)
2727 : ( len == kid_label_len && ((kid_label == label)
2728 || memEQ(kid_label, label, len)))))
2732 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2733 if (kid == PL_lastgotoprobe)
2735 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2738 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2739 ops[-1]->op_type == OP_DBSTATE)
2744 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2753 /* also used for: pp_dump() */
2761 #define GOTO_DEPTH 64
2762 OP *enterops[GOTO_DEPTH];
2763 const char *label = NULL;
2764 STRLEN label_len = 0;
2765 U32 label_flags = 0;
2766 const bool do_dump = (PL_op->op_type == OP_DUMP);
2767 static const char* const must_have_label = "goto must have label";
2769 if (PL_op->op_flags & OPf_STACKED) {
2770 /* goto EXPR or goto &foo */
2772 SV * const sv = POPs;
2775 /* This egregious kludge implements goto &subroutine */
2776 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2779 CV *cv = MUTABLE_CV(SvRV(sv));
2780 AV *arg = GvAV(PL_defgv);
2784 if (!CvROOT(cv) && !CvXSUB(cv)) {
2785 const GV * const gv = CvGV(cv);
2789 /* autoloaded stub? */
2790 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2792 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2794 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2795 if (autogv && (cv = GvCV(autogv)))
2797 tmpstr = sv_newmortal();
2798 gv_efullname3(tmpstr, gv, NULL);
2799 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2801 DIE(aTHX_ "Goto undefined subroutine");
2804 /* First do some returnish stuff. */
2805 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2807 cxix = dopoptosub(cxstack_ix);
2808 if (cxix < cxstack_ix) {
2811 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2817 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2818 if (CxTYPE(cx) == CXt_EVAL) {
2821 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2822 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2824 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2825 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2827 else if (CxMULTICALL(cx))
2830 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2832 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2833 AV* av = cx->blk_sub.argarray;
2835 /* abandon the original @_ if it got reified or if it is
2836 the same as the current @_ */
2837 if (AvREAL(av) || av == arg) {
2841 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2843 else CLEAR_ARGARRAY(av);
2845 /* We donate this refcount later to the callee’s pad. */
2846 SvREFCNT_inc_simple_void(arg);
2847 if (CxTYPE(cx) == CXt_SUB &&
2848 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2849 SvREFCNT_dec(cx->blk_sub.cv);
2850 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2851 LEAVE_SCOPE(oldsave);
2853 /* A destructor called during LEAVE_SCOPE could have undefined
2854 * our precious cv. See bug #99850. */
2855 if (!CvROOT(cv) && !CvXSUB(cv)) {
2856 const GV * const gv = CvGV(cv);
2859 SV * const tmpstr = sv_newmortal();
2860 gv_efullname3(tmpstr, gv, NULL);
2861 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2864 DIE(aTHX_ "Goto undefined subroutine");
2867 /* Now do some callish stuff. */
2869 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2873 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2874 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2877 PERL_UNUSED_VAR(newsp);
2878 PERL_UNUSED_VAR(gimme);
2880 /* put GvAV(defgv) back onto stack */
2882 EXTEND(SP, items+1); /* @_ could have been extended. */
2887 bool r = cBOOL(AvREAL(arg));
2888 for (index=0; index<items; index++)
2892 SV ** const svp = av_fetch(arg, index, 0);
2893 sv = svp ? *svp : NULL;
2895 else sv = AvARRAY(arg)[index];
2897 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2898 : sv_2mortal(newSVavdefelem(arg, index, 1));
2903 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2904 /* Restore old @_ */
2905 arg = GvAV(PL_defgv);
2906 GvAV(PL_defgv) = cx->blk_sub.savearray;
2910 retop = cx->blk_sub.retop;
2911 /* XS subs don't have a CxSUB, so pop it */
2912 POPBLOCK(cx, PL_curpm);
2913 /* Push a mark for the start of arglist */
2916 (void)(*CvXSUB(cv))(aTHX_ cv);
2921 PADLIST * const padlist = CvPADLIST(cv);
2922 cx->blk_sub.cv = cv;
2923 cx->blk_sub.olddepth = CvDEPTH(cv);
2926 if (CvDEPTH(cv) < 2)
2927 SvREFCNT_inc_simple_void_NN(cv);
2929 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2930 sub_crush_depth(cv);
2931 pad_push(padlist, CvDEPTH(cv));
2933 PL_curcop = cx->blk_oldcop;
2935 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2938 CX_CURPAD_SAVE(cx->blk_sub);
2940 /* cx->blk_sub.argarray has no reference count, so we
2941 need something to hang on to our argument array so
2942 that cx->blk_sub.argarray does not end up pointing
2943 to freed memory as the result of undef *_. So put
2944 it in the callee’s pad, donating our refer-
2947 SvREFCNT_dec(PAD_SVl(0));
2948 PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2951 /* GvAV(PL_defgv) might have been modified on scope
2952 exit, so restore it. */
2953 if (arg != GvAV(PL_defgv)) {
2954 AV * const av = GvAV(PL_defgv);
2955 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2959 else SvREFCNT_dec(arg);
2960 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2961 Perl_get_db_sub(aTHX_ NULL, cv);
2963 CV * const gotocv = get_cvs("DB::goto", 0);
2965 PUSHMARK( PL_stack_sp );
2966 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2971 retop = CvSTART(cv);
2972 goto putback_return;
2977 label = SvPV_nomg_const(sv, label_len);
2978 label_flags = SvUTF8(sv);
2981 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2982 /* goto LABEL or dump LABEL */
2983 label = cPVOP->op_pv;
2984 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2985 label_len = strlen(label);
2987 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2992 OP *gotoprobe = NULL;
2993 bool leaving_eval = FALSE;
2994 bool in_block = FALSE;
2995 PERL_CONTEXT *last_eval_cx = NULL;
2999 PL_lastgotoprobe = NULL;
3001 for (ix = cxstack_ix; ix >= 0; ix--) {
3003 switch (CxTYPE(cx)) {
3005 leaving_eval = TRUE;
3006 if (!CxTRYBLOCK(cx)) {
3007 gotoprobe = (last_eval_cx ?
3008 last_eval_cx->blk_eval.old_eval_root :
3013 /* else fall through */
3014 case CXt_LOOP_LAZYIV:
3015 case CXt_LOOP_LAZYSV:
3017 case CXt_LOOP_PLAIN:
3020 gotoprobe = OpSIBLING(cx->blk_oldcop);
3026 gotoprobe = OpSIBLING(cx->blk_oldcop);
3029 gotoprobe = PL_main_root;
3032 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3033 gotoprobe = CvROOT(cx->blk_sub.cv);
3039 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3042 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3043 CxTYPE(cx), (long) ix);
3044 gotoprobe = PL_main_root;
3050 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3051 enterops, enterops + GOTO_DEPTH);
3054 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3055 sibl1->op_type == OP_UNSTACK &&
3056 (sibl2 = OpSIBLING(sibl1)))
3058 retop = dofindlabel(sibl2,
3059 label, label_len, label_flags, enterops,
3060 enterops + GOTO_DEPTH);
3065 PL_lastgotoprobe = gotoprobe;
3068 DIE(aTHX_ "Can't find label %"UTF8f,
3069 UTF8fARG(label_flags, label_len, label));
3071 /* if we're leaving an eval, check before we pop any frames
3072 that we're not going to punt, otherwise the error
3075 if (leaving_eval && *enterops && enterops[1]) {
3077 for (i = 1; enterops[i]; i++)
3078 if (enterops[i]->op_type == OP_ENTERITER)
3079 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3082 if (*enterops && enterops[1]) {
3083 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3085 deprecate("\"goto\" to jump into a construct");
3088 /* pop unwanted frames */
3090 if (ix < cxstack_ix) {
3094 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3097 oldsave = PL_scopestack[PL_scopestack_ix];
3098 LEAVE_SCOPE(oldsave);
3101 /* push wanted frames */
3103 if (*enterops && enterops[1]) {
3104 OP * const oldop = PL_op;
3105 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3106 for (; enterops[ix]; ix++) {
3107 PL_op = enterops[ix];
3108 /* Eventually we may want to stack the needed arguments
3109 * for each op. For now, we punt on the hard ones. */
3110 if (PL_op->op_type == OP_ENTERITER)
3111 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3112 PL_op->op_ppaddr(aTHX);
3121 if (!retop) retop = PL_main_start;
3123 PL_restartop = retop;
3124 PL_do_undump = TRUE;
3128 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3129 PL_do_undump = FALSE;
3147 anum = 0; (void)POPs;
3153 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3156 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3159 PL_exit_flags |= PERL_EXIT_EXPECTED;
3161 PUSHs(&PL_sv_undef);
3168 S_save_lines(pTHX_ AV *array, SV *sv)
3170 const char *s = SvPVX_const(sv);
3171 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3174 PERL_ARGS_ASSERT_SAVE_LINES;
3176 while (s && s < send) {
3178 SV * const tmpstr = newSV_type(SVt_PVMG);
3180 t = (const char *)memchr(s, '\n', send - s);
3186 sv_setpvn(tmpstr, s, t - s);
3187 av_store(array, line++, tmpstr);
3195 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3197 0 is used as continue inside eval,
3199 3 is used for a die caught by an inner eval - continue inner loop
3201 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3202 establish a local jmpenv to handle exception traps.
3207 S_docatch(pTHX_ OP *o)
3210 OP * const oldop = PL_op;
3214 assert(CATCH_GET == TRUE);
3221 assert(cxstack_ix >= 0);
3222 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3223 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3228 /* die caught by an inner eval - continue inner loop */
3229 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3230 PL_restartjmpenv = NULL;
3231 PL_op = PL_restartop;
3240 NOT_REACHED; /* NOTREACHED */
3249 =for apidoc find_runcv
3251 Locate the CV corresponding to the currently executing sub or eval.
3252 If db_seqp is non_null, skip CVs that are in the DB package and populate
3253 *db_seqp with the cop sequence number at the point that the DB:: code was
3254 entered. (This allows debuggers to eval in the scope of the breakpoint
3255 rather than in the scope of the debugger itself.)
3261 Perl_find_runcv(pTHX_ U32 *db_seqp)
3263 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3266 /* If this becomes part of the API, it might need a better name. */
3268 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3275 PL_curcop == &PL_compiling
3277 : PL_curcop->cop_seq;
3279 for (si = PL_curstackinfo; si; si = si->si_prev) {
3281 for (ix = si->si_cxix; ix >= 0; ix--) {
3282 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3284 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3285 cv = cx->blk_sub.cv;
3286 /* skip DB:: code */
3287 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3288 *db_seqp = cx->blk_oldcop->cop_seq;
3291 if (cx->cx_type & CXp_SUB_RE)
3294 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3295 cv = cx->blk_eval.cv;
3298 case FIND_RUNCV_padid_eq:
3300 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3303 case FIND_RUNCV_level_eq:
3304 if (level++ != arg) continue;
3312 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3316 /* Run yyparse() in a setjmp wrapper. Returns:
3317 * 0: yyparse() successful
3318 * 1: yyparse() failed
3322 S_try_yyparse(pTHX_ int gramtype)
3327 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3331 ret = yyparse(gramtype) ? 1 : 0;
3338 NOT_REACHED; /* NOTREACHED */
3345 /* Compile a require/do or an eval ''.
3347 * outside is the lexically enclosing CV (if any) that invoked us.
3348 * seq is the current COP scope value.
3349 * hh is the saved hints hash, if any.
3351 * Returns a bool indicating whether the compile was successful; if so,
3352 * PL_eval_start contains the first op of the compiled code; otherwise,
3355 * This function is called from two places: pp_require and pp_entereval.
3356 * These can be distinguished by whether PL_op is entereval.
3360 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3363 OP * const saveop = PL_op;
3364 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3365 COP * const oldcurcop = PL_curcop;
3366 bool in_require = (saveop->op_type == OP_REQUIRE);
3370 PL_in_eval = (in_require
3371 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3373 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3374 ? EVAL_RE_REPARSING : 0)));
3378 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3380 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3381 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3382 cxstack[cxstack_ix].blk_gimme = gimme;
3384 CvOUTSIDE_SEQ(evalcv) = seq;
3385 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3387 /* set up a scratch pad */
3389 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3390 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3393 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3395 /* make sure we compile in the right package */
3397 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3398 SAVEGENERICSV(PL_curstash);
3399 PL_curstash = (HV *)CopSTASH(PL_curcop);
3400 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3401 else SvREFCNT_inc_simple_void(PL_curstash);
3403 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3404 SAVESPTR(PL_beginav);
3405 PL_beginav = newAV();
3406 SAVEFREESV(PL_beginav);
3407 SAVESPTR(PL_unitcheckav);
3408 PL_unitcheckav = newAV();
3409 SAVEFREESV(PL_unitcheckav);
3412 ENTER_with_name("evalcomp");
3413 SAVESPTR(PL_compcv);
3416 /* try to compile it */
3418 PL_eval_root = NULL;
3419 PL_curcop = &PL_compiling;
3420 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3421 PL_in_eval |= EVAL_KEEPERR;
3428 hv_clear(GvHV(PL_hintgv));
3431 PL_hints = saveop->op_private & OPpEVAL_COPHH
3432 ? oldcurcop->cop_hints : saveop->op_targ;
3434 /* making 'use re eval' not be in scope when compiling the
3435 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3436 * infinite recursion when S_has_runtime_code() gives a false
3437 * positive: the second time round, HINT_RE_EVAL isn't set so we
3438 * don't bother calling S_has_runtime_code() */
3439 if (PL_in_eval & EVAL_RE_REPARSING)
3440 PL_hints &= ~HINT_RE_EVAL;
3443 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3444 SvREFCNT_dec(GvHV(PL_hintgv));
3445 GvHV(PL_hintgv) = hh;
3448 SAVECOMPILEWARNINGS();
3450 if (PL_dowarn & G_WARN_ALL_ON)
3451 PL_compiling.cop_warnings = pWARN_ALL ;
3452 else if (PL_dowarn & G_WARN_ALL_OFF)
3453 PL_compiling.cop_warnings = pWARN_NONE ;
3455 PL_compiling.cop_warnings = pWARN_STD ;
3458 PL_compiling.cop_warnings =
3459 DUP_WARNINGS(oldcurcop->cop_warnings);
3460 cophh_free(CopHINTHASH_get(&PL_compiling));
3461 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3462 /* The label, if present, is the first entry on the chain. So rather
3463 than writing a blank label in front of it (which involves an
3464 allocation), just use the next entry in the chain. */
3465 PL_compiling.cop_hints_hash
3466 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3467 /* Check the assumption that this removed the label. */
3468 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3471 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3474 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3476 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3477 * so honour CATCH_GET and trap it here if necessary */
3479 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3481 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3482 SV **newsp; /* Used by POPBLOCK. */
3484 I32 optype; /* Used by POPEVAL. */
3490 PERL_UNUSED_VAR(newsp);
3491 PERL_UNUSED_VAR(optype);
3493 /* note that if yystatus == 3, then the EVAL CX block has already
3494 * been popped, and various vars restored */
3496 if (yystatus != 3) {
3498 op_free(PL_eval_root);
3499 PL_eval_root = NULL;
3501 SP = PL_stack_base + POPMARK; /* pop original mark */
3502 POPBLOCK(cx,PL_curpm);
3504 namesv = cx->blk_eval.old_namesv;
3505 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3506 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3512 /* If cx is still NULL, it means that we didn't go in the
3513 * POPEVAL branch. */
3514 cx = &cxstack[cxstack_ix];
3515 assert(CxTYPE(cx) == CXt_EVAL);
3516 namesv = cx->blk_eval.old_namesv;
3518 (void)hv_store(GvHVn(PL_incgv),
3519 SvPVX_const(namesv),
3520 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3522 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3525 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3528 if (!*(SvPV_nolen_const(errsv))) {
3529 sv_setpvs(errsv, "Compilation error");
3532 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3537 LEAVE_with_name("evalcomp");
3539 CopLINE_set(&PL_compiling, 0);
3540 SAVEFREEOP(PL_eval_root);
3541 cv_forget_slab(evalcv);
3543 DEBUG_x(dump_eval());
3545 /* Register with debugger: */
3546 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3547 CV * const cv = get_cvs("DB::postponed", 0);
3551 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3553 call_sv(MUTABLE_SV(cv), G_DISCARD);
3557 if (PL_unitcheckav) {
3558 OP *es = PL_eval_start;
3559 call_list(PL_scopestack_ix, PL_unitcheckav);
3563 /* compiled okay, so do it */
3565 CvDEPTH(evalcv) = 1;
3566 SP = PL_stack_base + POPMARK; /* pop original mark */
3567 PL_op = saveop; /* The caller may need it. */
3568 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3575 S_check_type_and_open(pTHX_ SV *name)
3579 const char *p = SvPV_const(name, len);
3582 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3584 /* checking here captures a reasonable error message when
3585 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3586 * user gets a confusing message about looking for the .pmc file
3587 * rather than for the .pm file.
3588 * This check prevents a \0 in @INC causing problems.
3590 if (!IS_SAFE_PATHNAME(p, len, "require"))
3593 /* we use the value of errno later to see how stat() or open() failed.
3594 * We don't want it set if the stat succeeded but we still failed,
3595 * such as if the name exists, but is a directory */
3598 st_rc = PerlLIO_stat(p, &st);
3600 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3604 #if !defined(PERLIO_IS_STDIO)
3605 return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3607 return PerlIO_open(p, PERL_SCRIPT_MODE);
3611 #ifndef PERL_DISABLE_PMC
3613 S_doopen_pm(pTHX_ SV *name)
3616 const char *p = SvPV_const(name, namelen);
3618 PERL_ARGS_ASSERT_DOOPEN_PM;
3620 /* check the name before trying for the .pmc name to avoid the
3621 * warning referring to the .pmc which the user probably doesn't
3622 * know or care about
3624 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3627 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3628 SV *const pmcsv = sv_newmortal();
3631 SvSetSV_nosteal(pmcsv,name);
3632 sv_catpvs(pmcsv, "c");
3634 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3635 return check_type_and_open(pmcsv);
3637 return check_type_and_open(name);
3640 # define doopen_pm(name) check_type_and_open(name)
3641 #endif /* !PERL_DISABLE_PMC */
3643 /* require doesn't search for absolute names, or when the name is
3644 explicity relative the current directory */
3645 PERL_STATIC_INLINE bool
3646 S_path_is_searchable(const char *name)
3648 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3650 if (PERL_FILE_IS_ABSOLUTE(name)
3652 || (*name == '.' && ((name[1] == '/' ||
3653 (name[1] == '.' && name[2] == '/'))
3654 || (name[1] == '\\' ||
3655 ( name[1] == '.' && name[2] == '\\')))
3658 || (*name == '.' && (name[1] == '/' ||
3659 (name[1] == '.' && name[2] == '/')))
3670 /* also used for: pp_dofile() */
3682 int vms_unixname = 0;
3685 const char *tryname = NULL;
3687 const I32 gimme = GIMME_V;
3688 int filter_has_file = 0;
3689 PerlIO *tryrsfp = NULL;
3690 SV *filter_cache = NULL;
3691 SV *filter_state = NULL;
3692 SV *filter_sub = NULL;
3696 bool path_searchable;
3700 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3701 sv = sv_2mortal(new_version(sv));
3702 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3703 upg_version(PL_patchlevel, TRUE);
3704 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3705 if ( vcmp(sv,PL_patchlevel) <= 0 )
3706 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3707 SVfARG(sv_2mortal(vnormal(sv))),
3708 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3712 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3715 SV * const req = SvRV(sv);
3716 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3718 /* get the left hand term */
3719 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3721 first = SvIV(*av_fetch(lav,0,0));
3722 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3723 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3724 || av_tindex(lav) > 1 /* FP with > 3 digits */
3725 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3727 DIE(aTHX_ "Perl %"SVf" required--this is only "
3729 SVfARG(sv_2mortal(vnormal(req))),
3730 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3733 else { /* probably 'use 5.10' or 'use 5.8' */
3737 if (av_tindex(lav)>=1)
3738 second = SvIV(*av_fetch(lav,1,0));
3740 second /= second >= 600 ? 100 : 10;
3741 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3742 (int)first, (int)second);
3743 upg_version(hintsv, TRUE);
3745 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3746 "--this is only %"SVf", stopped",
3747 SVfARG(sv_2mortal(vnormal(req))),
3748 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3749 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3758 DIE(aTHX_ "Missing or undefined argument to require");
3759 name = SvPV_nomg_const(sv, len);
3760 if (!(name && len > 0 && *name))
3761 DIE(aTHX_ "Missing or undefined argument to require");
3763 if (!IS_SAFE_PATHNAME(name, len, "require")) {
3764 DIE(aTHX_ "Can't locate %s: %s",
3765 pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3766 SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3769 TAINT_PROPER("require");
3771 path_searchable = path_is_searchable(name);
3774 /* The key in the %ENV hash is in the syntax of file passed as the argument
3775 * usually this is in UNIX format, but sometimes in VMS format, which
3776 * can result in a module being pulled in more than once.
3777 * To prevent this, the key must be stored in UNIX format if the VMS
3778 * name can be translated to UNIX.
3782 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3784 unixlen = strlen(unixname);
3790 /* if not VMS or VMS name can not be translated to UNIX, pass it
3793 unixname = (char *) name;
3796 if (PL_op->op_type == OP_REQUIRE) {
3797 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3798 unixname, unixlen, 0);
3800 if (*svp != &PL_sv_undef)
3803 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3804 "Compilation failed in require", unixname);
3808 LOADING_FILE_PROBE(unixname);
3810 /* prepare to compile file */
3812 if (!path_searchable) {
3813 /* At this point, name is SvPVX(sv) */
3815 tryrsfp = doopen_pm(sv);
3817 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3818 AV * const ar = GvAVn(PL_incgv);
3825 namesv = newSV_type(SVt_PV);
3826 for (i = 0; i <= AvFILL(ar); i++) {
3827 SV * const dirsv = *av_fetch(ar, i, TRUE);
3835 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3836 && !SvOBJECT(SvRV(loader)))
3838 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3842 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3843 PTR2UV(SvRV(dirsv)), name);
3844 tryname = SvPVX_const(namesv);
3847 if (SvPADTMP(nsv)) {
3848 nsv = sv_newmortal();
3849 SvSetSV_nosteal(nsv,sv);
3852 ENTER_with_name("call_INC");
3860 if (SvGMAGICAL(loader)) {
3861 SV *l = sv_newmortal();
3862 sv_setsv_nomg(l, loader);
3865 if (sv_isobject(loader))
3866 count = call_method("INC", G_ARRAY);
3868 count = call_sv(loader, G_ARRAY);
3878 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3879 && !isGV_with_GP(SvRV(arg))) {
3880 filter_cache = SvRV(arg);
3887 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3891 if (isGV_with_GP(arg)) {
3892 IO * const io = GvIO((const GV *)arg);
3897 tryrsfp = IoIFP(io);
3898 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3899 PerlIO_close(IoOFP(io));
3910 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3912 SvREFCNT_inc_simple_void_NN(filter_sub);
3915 filter_state = SP[i];
3916 SvREFCNT_inc_simple_void(filter_state);
3920 if (!tryrsfp && (filter_cache || filter_sub)) {
3921 tryrsfp = PerlIO_open(BIT_BUCKET,
3927 /* FREETMPS may free our filter_cache */
3928 SvREFCNT_inc_simple_void(filter_cache);
3932 LEAVE_with_name("call_INC");
3934 /* Now re-mortalize it. */
3935 sv_2mortal(filter_cache);
3937 /* Adjust file name if the hook has set an %INC entry.
3938 This needs to happen after the FREETMPS above. */
3939 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3941 tryname = SvPV_nolen_const(*svp);
3948 filter_has_file = 0;
3949 filter_cache = NULL;
3951 SvREFCNT_dec_NN(filter_state);
3952 filter_state = NULL;
3955 SvREFCNT_dec_NN(filter_sub);
3960 if (path_searchable) {
3965 dir = SvPV_nomg_const(dirsv, dirlen);
3971 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3975 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3978 sv_setpv(namesv, unixdir);
3979 sv_catpv(namesv, unixname);
3981 # ifdef __SYMBIAN32__
3982 if (PL_origfilename[0] &&
3983 PL_origfilename[1] == ':' &&
3984 !(dir[0] && dir[1] == ':'))
3985 Perl_sv_setpvf(aTHX_ namesv,
3990 Perl_sv_setpvf(aTHX_ namesv,
3994 /* The equivalent of
3995 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3996 but without the need to parse the format string, or
3997 call strlen on either pointer, and with the correct
3998 allocation up front. */
4000 char *tmp = SvGROW(namesv, dirlen + len + 2);
4002 memcpy(tmp, dir, dirlen);
4005 /* Avoid '<dir>//<file>' */
4006 if (!dirlen || *(tmp-1) != '/') {
4009 /* So SvCUR_set reports the correct length below */
4013 /* name came from an SV, so it will have a '\0' at the
4014 end that we can copy as part of this memcpy(). */
4015 memcpy(tmp, name, len + 1);
4017 SvCUR_set(namesv, dirlen + len + 1);
4022 TAINT_PROPER("require");
4023 tryname = SvPVX_const(namesv);
4024 tryrsfp = doopen_pm(namesv);
4026 if (tryname[0] == '.' && tryname[1] == '/') {
4028 while (*++tryname == '/') {}
4032 else if (errno == EMFILE || errno == EACCES) {
4033 /* no point in trying other paths if out of handles;
4034 * on the other hand, if we couldn't open one of the
4035 * files, then going on with the search could lead to
4036 * unexpected results; see perl #113422
4045 saved_errno = errno; /* sv_2mortal can realloc things */
4048 if (PL_op->op_type == OP_REQUIRE) {
4049 if(saved_errno == EMFILE || saved_errno == EACCES) {
4050 /* diag_listed_as: Can't locate %s */
4051 DIE(aTHX_ "Can't locate %s: %s: %s",
4052 name, tryname, Strerror(saved_errno));
4054 if (namesv) { /* did we lookup @INC? */
4055 AV * const ar = GvAVn(PL_incgv);
4057 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4058 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4059 for (i = 0; i <= AvFILL(ar); i++) {
4060 sv_catpvs(inc, " ");
4061 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4063 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4064 const char *c, *e = name + len - 3;
4065 sv_catpv(msg, " (you may need to install the ");
4066 for (c = name; c < e; c++) {
4068 sv_catpvs(msg, "::");
4071 sv_catpvn(msg, c, 1);
4074 sv_catpv(msg, " module)");
4076 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4077 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4079 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4080 sv_catpv(msg, " (did you run h2ph?)");
4083 /* diag_listed_as: Can't locate %s */
4085 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4089 DIE(aTHX_ "Can't locate %s", name);
4096 SETERRNO(0, SS_NORMAL);
4098 /* Assume success here to prevent recursive requirement. */
4099 /* name is never assigned to again, so len is still strlen(name) */
4100 /* Check whether a hook in @INC has already filled %INC */
4102 (void)hv_store(GvHVn(PL_incgv),
4103 unixname, unixlen, newSVpv(tryname,0),0);
4105 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4107 (void)hv_store(GvHVn(PL_incgv),
4108 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4111 ENTER_with_name("eval");
4113 SAVECOPFILE_FREE(&PL_compiling);
4114 CopFILE_set(&PL_compiling, tryname);
4115 lex_start(NULL, tryrsfp, 0);
4117 if (filter_sub || filter_cache) {
4118 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4119 than hanging another SV from it. In turn, filter_add() optionally
4120 takes the SV to use as the filter (or creates a new SV if passed
4121 NULL), so simply pass in whatever value filter_cache has. */
4122 SV * const fc = filter_cache ? newSV(0) : NULL;
4124 if (fc) sv_copypv(fc, filter_cache);
4125 datasv = filter_add(S_run_user_filter, fc);
4126 IoLINES(datasv) = filter_has_file;
4127 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4128 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4131 /* switch to eval mode */
4132 PUSHBLOCK(cx, CXt_EVAL, SP);
4134 cx->blk_eval.retop = PL_op->op_next;
4136 SAVECOPLINE(&PL_compiling);
4137 CopLINE_set(&PL_compiling, 0);
4141 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4142 op = DOCATCH(PL_eval_start);
4144 op = PL_op->op_next;
4146 LOADED_FILE_PROBE(unixname);
4151 /* This is a op added to hold the hints hash for
4152 pp_entereval. The hash can be modified by the code
4153 being eval'ed, so we return a copy instead. */
4158 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4168 const I32 gimme = GIMME_V;
4169 const U32 was = PL_breakable_sub_gen;
4170 char tbuf[TYPE_DIGITS(long) + 12];
4171 bool saved_delete = FALSE;
4172 char *tmpbuf = tbuf;
4175 U32 seq, lex_flags = 0;
4176 HV *saved_hh = NULL;
4177 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4179 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4180 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4182 else if (PL_hints & HINT_LOCALIZE_HH || (
4183 PL_op->op_private & OPpEVAL_COPHH
4184 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4186 saved_hh = cop_hints_2hv(PL_curcop, 0);
4187 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4191 /* make sure we've got a plain PV (no overload etc) before testing
4192 * for taint. Making a copy here is probably overkill, but better
4193 * safe than sorry */
4195 const char * const p = SvPV_const(sv, len);
4197 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4198 lex_flags |= LEX_START_COPIED;
4200 if (bytes && SvUTF8(sv))
4201 SvPVbyte_force(sv, len);
4203 else if (bytes && SvUTF8(sv)) {
4204 /* Don't modify someone else's scalar */
4207 (void)sv_2mortal(sv);
4208 SvPVbyte_force(sv,len);
4209 lex_flags |= LEX_START_COPIED;
4212 TAINT_IF(SvTAINTED(sv));
4213 TAINT_PROPER("eval");
4215 ENTER_with_name("eval");
4216 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4217 ? LEX_IGNORE_UTF8_HINTS
4218 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4223 /* switch to eval mode */
4225 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4226 SV * const temp_sv = sv_newmortal();
4227 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4228 (unsigned long)++PL_evalseq,
4229 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4230 tmpbuf = SvPVX(temp_sv);
4231 len = SvCUR(temp_sv);
4234 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4235 SAVECOPFILE_FREE(&PL_compiling);
4236 CopFILE_set(&PL_compiling, tmpbuf+2);
4237 SAVECOPLINE(&PL_compiling);
4238 CopLINE_set(&PL_compiling, 1);
4239 /* special case: an eval '' executed within the DB package gets lexically
4240 * placed in the first non-DB CV rather than the current CV - this
4241 * allows the debugger to execute code, find lexicals etc, in the
4242 * scope of the code being debugged. Passing &seq gets find_runcv
4243 * to do the dirty work for us */
4244 runcv = find_runcv(&seq);
4246 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4248 cx->blk_eval.retop = PL_op->op_next;
4250 /* prepare to compile string */
4252 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4253 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4255 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4256 deleting the eval's FILEGV from the stash before gv_check() runs
4257 (i.e. before run-time proper). To work around the coredump that
4258 ensues, we always turn GvMULTI_on for any globals that were
4259 introduced within evals. See force_ident(). GSAR 96-10-12 */
4260 char *const safestr = savepvn(tmpbuf, len);
4261 SAVEDELETE(PL_defstash, safestr, len);
4262 saved_delete = TRUE;
4267 if (doeval(gimme, runcv, seq, saved_hh)) {
4268 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4269 ? (PERLDB_LINE || PERLDB_SAVESRC)
4270 : PERLDB_SAVESRC_NOSUBS) {
4271 /* Retain the filegv we created. */
4272 } else if (!saved_delete) {
4273 char *const safestr = savepvn(tmpbuf, len);
4274 SAVEDELETE(PL_defstash, safestr, len);
4276 return DOCATCH(PL_eval_start);
4278 /* We have already left the scope set up earlier thanks to the LEAVE
4280 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4281 ? (PERLDB_LINE || PERLDB_SAVESRC)
4282 : PERLDB_SAVESRC_INVALID) {
4283 /* Retain the filegv we created. */
4284 } else if (!saved_delete) {
4285 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4287 return PL_op->op_next;
4299 const U8 save_flags = PL_op -> op_flags;
4307 namesv = cx->blk_eval.old_namesv;
4308 retop = cx->blk_eval.retop;
4309 evalcv = cx->blk_eval.cv;
4311 SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
4312 gimme, SVs_TEMP, FALSE);
4313 PL_curpm = newpm; /* Don't pop $1 et al till now */
4316 assert(CvDEPTH(evalcv) == 1);
4318 CvDEPTH(evalcv) = 0;
4320 if (optype == OP_REQUIRE &&
4321 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4323 /* Unassume the success we assumed earlier. */
4324 (void)hv_delete(GvHVn(PL_incgv),
4325 SvPVX_const(namesv),
4326 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4328 Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4329 NOT_REACHED; /* NOTREACHED */
4330 /* die_unwind() did LEAVE, or we won't be here */
4333 LEAVE_with_name("eval");
4334 if (!(save_flags & OPf_SPECIAL)) {
4342 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4343 close to the related Perl_create_eval_scope. */
4345 Perl_delete_eval_scope(pTHX)
4356 LEAVE_with_name("eval_scope");
4357 PERL_UNUSED_VAR(newsp);
4358 PERL_UNUSED_VAR(gimme);
4359 PERL_UNUSED_VAR(optype);
4362 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4363 also needed by Perl_fold_constants. */
4365 Perl_create_eval_scope(pTHX_ U32 flags)
4368 const I32 gimme = GIMME_V;
4370 ENTER_with_name("eval_scope");
4373 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4376 PL_in_eval = EVAL_INEVAL;
4377 if (flags & G_KEEPERR)
4378 PL_in_eval |= EVAL_KEEPERR;
4381 if (flags & G_FAKINGEVAL) {
4382 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4389 PERL_CONTEXT * const cx = create_eval_scope(0);
4390 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4391 return DOCATCH(PL_op->op_next);
4406 PERL_UNUSED_VAR(optype);
4408 SP = leave_common(newsp, SP, newsp, gimme,
4409 SVs_PADTMP|SVs_TEMP, FALSE);
4410 PL_curpm = newpm; /* Don't pop $1 et al till now */
4412 LEAVE_with_name("eval_scope");
4421 const I32 gimme = GIMME_V;
4423 ENTER_with_name("given");
4426 if (PL_op->op_targ) {
4427 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4428 SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4429 PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4436 PUSHBLOCK(cx, CXt_GIVEN, SP);
4449 PERL_UNUSED_CONTEXT;
4452 assert(CxTYPE(cx) == CXt_GIVEN);
4454 SP = leave_common(newsp, SP, newsp, gimme,
4455 SVs_PADTMP|SVs_TEMP, FALSE);
4456 PL_curpm = newpm; /* Don't pop $1 et al till now */
4458 LEAVE_with_name("given");
4462 /* Helper routines used by pp_smartmatch */
4464 S_make_matcher(pTHX_ REGEXP *re)
4466 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4468 PERL_ARGS_ASSERT_MAKE_MATCHER;
4470 PM_SETRE(matcher, ReREFCNT_inc(re));
4472 SAVEFREEOP((OP *) matcher);
4473 ENTER_with_name("matcher"); SAVETMPS;
4479 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4483 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4485 PL_op = (OP *) matcher;
4488 (void) Perl_pp_match(aTHX);
4490 return (SvTRUEx(POPs));
4494 S_destroy_matcher(pTHX_ PMOP *matcher)
4496 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4497 PERL_UNUSED_ARG(matcher);
4500 LEAVE_with_name("matcher");
4503 /* Do a smart match */
4506 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4507 return do_smartmatch(NULL, NULL, 0);
4510 /* This version of do_smartmatch() implements the
4511 * table of smart matches that is found in perlsyn.
4514 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4518 bool object_on_left = FALSE;
4519 SV *e = TOPs; /* e is for 'expression' */
4520 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4522 /* Take care only to invoke mg_get() once for each argument.
4523 * Currently we do this by copying the SV if it's magical. */
4525 if (!copied && SvGMAGICAL(d))
4526 d = sv_mortalcopy(d);
4533 e = sv_mortalcopy(e);
4535 /* First of all, handle overload magic of the rightmost argument */
4538 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4539 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4541 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4548 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4551 SP -= 2; /* Pop the values */
4556 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4563 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4564 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4565 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4567 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4568 object_on_left = TRUE;
4571 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4573 if (object_on_left) {
4574 goto sm_any_sub; /* Treat objects like scalars */
4576 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4577 /* Test sub truth for each key */
4579 bool andedresults = TRUE;
4580 HV *hv = (HV*) SvRV(d);
4581 I32 numkeys = hv_iterinit(hv);
4582 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4585 while ( (he = hv_iternext(hv)) ) {
4586 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4587 ENTER_with_name("smartmatch_hash_key_test");
4590 PUSHs(hv_iterkeysv(he));
4592 c = call_sv(e, G_SCALAR);
4595 andedresults = FALSE;
4597 andedresults = SvTRUEx(POPs) && andedresults;
4599 LEAVE_with_name("smartmatch_hash_key_test");
4606 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4607 /* Test sub truth for each element */
4609 bool andedresults = TRUE;
4610 AV *av = (AV*) SvRV(d);
4611 const I32 len = av_tindex(av);
4612 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4615 for (i = 0; i <= len; ++i) {
4616 SV * const * const svp = av_fetch(av, i, FALSE);
4617 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4618 ENTER_with_name("smartmatch_array_elem_test");
4624 c = call_sv(e, G_SCALAR);
4627 andedresults = FALSE;
4629 andedresults = SvTRUEx(POPs) && andedresults;
4631 LEAVE_with_name("smartmatch_array_elem_test");
4640 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4641 ENTER_with_name("smartmatch_coderef");
4646 c = call_sv(e, G_SCALAR);
4650 else if (SvTEMP(TOPs))
4651 SvREFCNT_inc_void(TOPs);
4653 LEAVE_with_name("smartmatch_coderef");
4658 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4659 if (object_on_left) {
4660 goto sm_any_hash; /* Treat objects like scalars */
4662 else if (!SvOK(d)) {
4663 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4666 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4667 /* Check that the key-sets are identical */
4669 HV *other_hv = MUTABLE_HV(SvRV(d));
4672 U32 this_key_count = 0,
4673 other_key_count = 0;
4674 HV *hv = MUTABLE_HV(SvRV(e));
4676 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4677 /* Tied hashes don't know how many keys they have. */
4678 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4679 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4683 HV * const temp = other_hv;
4689 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4693 /* The hashes have the same number of keys, so it suffices
4694 to check that one is a subset of the other. */
4695 (void) hv_iterinit(hv);
4696 while ( (he = hv_iternext(hv)) ) {
4697 SV *key = hv_iterkeysv(he);
4699 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4702 if(!hv_exists_ent(other_hv, key, 0)) {
4703 (void) hv_iterinit(hv); /* reset iterator */
4709 (void) hv_iterinit(other_hv);
4710 while ( hv_iternext(other_hv) )
4714 other_key_count = HvUSEDKEYS(other_hv);
4716 if (this_key_count != other_key_count)
4721 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4722 AV * const other_av = MUTABLE_AV(SvRV(d));
4723 const SSize_t other_len = av_tindex(other_av) + 1;
4725 HV *hv = MUTABLE_HV(SvRV(e));
4727 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4728 for (i = 0; i < other_len; ++i) {
4729 SV ** const svp = av_fetch(other_av, i, FALSE);
4730 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4731 if (svp) { /* ??? When can this not happen? */
4732 if (hv_exists_ent(hv, *svp, 0))
4738 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4739 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4742 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4744 HV *hv = MUTABLE_HV(SvRV(e));
4746 (void) hv_iterinit(hv);
4747 while ( (he = hv_iternext(hv)) ) {
4748 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4749 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4750 (void) hv_iterinit(hv);
4751 destroy_matcher(matcher);
4755 destroy_matcher(matcher);
4761 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4762 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4769 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4770 if (object_on_left) {
4771 goto sm_any_array; /* Treat objects like scalars */
4773 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4774 AV * const other_av = MUTABLE_AV(SvRV(e));
4775 const SSize_t other_len = av_tindex(other_av) + 1;
4778 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4779 for (i = 0; i < other_len; ++i) {
4780 SV ** const svp = av_fetch(other_av, i, FALSE);
4782 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4783 if (svp) { /* ??? When can this not happen? */
4784 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4790 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4791 AV *other_av = MUTABLE_AV(SvRV(d));
4792 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4793 if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4797 const SSize_t other_len = av_tindex(other_av);
4799 if (NULL == seen_this) {
4800 seen_this = newHV();
4801 (void) sv_2mortal(MUTABLE_SV(seen_this));
4803 if (NULL == seen_other) {
4804 seen_other = newHV();
4805 (void) sv_2mortal(MUTABLE_SV(seen_other));
4807 for(i = 0; i <= other_len; ++i) {
4808 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4809 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4811 if (!this_elem || !other_elem) {
4812 if ((this_elem && SvOK(*this_elem))
4813 || (other_elem && SvOK(*other_elem)))
4816 else if (hv_exists_ent(seen_this,
4817 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4818 hv_exists_ent(seen_other,
4819 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4821 if (*this_elem != *other_elem)
4825 (void)hv_store_ent(seen_this,
4826 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4828 (void)hv_store_ent(seen_other,
4829 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4835 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4836 (void) do_smartmatch(seen_this, seen_other, 0);
4838 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4847 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4848 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4851 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4852 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4855 for(i = 0; i <= this_len; ++i) {
4856 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4857 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4858 if (svp && matcher_matches_sv(matcher, *svp)) {
4859 destroy_matcher(matcher);
4863 destroy_matcher(matcher);
4867 else if (!SvOK(d)) {
4868 /* undef ~~ array */
4869 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4872 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4873 for (i = 0; i <= this_len; ++i) {
4874 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4875 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4876 if (!svp || !SvOK(*svp))
4885 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4887 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4888 for (i = 0; i <= this_len; ++i) {
4889 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4896 /* infinite recursion isn't supposed to happen here */
4897 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4898 (void) do_smartmatch(NULL, NULL, 1);
4900 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4909 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4910 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4911 SV *t = d; d = e; e = t;
4912 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4915 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4916 SV *t = d; d = e; e = t;
4917 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4918 goto sm_regex_array;
4921 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4923 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4925 PUSHs(matcher_matches_sv(matcher, d)
4928 destroy_matcher(matcher);
4933 /* See if there is overload magic on left */
4934 else if (object_on_left && SvAMAGIC(d)) {
4936 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4937 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4940 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4948 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4951 else if (!SvOK(d)) {
4952 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4953 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4958 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4959 DEBUG_M(if (SvNIOK(e))
4960 Perl_deb(aTHX_ " applying rule Any-Num\n");
4962 Perl_deb(aTHX_ " applying rule Num-numish\n");
4964 /* numeric comparison */
4967 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4968 (void) Perl_pp_i_eq(aTHX);
4970 (void) Perl_pp_eq(aTHX);
4978 /* As a last resort, use string comparison */
4979 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4982 return Perl_pp_seq(aTHX);
4989 const I32 gimme = GIMME_V;
4991 /* This is essentially an optimization: if the match
4992 fails, we don't want to push a context and then
4993 pop it again right away, so we skip straight
4994 to the op that follows the leavewhen.
4995 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4997 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4998 RETURNOP(cLOGOP->op_other->op_next);
5000 ENTER_with_name("when");
5003 PUSHBLOCK(cx, CXt_WHEN, SP);
5018 cxix = dopoptogiven(cxstack_ix);
5020 /* diag_listed_as: Can't "when" outside a topicalizer */
5021 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5022 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5025 assert(CxTYPE(cx) == CXt_WHEN);
5027 SP = leave_common(newsp, SP, newsp, gimme,
5028 SVs_PADTMP|SVs_TEMP, FALSE);
5029 PL_curpm = newpm; /* pop $1 et al */
5031 LEAVE_with_name("when");
5033 if (cxix < cxstack_ix)
5036 cx = &cxstack[cxix];
5038 if (CxFOREACH(cx)) {
5039 /* clear off anything above the scope we're re-entering */
5040 I32 inner = PL_scopestack_ix;
5043 if (PL_scopestack_ix < inner)
5044 leave_scope(PL_scopestack[PL_scopestack_ix]);
5045 PL_curcop = cx->blk_oldcop;
5048 return cx->blk_loop.my_op->op_nextop;
5052 RETURNOP(cx->blk_givwhen.leave_op);
5065 PERL_UNUSED_VAR(gimme);
5067 cxix = dopoptowhen(cxstack_ix);
5069 DIE(aTHX_ "Can't \"continue\" outside a when block");
5071 if (cxix < cxstack_ix)
5075 assert(CxTYPE(cx) == CXt_WHEN);
5078 PL_curpm = newpm; /* pop $1 et al */
5080 LEAVE_with_name("when");
5081 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5089 cxix = dopoptogiven(cxstack_ix);
5091 DIE(aTHX_ "Can't \"break\" outside a given block");
5093 cx = &cxstack[cxix];
5095 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5097 if (cxix < cxstack_ix)
5100 /* Restore the sp at the time we entered the given block */
5103 return cx->blk_givwhen.leave_op;
5107 S_doparseform(pTHX_ SV *sv)
5110 char *s = SvPV(sv, len);
5112 char *base = NULL; /* start of current field */
5113 I32 skipspaces = 0; /* number of contiguous spaces seen */
5114 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5115 bool repeat = FALSE; /* ~~ seen on this line */
5116 bool postspace = FALSE; /* a text field may need right padding */
5119 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5121 bool ischop; /* it's a ^ rather than a @ */
5122 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5123 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5127 PERL_ARGS_ASSERT_DOPARSEFORM;
5130 Perl_croak(aTHX_ "Null picture in formline");
5132 if (SvTYPE(sv) >= SVt_PVMG) {
5133 /* This might, of course, still return NULL. */
5134 mg = mg_find(sv, PERL_MAGIC_fm);
5136 sv_upgrade(sv, SVt_PVMG);
5140 /* still the same as previously-compiled string? */
5141 SV *old = mg->mg_obj;
5142 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5143 && len == SvCUR(old)
5144 && strnEQ(SvPVX(old), SvPVX(sv), len)
5146 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5150 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5151 Safefree(mg->mg_ptr);
5157 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5158 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5161 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5162 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5166 /* estimate the buffer size needed */
5167 for (base = s; s <= send; s++) {
5168 if (*s == '\n' || *s == '@' || *s == '^')
5174 Newx(fops, maxops, U32);
5179 *fpc++ = FF_LINEMARK;
5180 noblank = repeat = FALSE;
5198 case ' ': case '\t':
5205 } /* else FALL THROUGH */
5213 *fpc++ = FF_LITERAL;
5221 *fpc++ = (U32)skipspaces;
5225 *fpc++ = FF_NEWLINE;
5229 arg = fpc - linepc + 1;
5236 *fpc++ = FF_LINEMARK;
5237 noblank = repeat = FALSE;
5246 ischop = s[-1] == '^';
5252 arg = (s - base) - 1;
5254 *fpc++ = FF_LITERAL;
5260 if (*s == '*') { /* @* or ^* */
5262 *fpc++ = 2; /* skip the @* or ^* */
5264 *fpc++ = FF_LINESNGL;
5267 *fpc++ = FF_LINEGLOB;
5269 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5270 arg = ischop ? FORM_NUM_BLANK : 0;
5275 const char * const f = ++s;
5278 arg |= FORM_NUM_POINT + (s - f);
5280 *fpc++ = s - base; /* fieldsize for FETCH */
5281 *fpc++ = FF_DECIMAL;
5283 unchopnum |= ! ischop;
5285 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5286 arg = ischop ? FORM_NUM_BLANK : 0;
5288 s++; /* skip the '0' first */
5292 const char * const f = ++s;
5295 arg |= FORM_NUM_POINT + (s - f);
5297 *fpc++ = s - base; /* fieldsize for FETCH */
5298 *fpc++ = FF_0DECIMAL;
5300 unchopnum |= ! ischop;
5302 else { /* text field */
5304 bool ismore = FALSE;
5307 while (*++s == '>') ;
5308 prespace = FF_SPACE;
5310 else if (*s == '|') {
5311 while (*++s == '|') ;
5312 prespace = FF_HALFSPACE;
5317 while (*++s == '<') ;
5320 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5324 *fpc++ = s - base; /* fieldsize for FETCH */
5326 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5329 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5343 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5346 mg->mg_ptr = (char *) fops;
5347 mg->mg_len = arg * sizeof(U32);
5348 mg->mg_obj = sv_copy;
5349 mg->mg_flags |= MGf_REFCOUNTED;
5351 if (unchopnum && repeat)
5352 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5359 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5361 /* Can value be printed in fldsize chars, using %*.*f ? */
5365 int intsize = fldsize - (value < 0 ? 1 : 0);
5367 if (frcsize & FORM_NUM_POINT)
5369 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5372 while (intsize--) pwr *= 10.0;
5373 while (frcsize--) eps /= 10.0;
5376 if (value + eps >= pwr)
5379 if (value - eps <= -pwr)
5386 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5388 SV * const datasv = FILTER_DATA(idx);
5389 const int filter_has_file = IoLINES(datasv);
5390 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5391 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5396 char *prune_from = NULL;
5397 bool read_from_cache = FALSE;
5401 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5403 assert(maxlen >= 0);
5406 /* I was having segfault trouble under Linux 2.2.5 after a
5407 parse error occured. (Had to hack around it with a test
5408 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5409 not sure where the trouble is yet. XXX */
5412 SV *const cache = datasv;
5415 const char *cache_p = SvPV(cache, cache_len);
5419 /* Running in block mode and we have some cached data already.
5421 if (cache_len >= umaxlen) {
5422 /* In fact, so much data we don't even need to call
5427 const char *const first_nl =
5428 (const char *)memchr(cache_p, '\n', cache_len);
5430 take = first_nl + 1 - cache_p;
5434 sv_catpvn(buf_sv, cache_p, take);
5435 sv_chop(cache, cache_p + take);
5436 /* Definitely not EOF */
5440 sv_catsv(buf_sv, cache);
5442 umaxlen -= cache_len;
5445 read_from_cache = TRUE;
5449 /* Filter API says that the filter appends to the contents of the buffer.
5450 Usually the buffer is "", so the details don't matter. But if it's not,
5451 then clearly what it contains is already filtered by this filter, so we
5452 don't want to pass it in a second time.
5453 I'm going to use a mortal in case the upstream filter croaks. */
5454 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5455 ? sv_newmortal() : buf_sv;
5456 SvUPGRADE(upstream, SVt_PV);
5458 if (filter_has_file) {
5459 status = FILTER_READ(idx+1, upstream, 0);
5462 if (filter_sub && status >= 0) {
5466 ENTER_with_name("call_filter_sub");
5471 DEFSV_set(upstream);
5475 PUSHs(filter_state);
5478 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5488 SV * const errsv = ERRSV;
5489 if (SvTRUE_NN(errsv))
5490 err = newSVsv(errsv);
5496 LEAVE_with_name("call_filter_sub");
5499 if (SvGMAGICAL(upstream)) {
5501 if (upstream == buf_sv) mg_free(buf_sv);
5503 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5504 if(!err && SvOK(upstream)) {
5505 got_p = SvPV_nomg(upstream, got_len);
5507 if (got_len > umaxlen) {
5508 prune_from = got_p + umaxlen;
5511 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5512 if (first_nl && first_nl + 1 < got_p + got_len) {
5513 /* There's a second line here... */
5514 prune_from = first_nl + 1;
5518 if (!err && prune_from) {
5519 /* Oh. Too long. Stuff some in our cache. */
5520 STRLEN cached_len = got_p + got_len - prune_from;
5521 SV *const cache = datasv;
5524 /* Cache should be empty. */
5525 assert(!SvCUR(cache));
5528 sv_setpvn(cache, prune_from, cached_len);
5529 /* If you ask for block mode, you may well split UTF-8 characters.
5530 "If it breaks, you get to keep both parts"
5531 (Your code is broken if you don't put them back together again
5532 before something notices.) */
5533 if (SvUTF8(upstream)) {
5536 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5538 /* Cannot just use sv_setpvn, as that could free the buffer
5539 before we have a chance to assign it. */
5540 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5541 got_len - cached_len);
5543 /* Can't yet be EOF */
5548 /* If they are at EOF but buf_sv has something in it, then they may never
5549 have touched the SV upstream, so it may be undefined. If we naively
5550 concatenate it then we get a warning about use of uninitialised value.
5552 if (!err && upstream != buf_sv &&
5554 sv_catsv_nomg(buf_sv, upstream);
5556 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5559 IoLINES(datasv) = 0;
5561 SvREFCNT_dec(filter_state);
5562 IoTOP_GV(datasv) = NULL;
5565 SvREFCNT_dec(filter_sub);
5566 IoBOTTOM_GV(datasv) = NULL;
5568 filter_del(S_run_user_filter);
5574 if (status == 0 && read_from_cache) {
5575 /* If we read some data from the cache (and by getting here it implies
5576 that we emptied the cache) then we aren't yet at EOF, and mustn't
5577 report that to our caller. */
5585 * c-indentation-style: bsd
5587 * indent-tabs-mode: nil
5590 * ex: set ts=8 sts=4 sw=4 et: