3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
37 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
39 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
45 const PERL_CONTEXT *cx;
48 if (PL_op->op_private & OPpOFFBYONE) {
49 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
52 cxix = dopoptosub(cxstack_ix);
58 switch (cx->blk_gimme) {
77 PMOP *pm = (PMOP*)cLOGOP->op_other;
82 const regexp_engine *eng;
83 bool is_bare_re= FALSE;
85 if (PL_op->op_flags & OPf_STACKED) {
95 /* prevent recompiling under /o and ithreads. */
96 #if defined(USE_ITHREADS)
97 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
104 assert (re != (REGEXP*) &PL_sv_undef);
105 eng = re ? RX_ENGINE(re) : current_re_engine();
108 In the below logic: these are basically the same - check if this regcomp is part of a split.
110 (PL_op->op_pmflags & PMf_split )
111 (PL_op->op_next->op_type == OP_PUSHRE)
113 We could add a new mask for this and copy the PMf_split, if we did
114 some bit definition fiddling first.
116 For now we leave this
119 new_re = (eng->op_comp
121 : &Perl_re_op_compile
122 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
124 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
126 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
128 if (pm->op_pmflags & PMf_HAS_CV)
129 ReANY(new_re)->qr_anoncv
130 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
134 /* The match's LHS's get-magic might need to access this op's regexp
135 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
136 get-magic now before we replace the regexp. Hopefully this hack can
137 be replaced with the approach described at
138 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
140 if (pm->op_type == OP_MATCH) {
142 const bool was_tainted = TAINT_get;
143 if (pm->op_flags & OPf_STACKED)
145 else if (pm->op_private & OPpTARGET_MY)
146 lhs = PAD_SV(pm->op_targ);
149 /* Restore the previous value of PL_tainted (which may have been
150 modified by get-magic), to avoid incorrectly setting the
151 RXf_TAINTED flag with RX_TAINT_on further down. */
152 TAINT_set(was_tainted);
153 #ifdef NO_TAINT_SUPPORT
154 PERL_UNUSED_VAR(was_tainted);
157 tmp = reg_temp_copy(NULL, new_re);
158 ReREFCNT_dec(new_re);
164 PM_SETRE(pm, new_re);
168 if (TAINTING_get && TAINT_get) {
169 SvTAINTED_on((SV*)new_re);
173 #if !defined(USE_ITHREADS)
174 /* can't change the optree at runtime either */
175 /* PMf_KEEP is handled differently under threads to avoid these problems */
176 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
178 if (pm->op_pmflags & PMf_KEEP) {
179 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
180 cLOGOP->op_first->op_next = PL_op->op_next;
192 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
193 PMOP * const pm = (PMOP*) cLOGOP->op_other;
194 SV * const dstr = cx->sb_dstr;
197 char *orig = cx->sb_orig;
198 REGEXP * const rx = cx->sb_rx;
200 REGEXP *old = PM_GETRE(pm);
207 PM_SETRE(pm,ReREFCNT_inc(rx));
210 rxres_restore(&cx->sb_rxres, rx);
212 if (cx->sb_iters++) {
213 const I32 saviters = cx->sb_iters;
214 if (cx->sb_iters > cx->sb_maxiters)
215 DIE(aTHX_ "Substitution loop");
217 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
219 /* See "how taint works" above pp_subst() */
221 cx->sb_rxtainted |= SUBST_TAINT_REPL;
222 sv_catsv_nomg(dstr, POPs);
223 if (CxONCE(cx) || s < orig ||
224 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
225 (s == m), cx->sb_targ, NULL,
226 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
228 SV *targ = cx->sb_targ;
230 assert(cx->sb_strend >= s);
231 if(cx->sb_strend > s) {
232 if (DO_UTF8(dstr) && !SvUTF8(targ))
233 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
235 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
237 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
238 cx->sb_rxtainted |= SUBST_TAINT_PAT;
240 if (pm->op_pmflags & PMf_NONDESTRUCT) {
242 /* From here on down we're using the copy, and leaving the
243 original untouched. */
247 SV_CHECK_THINKFIRST_COW_DROP(targ);
248 if (isGV(targ)) Perl_croak_no_modify();
250 SvPV_set(targ, SvPVX(dstr));
251 SvCUR_set(targ, SvCUR(dstr));
252 SvLEN_set(targ, SvLEN(dstr));
255 SvPV_set(dstr, NULL);
258 mPUSHi(saviters - 1);
260 (void)SvPOK_only_UTF8(targ);
263 /* update the taint state of various various variables in
264 * preparation for final exit.
265 * See "how taint works" above pp_subst() */
267 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
268 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
269 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
271 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
273 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
274 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
276 SvTAINTED_on(TOPs); /* taint return value */
277 /* needed for mg_set below */
279 cBOOL(cx->sb_rxtainted &
280 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
284 /* PL_tainted must be correctly set for this mg_set */
287 LEAVE_SCOPE(cx->sb_oldsave);
290 RETURNOP(pm->op_next);
291 assert(0); /* NOTREACHED */
293 cx->sb_iters = saviters;
295 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
298 assert(!RX_SUBOFFSET(rx));
299 cx->sb_orig = orig = RX_SUBBEG(rx);
301 cx->sb_strend = s + (cx->sb_strend - m);
303 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
305 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
306 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
308 sv_catpvn_nomg(dstr, s, m-s);
310 cx->sb_s = RX_OFFS(rx)[0].end + orig;
311 { /* Update the pos() information. */
313 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
315 if (!(mg = mg_find_mglob(sv))) {
316 mg = sv_magicext_mglob(sv);
319 MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
322 (void)ReREFCNT_inc(rx);
323 /* update the taint state of various various variables in preparation
324 * for calling the code block.
325 * See "how taint works" above pp_subst() */
327 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
328 cx->sb_rxtainted |= SUBST_TAINT_PAT;
330 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
331 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
332 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
334 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
336 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
337 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
338 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
339 ? cx->sb_dstr : cx->sb_targ);
342 rxres_save(&cx->sb_rxres, rx);
344 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
348 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
353 PERL_ARGS_ASSERT_RXRES_SAVE;
356 if (!p || p[1] < RX_NPARENS(rx)) {
358 i = 7 + (RX_NPARENS(rx)+1) * 2;
360 i = 6 + (RX_NPARENS(rx)+1) * 2;
369 /* what (if anything) to free on croak */
370 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
371 RX_MATCH_COPIED_off(rx);
372 *p++ = RX_NPARENS(rx);
375 *p++ = PTR2UV(RX_SAVED_COPY(rx));
376 RX_SAVED_COPY(rx) = NULL;
379 *p++ = PTR2UV(RX_SUBBEG(rx));
380 *p++ = (UV)RX_SUBLEN(rx);
381 *p++ = (UV)RX_SUBOFFSET(rx);
382 *p++ = (UV)RX_SUBCOFFSET(rx);
383 for (i = 0; i <= RX_NPARENS(rx); ++i) {
384 *p++ = (UV)RX_OFFS(rx)[i].start;
385 *p++ = (UV)RX_OFFS(rx)[i].end;
390 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
395 PERL_ARGS_ASSERT_RXRES_RESTORE;
398 RX_MATCH_COPY_FREE(rx);
399 RX_MATCH_COPIED_set(rx, *p);
401 RX_NPARENS(rx) = *p++;
404 if (RX_SAVED_COPY(rx))
405 SvREFCNT_dec (RX_SAVED_COPY(rx));
406 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
410 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
411 RX_SUBLEN(rx) = (I32)(*p++);
412 RX_SUBOFFSET(rx) = (I32)*p++;
413 RX_SUBCOFFSET(rx) = (I32)*p++;
414 for (i = 0; i <= RX_NPARENS(rx); ++i) {
415 RX_OFFS(rx)[i].start = (I32)(*p++);
416 RX_OFFS(rx)[i].end = (I32)(*p++);
421 S_rxres_free(pTHX_ void **rsp)
423 UV * const p = (UV*)*rsp;
425 PERL_ARGS_ASSERT_RXRES_FREE;
429 void *tmp = INT2PTR(char*,*p);
432 U32 i = 9 + p[1] * 2;
434 U32 i = 8 + p[1] * 2;
439 SvREFCNT_dec (INT2PTR(SV*,p[2]));
442 PoisonFree(p, i, sizeof(UV));
451 #define FORM_NUM_BLANK (1<<30)
452 #define FORM_NUM_POINT (1<<29)
456 dSP; dMARK; dORIGMARK;
457 SV * const tmpForm = *++MARK;
458 SV *formsv; /* contains text of original format */
459 U32 *fpc; /* format ops program counter */
460 char *t; /* current append position in target string */
461 const char *f; /* current position in format string */
463 SV *sv = NULL; /* current item */
464 const char *item = NULL;/* string value of current item */
465 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
466 I32 itembytes = 0; /* as itemsize, but length in bytes */
467 I32 fieldsize = 0; /* width of current field */
468 I32 lines = 0; /* number of lines that have been output */
469 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
470 const char *chophere = NULL; /* where to chop current item */
471 STRLEN linemark = 0; /* pos of start of line in output */
473 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
474 STRLEN len; /* length of current sv */
475 STRLEN linemax; /* estimate of output size in bytes */
476 bool item_is_utf8 = FALSE;
477 bool targ_is_utf8 = FALSE;
480 U8 *source; /* source of bytes to append */
481 STRLEN to_copy; /* how may bytes to append */
482 char trans; /* what chars to translate */
484 mg = doparseform(tmpForm);
486 fpc = (U32*)mg->mg_ptr;
487 /* the actual string the format was compiled from.
488 * with overload etc, this may not match tmpForm */
492 SvPV_force(PL_formtarget, len);
493 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
494 SvTAINTED_on(PL_formtarget);
495 if (DO_UTF8(PL_formtarget))
497 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
498 t = SvGROW(PL_formtarget, len + linemax + 1);
499 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
501 f = SvPV_const(formsv, len);
505 const char *name = "???";
508 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
509 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
510 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
511 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
512 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
514 case FF_CHECKNL: name = "CHECKNL"; break;
515 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
516 case FF_SPACE: name = "SPACE"; break;
517 case FF_HALFSPACE: name = "HALFSPACE"; break;
518 case FF_ITEM: name = "ITEM"; break;
519 case FF_CHOP: name = "CHOP"; break;
520 case FF_LINEGLOB: name = "LINEGLOB"; break;
521 case FF_NEWLINE: name = "NEWLINE"; break;
522 case FF_MORE: name = "MORE"; break;
523 case FF_LINEMARK: name = "LINEMARK"; break;
524 case FF_END: name = "END"; break;
525 case FF_0DECIMAL: name = "0DECIMAL"; break;
526 case FF_LINESNGL: name = "LINESNGL"; break;
529 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
531 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
534 case FF_LINEMARK: /* start (or end) of a line */
535 linemark = t - SvPVX(PL_formtarget);
540 case FF_LITERAL: /* append <arg> literal chars */
545 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
548 case FF_SKIP: /* skip <arg> chars in format */
552 case FF_FETCH: /* get next item and set field size to <arg> */
561 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
564 SvTAINTED_on(PL_formtarget);
567 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
569 const char *s = item = SvPV_const(sv, len);
570 const char *send = s + len;
573 item_is_utf8 = DO_UTF8(sv);
585 if (itemsize == fieldsize)
588 itembytes = s - item;
592 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
594 const char *s = item = SvPV_const(sv, len);
595 const char *send = s + len;
599 item_is_utf8 = DO_UTF8(sv);
601 /* look for a legal split position */
609 /* provisional split point */
613 /* we delay testing fieldsize until after we've
614 * processed the possible split char directly
615 * following the last field char; so if fieldsize=3
616 * and item="a b cdef", we consume "a b", not "a".
617 * Ditto further down.
619 if (size == fieldsize)
623 if (strchr(PL_chopset, *s)) {
624 /* provisional split point */
625 /* for a non-space split char, we include
626 * the split char; hence the '+1' */
630 if (size == fieldsize)
642 if (!chophere || s == send) {
646 itembytes = chophere - item;
651 case FF_SPACE: /* append padding space (diff of field, item size) */
652 arg = fieldsize - itemsize;
660 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
661 arg = fieldsize - itemsize;
670 case FF_ITEM: /* append a text item, while blanking ctrl chars */
676 case FF_CHOP: /* (for ^*) chop the current item */
678 const char *s = chophere;
686 /* tied, overloaded or similar strangeness.
687 * Do it the hard way */
688 sv_setpvn(sv, s, len - (s-item));
693 case FF_LINESNGL: /* process ^* */
697 case FF_LINEGLOB: /* process @* */
699 const bool oneline = fpc[-1] == FF_LINESNGL;
700 const char *s = item = SvPV_const(sv, len);
701 const char *const send = s + len;
703 item_is_utf8 = DO_UTF8(sv);
714 to_copy = s - item - 1;
728 /* append to_copy bytes from source to PL_formstring.
729 * item_is_utf8 implies source is utf8.
730 * if trans, translate certain characters during the copy */
735 SvCUR_set(PL_formtarget,
736 t - SvPVX_const(PL_formtarget));
738 if (targ_is_utf8 && !item_is_utf8) {
739 source = tmp = bytes_to_utf8(source, &to_copy);
741 if (item_is_utf8 && !targ_is_utf8) {
743 /* Upgrade targ to UTF8, and then we reduce it to
744 a problem we have a simple solution for.
745 Don't need get magic. */
746 sv_utf8_upgrade_nomg(PL_formtarget);
748 /* re-calculate linemark */
749 s = (U8*)SvPVX(PL_formtarget);
750 /* the bytes we initially allocated to append the
751 * whole line may have been gobbled up during the
752 * upgrade, so allocate a whole new line's worth
757 linemark = s - (U8*)SvPVX(PL_formtarget);
759 /* Easy. They agree. */
760 assert (item_is_utf8 == targ_is_utf8);
763 /* @* and ^* are the only things that can exceed
764 * the linemax, so grow by the output size, plus
765 * a whole new form's worth in case of any further
767 grow = linemax + to_copy;
769 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
770 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
772 Copy(source, t, to_copy, char);
774 /* blank out ~ or control chars, depending on trans.
775 * works on bytes not chars, so relies on not
776 * matching utf8 continuation bytes */
778 U8 *send = s + to_copy;
781 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
788 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
794 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
796 #if defined(USE_LONG_DOUBLE)
798 ((arg & FORM_NUM_POINT) ?
799 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
802 ((arg & FORM_NUM_POINT) ?
803 "%#0*.*f" : "%0*.*f");
807 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
809 #if defined(USE_LONG_DOUBLE)
811 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
814 ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
817 /* If the field is marked with ^ and the value is undefined,
819 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
827 /* overflow evidence */
828 if (num_overflow(value, fieldsize, arg)) {
834 /* Formats aren't yet marked for locales, so assume "yes". */
836 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
838 DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
839 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
840 /* we generate fmt ourselves so it is safe */
841 GCC_DIAG_IGNORE(-Wformat-nonliteral);
842 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
843 PERL_MY_SNPRINTF_POST_GUARD(len, max);
845 RESTORE_LC_NUMERIC();
850 case FF_NEWLINE: /* delete trailing spaces, then append \n */
852 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
857 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
860 if (arg) { /* repeat until fields exhausted? */
866 t = SvPVX(PL_formtarget) + linemark;
871 case FF_MORE: /* replace long end of string with '...' */
873 const char *s = chophere;
874 const char *send = item + len;
876 while (isSPACE(*s) && (s < send))
881 arg = fieldsize - itemsize;
888 if (strnEQ(s1," ",3)) {
889 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
899 case FF_END: /* tidy up, then return */
901 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
903 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
905 SvUTF8_on(PL_formtarget);
906 FmLINES(PL_formtarget) += lines;
908 if (fpc[-1] == FF_BLANK)
909 RETURNOP(cLISTOP->op_first);
921 if (PL_stack_base + *PL_markstack_ptr == SP) {
923 if (GIMME_V == G_SCALAR)
925 RETURNOP(PL_op->op_next->op_next);
927 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
928 Perl_pp_pushmark(aTHX); /* push dst */
929 Perl_pp_pushmark(aTHX); /* push src */
930 ENTER_with_name("grep"); /* enter outer scope */
933 if (PL_op->op_private & OPpGREP_LEX)
934 SAVESPTR(PAD_SVl(PL_op->op_targ));
937 ENTER_with_name("grep_item"); /* enter inner scope */
940 src = PL_stack_base[*PL_markstack_ptr];
942 assert(!IS_PADGV(src));
943 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
947 if (PL_op->op_private & OPpGREP_LEX)
948 PAD_SVl(PL_op->op_targ) = src;
953 if (PL_op->op_type == OP_MAPSTART)
954 Perl_pp_pushmark(aTHX); /* push top */
955 return ((LOGOP*)PL_op->op_next)->op_other;
961 const I32 gimme = GIMME_V;
962 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
968 /* first, move source pointer to the next item in the source list */
969 ++PL_markstack_ptr[-1];
971 /* if there are new items, push them into the destination list */
972 if (items && gimme != G_VOID) {
973 /* might need to make room back there first */
974 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
975 /* XXX this implementation is very pessimal because the stack
976 * is repeatedly extended for every set of items. Is possible
977 * to do this without any stack extension or copying at all
978 * by maintaining a separate list over which the map iterates
979 * (like foreach does). --gsar */
981 /* everything in the stack after the destination list moves
982 * towards the end the stack by the amount of room needed */
983 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
985 /* items to shift up (accounting for the moved source pointer) */
986 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
988 /* This optimization is by Ben Tilly and it does
989 * things differently from what Sarathy (gsar)
990 * is describing. The downside of this optimization is
991 * that leaves "holes" (uninitialized and hopefully unused areas)
992 * to the Perl stack, but on the other hand this
993 * shouldn't be a problem. If Sarathy's idea gets
994 * implemented, this optimization should become
995 * irrelevant. --jhi */
997 shift = count; /* Avoid shifting too often --Ben Tilly */
1001 dst = (SP += shift);
1002 PL_markstack_ptr[-1] += shift;
1003 *PL_markstack_ptr += shift;
1007 /* copy the new items down to the destination list */
1008 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1009 if (gimme == G_ARRAY) {
1010 /* add returned items to the collection (making mortal copies
1011 * if necessary), then clear the current temps stack frame
1012 * *except* for those items. We do this splicing the items
1013 * into the start of the tmps frame (so some items may be on
1014 * the tmps stack twice), then moving PL_tmps_floor above
1015 * them, then freeing the frame. That way, the only tmps that
1016 * accumulate over iterations are the return values for map.
1017 * We have to do to this way so that everything gets correctly
1018 * freed if we die during the map.
1022 /* make space for the slice */
1023 EXTEND_MORTAL(items);
1024 tmpsbase = PL_tmps_floor + 1;
1025 Move(PL_tmps_stack + tmpsbase,
1026 PL_tmps_stack + tmpsbase + items,
1027 PL_tmps_ix - PL_tmps_floor,
1029 PL_tmps_ix += items;
1034 sv = sv_mortalcopy(sv);
1036 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1038 /* clear the stack frame except for the items */
1039 PL_tmps_floor += items;
1041 /* FREETMPS may have cleared the TEMP flag on some of the items */
1044 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1047 /* scalar context: we don't care about which values map returns
1048 * (we use undef here). And so we certainly don't want to do mortal
1049 * copies of meaningless values. */
1050 while (items-- > 0) {
1052 *dst-- = &PL_sv_undef;
1060 LEAVE_with_name("grep_item"); /* exit inner scope */
1063 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1065 (void)POPMARK; /* pop top */
1066 LEAVE_with_name("grep"); /* exit outer scope */
1067 (void)POPMARK; /* pop src */
1068 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1069 (void)POPMARK; /* pop dst */
1070 SP = PL_stack_base + POPMARK; /* pop original mark */
1071 if (gimme == G_SCALAR) {
1072 if (PL_op->op_private & OPpGREP_LEX) {
1073 SV* sv = sv_newmortal();
1074 sv_setiv(sv, items);
1082 else if (gimme == G_ARRAY)
1089 ENTER_with_name("grep_item"); /* enter inner scope */
1092 /* set $_ to the new source item */
1093 src = PL_stack_base[PL_markstack_ptr[-1]];
1094 if (SvPADTMP(src)) {
1095 assert(!IS_PADGV(src));
1096 src = sv_mortalcopy(src);
1099 if (PL_op->op_private & OPpGREP_LEX)
1100 PAD_SVl(PL_op->op_targ) = src;
1104 RETURNOP(cLOGOP->op_other);
1112 if (GIMME == G_ARRAY)
1114 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1115 return cLOGOP->op_other;
1124 if (GIMME == G_ARRAY) {
1125 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1129 SV * const targ = PAD_SV(PL_op->op_targ);
1132 if (PL_op->op_private & OPpFLIP_LINENUM) {
1133 if (GvIO(PL_last_in_gv)) {
1134 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1137 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1139 flip = SvIV(sv) == SvIV(GvSV(gv));
1145 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1146 if (PL_op->op_flags & OPf_SPECIAL) {
1154 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1157 sv_setpvs(TARG, "");
1163 /* This code tries to decide if "$left .. $right" should use the
1164 magical string increment, or if the range is numeric (we make
1165 an exception for .."0" [#18165]). AMS 20021031. */
1167 #define RANGE_IS_NUMERIC(left,right) ( \
1168 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1169 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1170 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1171 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1172 && (!SvOK(right) || looks_like_number(right))))
1178 if (GIMME == G_ARRAY) {
1184 if (RANGE_IS_NUMERIC(left,right)) {
1186 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1187 (SvOK(right) && (SvIOK(right)
1188 ? SvIsUV(right) && SvUV(right) > IV_MAX
1189 : SvNV_nomg(right) > IV_MAX)))
1190 DIE(aTHX_ "Range iterator outside integer range");
1191 i = SvIV_nomg(left);
1192 j = SvIV_nomg(right);
1194 /* Dance carefully around signed max. */
1195 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1198 /* The wraparound of signed integers is undefined
1199 * behavior, but here we aim for count >=1, and
1200 * negative count is just wrong. */
1205 Perl_croak(aTHX_ "Out of memory during list extend");
1212 SV * const sv = sv_2mortal(newSViv(i++));
1218 const char * const lpv = SvPV_nomg_const(left, llen);
1219 const char * const tmps = SvPV_nomg_const(right, len);
1221 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1222 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1224 if (strEQ(SvPVX_const(sv),tmps))
1226 sv = sv_2mortal(newSVsv(sv));
1233 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1237 if (PL_op->op_private & OPpFLIP_LINENUM) {
1238 if (GvIO(PL_last_in_gv)) {
1239 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1242 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1243 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1251 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1252 sv_catpvs(targ, "E0");
1262 static const char * const context_name[] = {
1264 NULL, /* CXt_WHEN never actually needs "block" */
1265 NULL, /* CXt_BLOCK never actually needs "block" */
1266 NULL, /* CXt_GIVEN never actually needs "block" */
1267 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1268 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1269 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1270 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1278 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1282 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1284 for (i = cxstack_ix; i >= 0; i--) {
1285 const PERL_CONTEXT * const cx = &cxstack[i];
1286 switch (CxTYPE(cx)) {
1292 /* diag_listed_as: Exiting subroutine via %s */
1293 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1294 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1295 if (CxTYPE(cx) == CXt_NULL)
1298 case CXt_LOOP_LAZYIV:
1299 case CXt_LOOP_LAZYSV:
1301 case CXt_LOOP_PLAIN:
1303 STRLEN cx_label_len = 0;
1304 U32 cx_label_flags = 0;
1305 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1307 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1310 (const U8*)cx_label, cx_label_len,
1311 (const U8*)label, len) == 0)
1313 (const U8*)label, len,
1314 (const U8*)cx_label, cx_label_len) == 0)
1315 : (len == cx_label_len && ((cx_label == label)
1316 || memEQ(cx_label, label, len))) )) {
1317 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1318 (long)i, cx_label));
1321 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1332 Perl_dowantarray(pTHX)
1334 const I32 gimme = block_gimme();
1335 return (gimme == G_VOID) ? G_SCALAR : gimme;
1339 Perl_block_gimme(pTHX)
1341 const I32 cxix = dopoptosub(cxstack_ix);
1345 switch (cxstack[cxix].blk_gimme) {
1353 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1355 NOT_REACHED; /* NOTREACHED */
1359 Perl_is_lvalue_sub(pTHX)
1361 const I32 cxix = dopoptosub(cxstack_ix);
1362 assert(cxix >= 0); /* We should only be called from inside subs */
1364 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1365 return CxLVAL(cxstack + cxix);
1370 /* only used by PUSHSUB */
1372 Perl_was_lvalue_sub(pTHX)
1374 const I32 cxix = dopoptosub(cxstack_ix-1);
1375 assert(cxix >= 0); /* We should only be called from inside subs */
1377 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1378 return CxLVAL(cxstack + cxix);
1384 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1388 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1390 PERL_UNUSED_CONTEXT;
1393 for (i = startingblock; i >= 0; i--) {
1394 const PERL_CONTEXT * const cx = &cxstk[i];
1395 switch (CxTYPE(cx)) {
1399 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1400 * twice; the first for the normal foo() call, and the second
1401 * for a faked up re-entry into the sub to execute the
1402 * code block. Hide this faked entry from the world. */
1403 if (cx->cx_type & CXp_SUB_RE_FAKE)
1408 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1416 S_dopoptoeval(pTHX_ I32 startingblock)
1419 for (i = startingblock; i >= 0; i--) {
1420 const PERL_CONTEXT *cx = &cxstack[i];
1421 switch (CxTYPE(cx)) {
1425 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1433 S_dopoptoloop(pTHX_ I32 startingblock)
1436 for (i = startingblock; i >= 0; i--) {
1437 const PERL_CONTEXT * const cx = &cxstack[i];
1438 switch (CxTYPE(cx)) {
1444 /* diag_listed_as: Exiting subroutine via %s */
1445 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1446 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1447 if ((CxTYPE(cx)) == CXt_NULL)
1450 case CXt_LOOP_LAZYIV:
1451 case CXt_LOOP_LAZYSV:
1453 case CXt_LOOP_PLAIN:
1454 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1462 S_dopoptogiven(pTHX_ I32 startingblock)
1465 for (i = startingblock; i >= 0; i--) {
1466 const PERL_CONTEXT *cx = &cxstack[i];
1467 switch (CxTYPE(cx)) {
1471 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1473 case CXt_LOOP_PLAIN:
1474 assert(!CxFOREACHDEF(cx));
1476 case CXt_LOOP_LAZYIV:
1477 case CXt_LOOP_LAZYSV:
1479 if (CxFOREACHDEF(cx)) {
1480 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1489 S_dopoptowhen(pTHX_ I32 startingblock)
1492 for (i = startingblock; i >= 0; i--) {
1493 const PERL_CONTEXT *cx = &cxstack[i];
1494 switch (CxTYPE(cx)) {
1498 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1506 Perl_dounwind(pTHX_ I32 cxix)
1510 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1513 while (cxstack_ix > cxix) {
1515 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1516 DEBUG_CX("UNWIND"); \
1517 /* Note: we don't need to restore the base context info till the end. */
1518 switch (CxTYPE(cx)) {
1521 continue; /* not break */
1529 case CXt_LOOP_LAZYIV:
1530 case CXt_LOOP_LAZYSV:
1532 case CXt_LOOP_PLAIN:
1543 PERL_UNUSED_VAR(optype);
1547 Perl_qerror(pTHX_ SV *err)
1549 PERL_ARGS_ASSERT_QERROR;
1552 if (PL_in_eval & EVAL_KEEPERR) {
1553 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1557 sv_catsv(ERRSV, err);
1560 sv_catsv(PL_errors, err);
1562 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1564 ++PL_parser->error_count;
1568 Perl_die_unwind(pTHX_ SV *msv)
1570 SV *exceptsv = sv_mortalcopy(msv);
1571 U8 in_eval = PL_in_eval;
1572 PERL_ARGS_ASSERT_DIE_UNWIND;
1579 * Historically, perl used to set ERRSV ($@) early in the die
1580 * process and rely on it not getting clobbered during unwinding.
1581 * That sucked, because it was liable to get clobbered, so the
1582 * setting of ERRSV used to emit the exception from eval{} has
1583 * been moved to much later, after unwinding (see just before
1584 * JMPENV_JUMP below). However, some modules were relying on the
1585 * early setting, by examining $@ during unwinding to use it as
1586 * a flag indicating whether the current unwinding was caused by
1587 * an exception. It was never a reliable flag for that purpose,
1588 * being totally open to false positives even without actual
1589 * clobberage, but was useful enough for production code to
1590 * semantically rely on it.
1592 * We'd like to have a proper introspective interface that
1593 * explicitly describes the reason for whatever unwinding
1594 * operations are currently in progress, so that those modules
1595 * work reliably and $@ isn't further overloaded. But we don't
1596 * have one yet. In its absence, as a stopgap measure, ERRSV is
1597 * now *additionally* set here, before unwinding, to serve as the
1598 * (unreliable) flag that it used to.
1600 * This behaviour is temporary, and should be removed when a
1601 * proper way to detect exceptional unwinding has been developed.
1602 * As of 2010-12, the authors of modules relying on the hack
1603 * are aware of the issue, because the modules failed on
1604 * perls 5.13.{1..7} which had late setting of $@ without this
1605 * early-setting hack.
1607 if (!(in_eval & EVAL_KEEPERR)) {
1608 SvTEMP_off(exceptsv);
1609 sv_setsv(ERRSV, exceptsv);
1612 if (in_eval & EVAL_KEEPERR) {
1613 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1617 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1618 && PL_curstackinfo->si_prev)
1630 JMPENV *restartjmpenv;
1633 if (cxix < cxstack_ix)
1636 POPBLOCK(cx,PL_curpm);
1637 if (CxTYPE(cx) != CXt_EVAL) {
1639 const char* message = SvPVx_const(exceptsv, msglen);
1640 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1641 PerlIO_write(Perl_error_log, message, msglen);
1645 namesv = cx->blk_eval.old_namesv;
1646 oldcop = cx->blk_oldcop;
1647 restartjmpenv = cx->blk_eval.cur_top_env;
1648 restartop = cx->blk_eval.retop;
1650 if (gimme == G_SCALAR)
1651 *++newsp = &PL_sv_undef;
1652 PL_stack_sp = newsp;
1656 /* LEAVE could clobber PL_curcop (see save_re_context())
1657 * XXX it might be better to find a way to avoid messing with
1658 * PL_curcop in save_re_context() instead, but this is a more
1659 * minimal fix --GSAR */
1662 if (optype == OP_REQUIRE) {
1663 (void)hv_store(GvHVn(PL_incgv),
1664 SvPVX_const(namesv),
1665 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1667 /* note that unlike pp_entereval, pp_require isn't
1668 * supposed to trap errors. So now that we've popped the
1669 * EVAL that pp_require pushed, and processed the error
1670 * message, rethrow the error */
1671 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1672 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1675 if (!(in_eval & EVAL_KEEPERR))
1676 sv_setsv(ERRSV, exceptsv);
1677 PL_restartjmpenv = restartjmpenv;
1678 PL_restartop = restartop;
1680 assert(0); /* NOTREACHED */
1684 write_to_stderr(exceptsv);
1686 assert(0); /* NOTREACHED */
1692 if (SvTRUE(left) != SvTRUE(right))
1700 =head1 CV Manipulation Functions
1702 =for apidoc caller_cx
1704 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1705 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1706 information returned to Perl by C<caller>. Note that XSUBs don't get a
1707 stack frame, so C<caller_cx(0, NULL)> will return information for the
1708 immediately-surrounding Perl code.
1710 This function skips over the automatic calls to C<&DB::sub> made on the
1711 behalf of the debugger. If the stack frame requested was a sub called by
1712 C<DB::sub>, the return value will be the frame for the call to
1713 C<DB::sub>, since that has the correct line number/etc. for the call
1714 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1715 frame for the sub call itself.
1720 const PERL_CONTEXT *
1721 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1723 I32 cxix = dopoptosub(cxstack_ix);
1724 const PERL_CONTEXT *cx;
1725 const PERL_CONTEXT *ccstack = cxstack;
1726 const PERL_SI *top_si = PL_curstackinfo;
1729 /* we may be in a higher stacklevel, so dig down deeper */
1730 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1731 top_si = top_si->si_prev;
1732 ccstack = top_si->si_cxstack;
1733 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1737 /* caller() should not report the automatic calls to &DB::sub */
1738 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1739 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1743 cxix = dopoptosub_at(ccstack, cxix - 1);
1746 cx = &ccstack[cxix];
1747 if (dbcxp) *dbcxp = cx;
1749 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1750 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1751 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1752 field below is defined for any cx. */
1753 /* caller() should not report the automatic calls to &DB::sub */
1754 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1755 cx = &ccstack[dbcxix];
1764 const PERL_CONTEXT *cx;
1765 const PERL_CONTEXT *dbcx;
1767 const HEK *stash_hek;
1769 bool has_arg = MAXARG && TOPs;
1778 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1780 if (GIMME != G_ARRAY) {
1788 assert(CopSTASH(cx->blk_oldcop));
1789 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1790 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1792 if (GIMME != G_ARRAY) {
1795 PUSHs(&PL_sv_undef);
1798 sv_sethek(TARG, stash_hek);
1807 PUSHs(&PL_sv_undef);
1810 sv_sethek(TARG, stash_hek);
1813 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1814 lcop = closest_cop(cx->blk_oldcop, OP_SIBLING(cx->blk_oldcop),
1815 cx->blk_sub.retop, TRUE);
1817 lcop = cx->blk_oldcop;
1818 mPUSHi((I32)CopLINE(lcop));
1821 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1822 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1823 /* So is ccstack[dbcxix]. */
1824 if (cvgv && isGV(cvgv)) {
1825 SV * const sv = newSV(0);
1826 gv_efullname3(sv, cvgv, NULL);
1828 PUSHs(boolSV(CxHASARGS(cx)));
1831 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1832 PUSHs(boolSV(CxHASARGS(cx)));
1836 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1839 gimme = (I32)cx->blk_gimme;
1840 if (gimme == G_VOID)
1841 PUSHs(&PL_sv_undef);
1843 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1844 if (CxTYPE(cx) == CXt_EVAL) {
1846 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1847 SV *cur_text = cx->blk_eval.cur_text;
1848 if (SvCUR(cur_text) >= 2) {
1849 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1850 SvUTF8(cur_text)|SVs_TEMP));
1853 /* I think this is will always be "", but be sure */
1854 PUSHs(sv_2mortal(newSVsv(cur_text)));
1860 else if (cx->blk_eval.old_namesv) {
1861 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1864 /* eval BLOCK (try blocks have old_namesv == 0) */
1866 PUSHs(&PL_sv_undef);
1867 PUSHs(&PL_sv_undef);
1871 PUSHs(&PL_sv_undef);
1872 PUSHs(&PL_sv_undef);
1874 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1875 && CopSTASH_eq(PL_curcop, PL_debstash))
1877 AV * const ary = cx->blk_sub.argarray;
1878 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1880 Perl_init_dbargs(aTHX);
1882 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1883 av_extend(PL_dbargs, AvFILLp(ary) + off);
1884 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1885 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1887 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1890 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1892 if (old_warnings == pWARN_NONE)
1893 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1894 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1895 mask = &PL_sv_undef ;
1896 else if (old_warnings == pWARN_ALL ||
1897 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1898 /* Get the bit mask for $warnings::Bits{all}, because
1899 * it could have been extended by warnings::register */
1901 HV * const bits = get_hv("warnings::Bits", 0);
1902 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1903 mask = newSVsv(*bits_all);
1906 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1910 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1914 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1915 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1925 if (MAXARG < 1 || (!TOPs && !POPs))
1926 tmps = NULL, len = 0;
1928 tmps = SvPVx_const(POPs, len);
1929 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1934 /* like pp_nextstate, but used instead when the debugger is active */
1938 PL_curcop = (COP*)PL_op;
1939 TAINT_NOT; /* Each statement is presumed innocent */
1940 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1945 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1946 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1950 const I32 gimme = G_ARRAY;
1952 GV * const gv = PL_DBgv;
1955 if (gv && isGV_with_GP(gv))
1958 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1959 DIE(aTHX_ "No DB::DB routine defined");
1961 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1962 /* don't do recursive DB::DB call */
1976 (void)(*CvXSUB(cv))(aTHX_ cv);
1982 PUSHBLOCK(cx, CXt_SUB, SP);
1984 cx->blk_sub.retop = PL_op->op_next;
1986 if (CvDEPTH(cv) >= 2) {
1987 PERL_STACK_OVERFLOW_CHECK();
1988 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1991 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1992 RETURNOP(CvSTART(cv));
1999 /* SVs on the stack that have any of the flags passed in are left as is.
2000 Other SVs are protected via the mortals stack if lvalue is true, and
2001 copied otherwise. */
2004 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
2005 U32 flags, bool lvalue)
2008 PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2010 if (flags & SVs_PADTMP) {
2011 flags &= ~SVs_PADTMP;
2014 if (gimme == G_SCALAR) {
2016 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2019 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2020 : sv_mortalcopy(*SP);
2022 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2025 *++MARK = &PL_sv_undef;
2029 else if (gimme == G_ARRAY) {
2030 /* in case LEAVE wipes old return values */
2031 while (++MARK <= SP) {
2032 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2036 ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
2037 : sv_mortalcopy(*MARK);
2038 TAINT_NOT; /* Each item is independent */
2041 /* When this function was called with MARK == newsp, we reach this
2042 * point with SP == newsp. */
2052 I32 gimme = GIMME_V;
2054 ENTER_with_name("block");
2057 PUSHBLOCK(cx, CXt_BLOCK, SP);
2070 if (PL_op->op_flags & OPf_SPECIAL) {
2071 cx = &cxstack[cxstack_ix];
2072 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2077 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2080 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
2081 PL_op->op_private & OPpLVALUE);
2082 PL_curpm = newpm; /* Don't pop $1 et al till now */
2084 LEAVE_with_name("block");
2093 const I32 gimme = GIMME_V;
2094 void *itervar; /* location of the iteration variable */
2095 U8 cxtype = CXt_LOOP_FOR;
2097 ENTER_with_name("loop1");
2100 if (PL_op->op_targ) { /* "my" variable */
2101 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2102 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2103 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2104 SVs_PADSTALE, SVs_PADSTALE);
2106 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2108 itervar = PL_comppad;
2110 itervar = &PAD_SVl(PL_op->op_targ);
2113 else { /* symbol table variable */
2114 GV * const gv = MUTABLE_GV(POPs);
2115 SV** svp = &GvSV(gv);
2116 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2118 itervar = (void *)gv;
2121 if (PL_op->op_private & OPpITER_DEF)
2122 cxtype |= CXp_FOR_DEF;
2124 ENTER_with_name("loop2");
2126 PUSHBLOCK(cx, cxtype, SP);
2127 PUSHLOOP_FOR(cx, itervar, MARK);
2128 if (PL_op->op_flags & OPf_STACKED) {
2129 SV *maybe_ary = POPs;
2130 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2132 SV * const right = maybe_ary;
2135 if (RANGE_IS_NUMERIC(sv,right)) {
2136 cx->cx_type &= ~CXTYPEMASK;
2137 cx->cx_type |= CXt_LOOP_LAZYIV;
2138 /* Make sure that no-one re-orders cop.h and breaks our
2140 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2141 #ifdef NV_PRESERVES_UV
2142 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2143 (SvNV_nomg(sv) > (NV)IV_MAX)))
2145 (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2146 (SvNV_nomg(right) < (NV)IV_MIN))))
2148 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
2150 ((SvNV_nomg(sv) > 0) &&
2151 ((SvUV_nomg(sv) > (UV)IV_MAX) ||
2152 (SvNV_nomg(sv) > (NV)UV_MAX)))))
2154 (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
2156 ((SvNV_nomg(right) > 0) &&
2157 ((SvUV_nomg(right) > (UV)IV_MAX) ||
2158 (SvNV_nomg(right) > (NV)UV_MAX))
2161 DIE(aTHX_ "Range iterator outside integer range");
2162 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2163 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2165 /* for correct -Dstv display */
2166 cx->blk_oldsp = sp - PL_stack_base;
2170 cx->cx_type &= ~CXTYPEMASK;
2171 cx->cx_type |= CXt_LOOP_LAZYSV;
2172 /* Make sure that no-one re-orders cop.h and breaks our
2174 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2175 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2176 cx->blk_loop.state_u.lazysv.end = right;
2177 SvREFCNT_inc(right);
2178 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2179 /* This will do the upgrade to SVt_PV, and warn if the value
2180 is uninitialised. */
2181 (void) SvPV_nolen_const(right);
2182 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2183 to replace !SvOK() with a pointer to "". */
2185 SvREFCNT_dec(right);
2186 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2190 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2191 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2192 SvREFCNT_inc(maybe_ary);
2193 cx->blk_loop.state_u.ary.ix =
2194 (PL_op->op_private & OPpITER_REVERSED) ?
2195 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2199 else { /* iterating over items on the stack */
2200 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2201 if (PL_op->op_private & OPpITER_REVERSED) {
2202 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2205 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2216 const I32 gimme = GIMME_V;
2218 ENTER_with_name("loop1");
2220 ENTER_with_name("loop2");
2222 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2223 PUSHLOOP_PLAIN(cx, SP);
2238 assert(CxTYPE_is_LOOP(cx));
2240 newsp = PL_stack_base + cx->blk_loop.resetsp;
2243 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0,
2244 PL_op->op_private & OPpLVALUE);
2247 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2248 PL_curpm = newpm; /* ... and pop $1 et al */
2250 LEAVE_with_name("loop2");
2251 LEAVE_with_name("loop1");
2257 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2258 PERL_CONTEXT *cx, PMOP *newpm)
2260 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2261 if (gimme == G_SCALAR) {
2262 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2264 const char *what = NULL;
2266 assert(MARK+1 == SP);
2267 if ((SvPADTMP(TOPs) ||
2268 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2271 !SvSMAGICAL(TOPs)) {
2273 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2274 : "a readonly value" : "a temporary";
2279 /* sub:lvalue{} will take us here. */
2288 "Can't return %s from lvalue subroutine", what
2293 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2294 if (!SvPADTMP(*SP)) {
2295 *++newsp = SvREFCNT_inc(*SP);
2300 /* FREETMPS could clobber it */
2301 SV *sv = SvREFCNT_inc(*SP);
2303 *++newsp = sv_mortalcopy(sv);
2310 ? sv_mortalcopy(*SP)
2312 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2317 *++newsp = &PL_sv_undef;
2319 if (CxLVAL(cx) & OPpDEREF) {
2322 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2326 else if (gimme == G_ARRAY) {
2327 assert (!(CxLVAL(cx) & OPpDEREF));
2328 if (ref || !CxLVAL(cx))
2329 while (++MARK <= SP)
2331 SvFLAGS(*MARK) & SVs_PADTMP
2332 ? sv_mortalcopy(*MARK)
2335 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2336 else while (++MARK <= SP) {
2337 if (*MARK != &PL_sv_undef
2339 || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2344 /* Might be flattened array after $#array = */
2351 /* diag_listed_as: Can't return %s from lvalue subroutine */
2353 "Can't return a %s from lvalue subroutine",
2354 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2360 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2363 PL_stack_sp = newsp;
2370 bool popsub2 = FALSE;
2371 bool clear_errsv = FALSE;
2381 const I32 cxix = dopoptosub(cxstack_ix);
2384 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2385 * sort block, which is a CXt_NULL
2388 PL_stack_base[1] = *PL_stack_sp;
2389 PL_stack_sp = PL_stack_base + 1;
2393 DIE(aTHX_ "Can't return outside a subroutine");
2395 if (cxix < cxstack_ix)
2398 if (CxMULTICALL(&cxstack[cxix])) {
2399 gimme = cxstack[cxix].blk_gimme;
2400 if (gimme == G_VOID)
2401 PL_stack_sp = PL_stack_base;
2402 else if (gimme == G_SCALAR) {
2403 PL_stack_base[1] = *PL_stack_sp;
2404 PL_stack_sp = PL_stack_base + 1;
2410 switch (CxTYPE(cx)) {
2413 lval = !!CvLVALUE(cx->blk_sub.cv);
2414 retop = cx->blk_sub.retop;
2415 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2418 if (!(PL_in_eval & EVAL_KEEPERR))
2421 namesv = cx->blk_eval.old_namesv;
2422 retop = cx->blk_eval.retop;
2425 if (optype == OP_REQUIRE &&
2426 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2428 /* Unassume the success we assumed earlier. */
2429 (void)hv_delete(GvHVn(PL_incgv),
2430 SvPVX_const(namesv),
2431 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2433 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2437 retop = cx->blk_sub.retop;
2441 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2445 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2447 if (gimme == G_SCALAR) {
2450 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2451 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2452 && !SvMAGICAL(TOPs)) {
2453 *++newsp = SvREFCNT_inc(*SP);
2458 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2460 *++newsp = sv_mortalcopy(sv);
2464 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2465 && !SvMAGICAL(*SP)) {
2469 *++newsp = sv_mortalcopy(*SP);
2472 *++newsp = sv_mortalcopy(*SP);
2475 *++newsp = &PL_sv_undef;
2477 else if (gimme == G_ARRAY) {
2478 while (++MARK <= SP) {
2479 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2480 && !SvGMAGICAL(*MARK)
2481 ? *MARK : sv_mortalcopy(*MARK);
2482 TAINT_NOT; /* Each item is independent */
2485 PL_stack_sp = newsp;
2489 /* Stack values are safe: */
2492 POPSUB(cx,sv); /* release CV and @_ ... */
2496 PL_curpm = newpm; /* ... and pop $1 et al */
2505 /* This duplicates parts of pp_leavesub, so that it can share code with
2516 if (CxMULTICALL(&cxstack[cxstack_ix]))
2520 cxstack_ix++; /* temporarily protect top context */
2524 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2527 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2529 PL_curpm = newpm; /* ... and pop $1 et al */
2532 return cx->blk_sub.retop;
2536 S_unwind_loop(pTHX_ const char * const opname)
2539 if (PL_op->op_flags & OPf_SPECIAL) {
2540 cxix = dopoptoloop(cxstack_ix);
2542 /* diag_listed_as: Can't "last" outside a loop block */
2543 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2548 const char * const label =
2549 PL_op->op_flags & OPf_STACKED
2550 ? SvPV(TOPs,label_len)
2551 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2552 const U32 label_flags =
2553 PL_op->op_flags & OPf_STACKED
2555 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2557 cxix = dopoptolabel(label, label_len, label_flags);
2559 /* diag_listed_as: Label not found for "last %s" */
2560 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2562 SVfARG(PL_op->op_flags & OPf_STACKED
2563 && !SvGMAGICAL(TOPp1s)
2565 : newSVpvn_flags(label,
2567 label_flags | SVs_TEMP)));
2569 if (cxix < cxstack_ix)
2585 S_unwind_loop(aTHX_ "last");
2588 cxstack_ix++; /* temporarily protect top context */
2589 switch (CxTYPE(cx)) {
2590 case CXt_LOOP_LAZYIV:
2591 case CXt_LOOP_LAZYSV:
2593 case CXt_LOOP_PLAIN:
2595 newsp = PL_stack_base + cx->blk_loop.resetsp;
2596 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2600 nextop = cx->blk_sub.retop;
2604 nextop = cx->blk_eval.retop;
2608 nextop = cx->blk_sub.retop;
2611 DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2615 PL_stack_sp = newsp;
2619 /* Stack values are safe: */
2621 case CXt_LOOP_LAZYIV:
2622 case CXt_LOOP_PLAIN:
2623 case CXt_LOOP_LAZYSV:
2625 POPLOOP(cx); /* release loop vars ... */
2629 POPSUB(cx,sv); /* release CV and @_ ... */
2632 PL_curpm = newpm; /* ... and pop $1 et al */
2635 PERL_UNUSED_VAR(optype);
2636 PERL_UNUSED_VAR(gimme);
2643 const I32 inner = PL_scopestack_ix;
2645 S_unwind_loop(aTHX_ "next");
2647 /* clear off anything above the scope we're re-entering, but
2648 * save the rest until after a possible continue block */
2650 if (PL_scopestack_ix < inner)
2651 leave_scope(PL_scopestack[PL_scopestack_ix]);
2652 PL_curcop = cx->blk_oldcop;
2654 return (cx)->blk_loop.my_op->op_nextop;
2659 const I32 cxix = S_unwind_loop(aTHX_ "redo");
2662 OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2664 if (redo_op->op_type == OP_ENTER) {
2665 /* pop one less context to avoid $x being freed in while (my $x..) */
2667 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2668 redo_op = redo_op->op_next;
2672 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2673 LEAVE_SCOPE(oldsave);
2675 PL_curcop = cx->blk_oldcop;
2681 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2684 static const char* const too_deep = "Target of goto is too deeply nested";
2686 PERL_ARGS_ASSERT_DOFINDLABEL;
2689 Perl_croak(aTHX_ "%s", too_deep);
2690 if (o->op_type == OP_LEAVE ||
2691 o->op_type == OP_SCOPE ||
2692 o->op_type == OP_LEAVELOOP ||
2693 o->op_type == OP_LEAVESUB ||
2694 o->op_type == OP_LEAVETRY)
2696 *ops++ = cUNOPo->op_first;
2698 Perl_croak(aTHX_ "%s", too_deep);
2701 if (o->op_flags & OPf_KIDS) {
2703 /* First try all the kids at this level, since that's likeliest. */
2704 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2705 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2706 STRLEN kid_label_len;
2707 U32 kid_label_flags;
2708 const char *kid_label = CopLABEL_len_flags(kCOP,
2709 &kid_label_len, &kid_label_flags);
2711 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2714 (const U8*)kid_label, kid_label_len,
2715 (const U8*)label, len) == 0)
2717 (const U8*)label, len,
2718 (const U8*)kid_label, kid_label_len) == 0)
2719 : ( len == kid_label_len && ((kid_label == label)
2720 || memEQ(kid_label, label, len)))))
2724 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2725 if (kid == PL_lastgotoprobe)
2727 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2730 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2731 ops[-1]->op_type == OP_DBSTATE)
2736 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2744 PP(pp_goto) /* also pp_dump */
2750 #define GOTO_DEPTH 64
2751 OP *enterops[GOTO_DEPTH];
2752 const char *label = NULL;
2753 STRLEN label_len = 0;
2754 U32 label_flags = 0;
2755 const bool do_dump = (PL_op->op_type == OP_DUMP);
2756 static const char* const must_have_label = "goto must have label";
2758 if (PL_op->op_flags & OPf_STACKED) {
2759 /* goto EXPR or goto &foo */
2761 SV * const sv = POPs;
2764 /* This egregious kludge implements goto &subroutine */
2765 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2768 CV *cv = MUTABLE_CV(SvRV(sv));
2769 AV *arg = GvAV(PL_defgv);
2773 if (!CvROOT(cv) && !CvXSUB(cv)) {
2774 const GV * const gv = CvGV(cv);
2778 /* autoloaded stub? */
2779 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2781 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2783 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2784 if (autogv && (cv = GvCV(autogv)))
2786 tmpstr = sv_newmortal();
2787 gv_efullname3(tmpstr, gv, NULL);
2788 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2790 DIE(aTHX_ "Goto undefined subroutine");
2793 /* First do some returnish stuff. */
2794 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2796 cxix = dopoptosub(cxstack_ix);
2797 if (cxix < cxstack_ix) {
2800 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2806 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2807 if (CxTYPE(cx) == CXt_EVAL) {
2810 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2811 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2813 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2814 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2816 else if (CxMULTICALL(cx))
2819 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2821 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2822 AV* av = cx->blk_sub.argarray;
2824 /* abandon the original @_ if it got reified or if it is
2825 the same as the current @_ */
2826 if (AvREAL(av) || av == arg) {
2830 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2832 else CLEAR_ARGARRAY(av);
2834 /* We donate this refcount later to the callee’s pad. */
2835 SvREFCNT_inc_simple_void(arg);
2836 if (CxTYPE(cx) == CXt_SUB &&
2837 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2838 SvREFCNT_dec(cx->blk_sub.cv);
2839 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2840 LEAVE_SCOPE(oldsave);
2842 /* A destructor called during LEAVE_SCOPE could have undefined
2843 * our precious cv. See bug #99850. */
2844 if (!CvROOT(cv) && !CvXSUB(cv)) {
2845 const GV * const gv = CvGV(cv);
2848 SV * const tmpstr = sv_newmortal();
2849 gv_efullname3(tmpstr, gv, NULL);
2850 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2853 DIE(aTHX_ "Goto undefined subroutine");
2856 /* Now do some callish stuff. */
2858 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2860 OP* const retop = cx->blk_sub.retop;
2863 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2864 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2867 PERL_UNUSED_VAR(newsp);
2868 PERL_UNUSED_VAR(gimme);
2870 /* put GvAV(defgv) back onto stack */
2872 EXTEND(SP, items+1); /* @_ could have been extended. */
2877 bool r = cBOOL(AvREAL(arg));
2878 for (index=0; index<items; index++)
2882 SV ** const svp = av_fetch(arg, index, 0);
2883 sv = svp ? *svp : NULL;
2885 else sv = AvARRAY(arg)[index];
2887 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2888 : sv_2mortal(newSVavdefelem(arg, index, 1));
2893 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2894 /* Restore old @_ */
2895 arg = GvAV(PL_defgv);
2896 GvAV(PL_defgv) = cx->blk_sub.savearray;
2900 /* XS subs don't have a CxSUB, so pop it */
2901 POPBLOCK(cx, PL_curpm);
2902 /* Push a mark for the start of arglist */
2905 (void)(*CvXSUB(cv))(aTHX_ cv);
2911 PADLIST * const padlist = CvPADLIST(cv);
2912 cx->blk_sub.cv = cv;
2913 cx->blk_sub.olddepth = CvDEPTH(cv);
2916 if (CvDEPTH(cv) < 2)
2917 SvREFCNT_inc_simple_void_NN(cv);
2919 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2920 sub_crush_depth(cv);
2921 pad_push(padlist, CvDEPTH(cv));
2923 PL_curcop = cx->blk_oldcop;
2925 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2928 CX_CURPAD_SAVE(cx->blk_sub);
2930 /* cx->blk_sub.argarray has no reference count, so we
2931 need something to hang on to our argument array so
2932 that cx->blk_sub.argarray does not end up pointing
2933 to freed memory as the result of undef *_. So put
2934 it in the callee’s pad, donating our refer-
2937 SvREFCNT_dec(PAD_SVl(0));
2938 PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2941 /* GvAV(PL_defgv) might have been modified on scope
2942 exit, so restore it. */
2943 if (arg != GvAV(PL_defgv)) {
2944 AV * const av = GvAV(PL_defgv);
2945 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2949 else SvREFCNT_dec(arg);
2950 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2951 Perl_get_db_sub(aTHX_ NULL, cv);
2953 CV * const gotocv = get_cvs("DB::goto", 0);
2955 PUSHMARK( PL_stack_sp );
2956 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2962 RETURNOP(CvSTART(cv));
2967 label = SvPV_nomg_const(sv, label_len);
2968 label_flags = SvUTF8(sv);
2971 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2972 /* goto LABEL or dump LABEL */
2973 label = cPVOP->op_pv;
2974 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2975 label_len = strlen(label);
2977 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2982 OP *gotoprobe = NULL;
2983 bool leaving_eval = FALSE;
2984 bool in_block = FALSE;
2985 PERL_CONTEXT *last_eval_cx = NULL;
2989 PL_lastgotoprobe = NULL;
2991 for (ix = cxstack_ix; ix >= 0; ix--) {
2993 switch (CxTYPE(cx)) {
2995 leaving_eval = TRUE;
2996 if (!CxTRYBLOCK(cx)) {
2997 gotoprobe = (last_eval_cx ?
2998 last_eval_cx->blk_eval.old_eval_root :
3003 /* else fall through */
3004 case CXt_LOOP_LAZYIV:
3005 case CXt_LOOP_LAZYSV:
3007 case CXt_LOOP_PLAIN:
3010 gotoprobe = OP_SIBLING(cx->blk_oldcop);
3016 gotoprobe = OP_SIBLING(cx->blk_oldcop);
3019 gotoprobe = PL_main_root;
3022 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3023 gotoprobe = CvROOT(cx->blk_sub.cv);
3029 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3032 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3033 CxTYPE(cx), (long) ix);
3034 gotoprobe = PL_main_root;
3040 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3041 enterops, enterops + GOTO_DEPTH);
3044 if ( (sibl1 = OP_SIBLING(gotoprobe)) &&
3045 sibl1->op_type == OP_UNSTACK &&
3046 (sibl2 = OP_SIBLING(sibl1)))
3048 retop = dofindlabel(sibl2,
3049 label, label_len, label_flags, enterops,
3050 enterops + GOTO_DEPTH);
3055 PL_lastgotoprobe = gotoprobe;
3058 DIE(aTHX_ "Can't find label %"UTF8f,
3059 UTF8fARG(label_flags, label_len, label));
3061 /* if we're leaving an eval, check before we pop any frames
3062 that we're not going to punt, otherwise the error
3065 if (leaving_eval && *enterops && enterops[1]) {
3067 for (i = 1; enterops[i]; i++)
3068 if (enterops[i]->op_type == OP_ENTERITER)
3069 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3072 if (*enterops && enterops[1]) {
3073 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3075 deprecate("\"goto\" to jump into a construct");
3078 /* pop unwanted frames */
3080 if (ix < cxstack_ix) {
3084 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3087 oldsave = PL_scopestack[PL_scopestack_ix];
3088 LEAVE_SCOPE(oldsave);
3091 /* push wanted frames */
3093 if (*enterops && enterops[1]) {
3094 OP * const oldop = PL_op;
3095 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3096 for (; enterops[ix]; ix++) {
3097 PL_op = enterops[ix];
3098 /* Eventually we may want to stack the needed arguments
3099 * for each op. For now, we punt on the hard ones. */
3100 if (PL_op->op_type == OP_ENTERITER)
3101 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3102 PL_op->op_ppaddr(aTHX);
3110 if (!retop) retop = PL_main_start;
3112 PL_restartop = retop;
3113 PL_do_undump = TRUE;
3117 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3118 PL_do_undump = FALSE;
3133 anum = 0; (void)POPs;
3139 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3142 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3145 PL_exit_flags |= PERL_EXIT_EXPECTED;
3147 PUSHs(&PL_sv_undef);
3154 S_save_lines(pTHX_ AV *array, SV *sv)
3156 const char *s = SvPVX_const(sv);
3157 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3160 PERL_ARGS_ASSERT_SAVE_LINES;
3162 while (s && s < send) {
3164 SV * const tmpstr = newSV_type(SVt_PVMG);
3166 t = (const char *)memchr(s, '\n', send - s);
3172 sv_setpvn(tmpstr, s, t - s);
3173 av_store(array, line++, tmpstr);
3181 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3183 0 is used as continue inside eval,
3185 3 is used for a die caught by an inner eval - continue inner loop
3187 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3188 establish a local jmpenv to handle exception traps.
3193 S_docatch(pTHX_ OP *o)
3196 OP * const oldop = PL_op;
3200 assert(CATCH_GET == TRUE);
3207 assert(cxstack_ix >= 0);
3208 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3209 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3214 /* die caught by an inner eval - continue inner loop */
3215 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3216 PL_restartjmpenv = NULL;
3217 PL_op = PL_restartop;
3226 assert(0); /* NOTREACHED */
3235 =for apidoc find_runcv
3237 Locate the CV corresponding to the currently executing sub or eval.
3238 If db_seqp is non_null, skip CVs that are in the DB package and populate
3239 *db_seqp with the cop sequence number at the point that the DB:: code was
3240 entered. (This allows debuggers to eval in the scope of the breakpoint
3241 rather than in the scope of the debugger itself.)
3247 Perl_find_runcv(pTHX_ U32 *db_seqp)
3249 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3252 /* If this becomes part of the API, it might need a better name. */
3254 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3261 PL_curcop == &PL_compiling
3263 : PL_curcop->cop_seq;
3265 for (si = PL_curstackinfo; si; si = si->si_prev) {
3267 for (ix = si->si_cxix; ix >= 0; ix--) {
3268 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3270 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3271 cv = cx->blk_sub.cv;
3272 /* skip DB:: code */
3273 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3274 *db_seqp = cx->blk_oldcop->cop_seq;
3277 if (cx->cx_type & CXp_SUB_RE)
3280 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3281 cv = cx->blk_eval.cv;
3284 case FIND_RUNCV_padid_eq:
3286 || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
3289 case FIND_RUNCV_level_eq:
3290 if (level++ != arg) continue;
3298 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3302 /* Run yyparse() in a setjmp wrapper. Returns:
3303 * 0: yyparse() successful
3304 * 1: yyparse() failed
3308 S_try_yyparse(pTHX_ int gramtype)
3313 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3317 ret = yyparse(gramtype) ? 1 : 0;
3324 assert(0); /* NOTREACHED */
3331 /* Compile a require/do or an eval ''.
3333 * outside is the lexically enclosing CV (if any) that invoked us.
3334 * seq is the current COP scope value.
3335 * hh is the saved hints hash, if any.
3337 * Returns a bool indicating whether the compile was successful; if so,
3338 * PL_eval_start contains the first op of the compiled code; otherwise,
3341 * This function is called from two places: pp_require and pp_entereval.
3342 * These can be distinguished by whether PL_op is entereval.
3346 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3349 OP * const saveop = PL_op;
3350 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3351 COP * const oldcurcop = PL_curcop;
3352 bool in_require = (saveop->op_type == OP_REQUIRE);
3356 PL_in_eval = (in_require
3357 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3359 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3360 ? EVAL_RE_REPARSING : 0)));
3364 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3366 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3367 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3368 cxstack[cxstack_ix].blk_gimme = gimme;
3370 CvOUTSIDE_SEQ(evalcv) = seq;
3371 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3373 /* set up a scratch pad */
3375 CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3376 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3379 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3381 /* make sure we compile in the right package */
3383 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3384 SAVEGENERICSV(PL_curstash);
3385 PL_curstash = (HV *)CopSTASH(PL_curcop);
3386 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3387 else SvREFCNT_inc_simple_void(PL_curstash);
3389 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3390 SAVESPTR(PL_beginav);
3391 PL_beginav = newAV();
3392 SAVEFREESV(PL_beginav);
3393 SAVESPTR(PL_unitcheckav);
3394 PL_unitcheckav = newAV();
3395 SAVEFREESV(PL_unitcheckav);
3398 ENTER_with_name("evalcomp");
3399 SAVESPTR(PL_compcv);
3402 /* try to compile it */
3404 PL_eval_root = NULL;
3405 PL_curcop = &PL_compiling;
3406 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3407 PL_in_eval |= EVAL_KEEPERR;
3414 hv_clear(GvHV(PL_hintgv));
3417 PL_hints = saveop->op_private & OPpEVAL_COPHH
3418 ? oldcurcop->cop_hints : saveop->op_targ;
3420 /* making 'use re eval' not be in scope when compiling the
3421 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3422 * infinite recursion when S_has_runtime_code() gives a false
3423 * positive: the second time round, HINT_RE_EVAL isn't set so we
3424 * don't bother calling S_has_runtime_code() */
3425 if (PL_in_eval & EVAL_RE_REPARSING)
3426 PL_hints &= ~HINT_RE_EVAL;
3429 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3430 SvREFCNT_dec(GvHV(PL_hintgv));
3431 GvHV(PL_hintgv) = hh;
3434 SAVECOMPILEWARNINGS();
3436 if (PL_dowarn & G_WARN_ALL_ON)
3437 PL_compiling.cop_warnings = pWARN_ALL ;
3438 else if (PL_dowarn & G_WARN_ALL_OFF)
3439 PL_compiling.cop_warnings = pWARN_NONE ;
3441 PL_compiling.cop_warnings = pWARN_STD ;
3444 PL_compiling.cop_warnings =
3445 DUP_WARNINGS(oldcurcop->cop_warnings);
3446 cophh_free(CopHINTHASH_get(&PL_compiling));
3447 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3448 /* The label, if present, is the first entry on the chain. So rather
3449 than writing a blank label in front of it (which involves an
3450 allocation), just use the next entry in the chain. */
3451 PL_compiling.cop_hints_hash
3452 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3453 /* Check the assumption that this removed the label. */
3454 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3457 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3460 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3462 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3463 * so honour CATCH_GET and trap it here if necessary */
3465 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3467 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3468 SV **newsp; /* Used by POPBLOCK. */
3470 I32 optype; /* Used by POPEVAL. */
3476 PERL_UNUSED_VAR(newsp);
3477 PERL_UNUSED_VAR(optype);
3479 /* note that if yystatus == 3, then the EVAL CX block has already
3480 * been popped, and various vars restored */
3482 if (yystatus != 3) {
3484 op_free(PL_eval_root);
3485 PL_eval_root = NULL;
3487 SP = PL_stack_base + POPMARK; /* pop original mark */
3488 POPBLOCK(cx,PL_curpm);
3490 namesv = cx->blk_eval.old_namesv;
3491 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3492 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3498 /* If cx is still NULL, it means that we didn't go in the
3499 * POPEVAL branch. */
3500 cx = &cxstack[cxstack_ix];
3501 assert(CxTYPE(cx) == CXt_EVAL);
3502 namesv = cx->blk_eval.old_namesv;
3504 (void)hv_store(GvHVn(PL_incgv),
3505 SvPVX_const(namesv),
3506 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3508 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3511 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3514 if (!*(SvPV_nolen_const(errsv))) {
3515 sv_setpvs(errsv, "Compilation error");
3518 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3523 LEAVE_with_name("evalcomp");
3525 CopLINE_set(&PL_compiling, 0);
3526 SAVEFREEOP(PL_eval_root);
3527 cv_forget_slab(evalcv);
3529 DEBUG_x(dump_eval());
3531 /* Register with debugger: */
3532 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3533 CV * const cv = get_cvs("DB::postponed", 0);
3537 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3539 call_sv(MUTABLE_SV(cv), G_DISCARD);
3543 if (PL_unitcheckav) {
3544 OP *es = PL_eval_start;
3545 call_list(PL_scopestack_ix, PL_unitcheckav);
3549 /* compiled okay, so do it */
3551 CvDEPTH(evalcv) = 1;
3552 SP = PL_stack_base + POPMARK; /* pop original mark */
3553 PL_op = saveop; /* The caller may need it. */
3554 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3561 S_check_type_and_open(pTHX_ SV *name)
3565 const char *p = SvPV_const(name, len);
3568 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3570 /* checking here captures a reasonable error message when
3571 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3572 * user gets a confusing message about looking for the .pmc file
3573 * rather than for the .pm file.
3574 * This check prevents a \0 in @INC causing problems.
3576 if (!IS_SAFE_PATHNAME(p, len, "require"))
3579 /* we use the value of errno later to see how stat() or open() failed.
3580 * We don't want it set if the stat succeeded but we still failed,
3581 * such as if the name exists, but is a directory */
3584 st_rc = PerlLIO_stat(p, &st);
3586 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3590 #if !defined(PERLIO_IS_STDIO)
3591 return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3593 return PerlIO_open(p, PERL_SCRIPT_MODE);
3597 #ifndef PERL_DISABLE_PMC
3599 S_doopen_pm(pTHX_ SV *name)
3602 const char *p = SvPV_const(name, namelen);
3604 PERL_ARGS_ASSERT_DOOPEN_PM;
3606 /* check the name before trying for the .pmc name to avoid the
3607 * warning referring to the .pmc which the user probably doesn't
3608 * know or care about
3610 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3613 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3614 SV *const pmcsv = sv_newmortal();
3617 SvSetSV_nosteal(pmcsv,name);
3618 sv_catpvs(pmcsv, "c");
3620 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3621 return check_type_and_open(pmcsv);
3623 return check_type_and_open(name);
3626 # define doopen_pm(name) check_type_and_open(name)
3627 #endif /* !PERL_DISABLE_PMC */
3629 /* require doesn't search for absolute names, or when the name is
3630 explicity relative the current directory */
3631 PERL_STATIC_INLINE bool
3632 S_path_is_searchable(const char *name)
3634 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3636 if (PERL_FILE_IS_ABSOLUTE(name)
3638 || (*name == '.' && ((name[1] == '/' ||
3639 (name[1] == '.' && name[2] == '/'))
3640 || (name[1] == '\\' ||
3641 ( name[1] == '.' && name[2] == '\\')))
3644 || (*name == '.' && (name[1] == '/' ||
3645 (name[1] == '.' && name[2] == '/')))
3665 int vms_unixname = 0;
3668 const char *tryname = NULL;
3670 const I32 gimme = GIMME_V;
3671 int filter_has_file = 0;
3672 PerlIO *tryrsfp = NULL;
3673 SV *filter_cache = NULL;
3674 SV *filter_state = NULL;
3675 SV *filter_sub = NULL;
3680 bool path_searchable;
3684 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3685 sv = sv_2mortal(new_version(sv));
3686 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3687 upg_version(PL_patchlevel, TRUE);
3688 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3689 if ( vcmp(sv,PL_patchlevel) <= 0 )
3690 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3691 SVfARG(sv_2mortal(vnormal(sv))),
3692 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3696 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3699 SV * const req = SvRV(sv);
3700 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3702 /* get the left hand term */
3703 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3705 first = SvIV(*av_fetch(lav,0,0));
3706 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3707 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3708 || av_tindex(lav) > 1 /* FP with > 3 digits */
3709 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3711 DIE(aTHX_ "Perl %"SVf" required--this is only "
3713 SVfARG(sv_2mortal(vnormal(req))),
3714 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3717 else { /* probably 'use 5.10' or 'use 5.8' */
3721 if (av_tindex(lav)>=1)
3722 second = SvIV(*av_fetch(lav,1,0));
3724 second /= second >= 600 ? 100 : 10;
3725 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3726 (int)first, (int)second);
3727 upg_version(hintsv, TRUE);
3729 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3730 "--this is only %"SVf", stopped",
3731 SVfARG(sv_2mortal(vnormal(req))),
3732 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3733 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3742 DIE(aTHX_ "Missing or undefined argument to require");
3743 name = SvPV_nomg_const(sv, len);
3744 if (!(name && len > 0 && *name))
3745 DIE(aTHX_ "Missing or undefined argument to require");
3747 if (!IS_SAFE_PATHNAME(name, len, "require")) {
3748 DIE(aTHX_ "Can't locate %s: %s",
3749 pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3750 SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3753 TAINT_PROPER("require");
3755 path_searchable = path_is_searchable(name);
3758 /* The key in the %ENV hash is in the syntax of file passed as the argument
3759 * usually this is in UNIX format, but sometimes in VMS format, which
3760 * can result in a module being pulled in more than once.
3761 * To prevent this, the key must be stored in UNIX format if the VMS
3762 * name can be translated to UNIX.
3766 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3768 unixlen = strlen(unixname);
3774 /* if not VMS or VMS name can not be translated to UNIX, pass it
3777 unixname = (char *) name;
3780 if (PL_op->op_type == OP_REQUIRE) {
3781 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3782 unixname, unixlen, 0);
3784 if (*svp != &PL_sv_undef)
3787 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3788 "Compilation failed in require", unixname);
3792 LOADING_FILE_PROBE(unixname);
3794 /* prepare to compile file */
3796 if (!path_searchable) {
3797 /* At this point, name is SvPVX(sv) */
3799 tryrsfp = doopen_pm(sv);
3801 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3802 AV * const ar = GvAVn(PL_incgv);
3809 namesv = newSV_type(SVt_PV);
3810 for (i = 0; i <= AvFILL(ar); i++) {
3811 SV * const dirsv = *av_fetch(ar, i, TRUE);
3819 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3820 && !SvOBJECT(SvRV(loader)))
3822 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3826 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3827 PTR2UV(SvRV(dirsv)), name);
3828 tryname = SvPVX_const(namesv);
3831 if (SvPADTMP(nsv)) {
3832 nsv = sv_newmortal();
3833 SvSetSV_nosteal(nsv,sv);
3836 ENTER_with_name("call_INC");
3844 if (SvGMAGICAL(loader)) {
3845 SV *l = sv_newmortal();
3846 sv_setsv_nomg(l, loader);
3849 if (sv_isobject(loader))
3850 count = call_method("INC", G_ARRAY);
3852 count = call_sv(loader, G_ARRAY);
3862 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3863 && !isGV_with_GP(SvRV(arg))) {
3864 filter_cache = SvRV(arg);
3871 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3875 if (isGV_with_GP(arg)) {
3876 IO * const io = GvIO((const GV *)arg);
3881 tryrsfp = IoIFP(io);
3882 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3883 PerlIO_close(IoOFP(io));
3894 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3896 SvREFCNT_inc_simple_void_NN(filter_sub);
3899 filter_state = SP[i];
3900 SvREFCNT_inc_simple_void(filter_state);
3904 if (!tryrsfp && (filter_cache || filter_sub)) {
3905 tryrsfp = PerlIO_open(BIT_BUCKET,
3911 /* FREETMPS may free our filter_cache */
3912 SvREFCNT_inc_simple_void(filter_cache);
3916 LEAVE_with_name("call_INC");
3918 /* Now re-mortalize it. */
3919 sv_2mortal(filter_cache);
3921 /* Adjust file name if the hook has set an %INC entry.
3922 This needs to happen after the FREETMPS above. */
3923 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3925 tryname = SvPV_nolen_const(*svp);
3932 filter_has_file = 0;
3933 filter_cache = NULL;
3935 SvREFCNT_dec_NN(filter_state);
3936 filter_state = NULL;
3939 SvREFCNT_dec_NN(filter_sub);
3944 if (path_searchable) {
3949 dir = SvPV_nomg_const(dirsv, dirlen);
3955 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3959 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3962 sv_setpv(namesv, unixdir);
3963 sv_catpv(namesv, unixname);
3965 # ifdef __SYMBIAN32__
3966 if (PL_origfilename[0] &&
3967 PL_origfilename[1] == ':' &&
3968 !(dir[0] && dir[1] == ':'))
3969 Perl_sv_setpvf(aTHX_ namesv,
3974 Perl_sv_setpvf(aTHX_ namesv,
3978 /* The equivalent of
3979 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3980 but without the need to parse the format string, or
3981 call strlen on either pointer, and with the correct
3982 allocation up front. */
3984 char *tmp = SvGROW(namesv, dirlen + len + 2);
3986 memcpy(tmp, dir, dirlen);
3989 /* Avoid '<dir>//<file>' */
3990 if (!dirlen || *(tmp-1) != '/') {
3993 /* So SvCUR_set reports the correct length below */
3997 /* name came from an SV, so it will have a '\0' at the
3998 end that we can copy as part of this memcpy(). */
3999 memcpy(tmp, name, len + 1);
4001 SvCUR_set(namesv, dirlen + len + 1);
4006 TAINT_PROPER("require");
4007 tryname = SvPVX_const(namesv);
4008 tryrsfp = doopen_pm(namesv);
4010 if (tryname[0] == '.' && tryname[1] == '/') {
4012 while (*++tryname == '/') {}
4016 else if (errno == EMFILE || errno == EACCES) {
4017 /* no point in trying other paths if out of handles;
4018 * on the other hand, if we couldn't open one of the
4019 * files, then going on with the search could lead to
4020 * unexpected results; see perl #113422
4029 saved_errno = errno; /* sv_2mortal can realloc things */
4032 if (PL_op->op_type == OP_REQUIRE) {
4033 if(saved_errno == EMFILE || saved_errno == EACCES) {
4034 /* diag_listed_as: Can't locate %s */
4035 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno));
4037 if (namesv) { /* did we lookup @INC? */
4038 AV * const ar = GvAVn(PL_incgv);
4040 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4041 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4042 for (i = 0; i <= AvFILL(ar); i++) {
4043 sv_catpvs(inc, " ");
4044 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4046 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4047 const char *c, *e = name + len - 3;
4048 sv_catpv(msg, " (you may need to install the ");
4049 for (c = name; c < e; c++) {
4051 sv_catpvs(msg, "::");
4054 sv_catpvn(msg, c, 1);
4057 sv_catpv(msg, " module)");
4059 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4060 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4062 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4063 sv_catpv(msg, " (did you run h2ph?)");
4066 /* diag_listed_as: Can't locate %s */
4068 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4072 DIE(aTHX_ "Can't locate %s", name);
4079 SETERRNO(0, SS_NORMAL);
4081 /* Assume success here to prevent recursive requirement. */
4082 /* name is never assigned to again, so len is still strlen(name) */
4083 /* Check whether a hook in @INC has already filled %INC */
4085 (void)hv_store(GvHVn(PL_incgv),
4086 unixname, unixlen, newSVpv(tryname,0),0);
4088 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4090 (void)hv_store(GvHVn(PL_incgv),
4091 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4094 ENTER_with_name("eval");
4096 SAVECOPFILE_FREE(&PL_compiling);
4097 CopFILE_set(&PL_compiling, tryname);
4098 lex_start(NULL, tryrsfp, 0);
4100 if (filter_sub || filter_cache) {
4101 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4102 than hanging another SV from it. In turn, filter_add() optionally
4103 takes the SV to use as the filter (or creates a new SV if passed
4104 NULL), so simply pass in whatever value filter_cache has. */
4105 SV * const fc = filter_cache ? newSV(0) : NULL;
4107 if (fc) sv_copypv(fc, filter_cache);
4108 datasv = filter_add(S_run_user_filter, fc);
4109 IoLINES(datasv) = filter_has_file;
4110 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4111 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4114 /* switch to eval mode */
4115 PUSHBLOCK(cx, CXt_EVAL, SP);
4117 cx->blk_eval.retop = PL_op->op_next;
4119 SAVECOPLINE(&PL_compiling);
4120 CopLINE_set(&PL_compiling, 0);
4124 /* Store and reset encoding. */
4125 encoding = PL_encoding;
4128 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4129 op = DOCATCH(PL_eval_start);
4131 op = PL_op->op_next;
4133 /* Restore encoding. */
4134 PL_encoding = encoding;
4136 LOADED_FILE_PROBE(unixname);
4141 /* This is a op added to hold the hints hash for
4142 pp_entereval. The hash can be modified by the code
4143 being eval'ed, so we return a copy instead. */
4148 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4158 const I32 gimme = GIMME_V;
4159 const U32 was = PL_breakable_sub_gen;
4160 char tbuf[TYPE_DIGITS(long) + 12];
4161 bool saved_delete = FALSE;
4162 char *tmpbuf = tbuf;
4165 U32 seq, lex_flags = 0;
4166 HV *saved_hh = NULL;
4167 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4169 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4170 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4172 else if (PL_hints & HINT_LOCALIZE_HH || (
4173 PL_op->op_private & OPpEVAL_COPHH
4174 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4176 saved_hh = cop_hints_2hv(PL_curcop, 0);
4177 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4181 /* make sure we've got a plain PV (no overload etc) before testing
4182 * for taint. Making a copy here is probably overkill, but better
4183 * safe than sorry */
4185 const char * const p = SvPV_const(sv, len);
4187 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4188 lex_flags |= LEX_START_COPIED;
4190 if (bytes && SvUTF8(sv))
4191 SvPVbyte_force(sv, len);
4193 else if (bytes && SvUTF8(sv)) {
4194 /* Don't modify someone else's scalar */
4197 (void)sv_2mortal(sv);
4198 SvPVbyte_force(sv,len);
4199 lex_flags |= LEX_START_COPIED;
4202 TAINT_IF(SvTAINTED(sv));
4203 TAINT_PROPER("eval");
4205 ENTER_with_name("eval");
4206 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4207 ? LEX_IGNORE_UTF8_HINTS
4208 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4213 /* switch to eval mode */
4215 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4216 SV * const temp_sv = sv_newmortal();
4217 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4218 (unsigned long)++PL_evalseq,
4219 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4220 tmpbuf = SvPVX(temp_sv);
4221 len = SvCUR(temp_sv);
4224 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4225 SAVECOPFILE_FREE(&PL_compiling);
4226 CopFILE_set(&PL_compiling, tmpbuf+2);
4227 SAVECOPLINE(&PL_compiling);
4228 CopLINE_set(&PL_compiling, 1);
4229 /* special case: an eval '' executed within the DB package gets lexically
4230 * placed in the first non-DB CV rather than the current CV - this
4231 * allows the debugger to execute code, find lexicals etc, in the
4232 * scope of the code being debugged. Passing &seq gets find_runcv
4233 * to do the dirty work for us */
4234 runcv = find_runcv(&seq);
4236 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4238 cx->blk_eval.retop = PL_op->op_next;
4240 /* prepare to compile string */
4242 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4243 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4245 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4246 deleting the eval's FILEGV from the stash before gv_check() runs
4247 (i.e. before run-time proper). To work around the coredump that
4248 ensues, we always turn GvMULTI_on for any globals that were
4249 introduced within evals. See force_ident(). GSAR 96-10-12 */
4250 char *const safestr = savepvn(tmpbuf, len);
4251 SAVEDELETE(PL_defstash, safestr, len);
4252 saved_delete = TRUE;
4257 if (doeval(gimme, runcv, seq, saved_hh)) {
4258 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4259 ? (PERLDB_LINE || PERLDB_SAVESRC)
4260 : PERLDB_SAVESRC_NOSUBS) {
4261 /* Retain the filegv we created. */
4262 } else if (!saved_delete) {
4263 char *const safestr = savepvn(tmpbuf, len);
4264 SAVEDELETE(PL_defstash, safestr, len);
4266 return DOCATCH(PL_eval_start);
4268 /* We have already left the scope set up earlier thanks to the LEAVE
4270 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4271 ? (PERLDB_LINE || PERLDB_SAVESRC)
4272 : PERLDB_SAVESRC_INVALID) {
4273 /* Retain the filegv we created. */
4274 } else if (!saved_delete) {
4275 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4277 return PL_op->op_next;
4289 const U8 save_flags = PL_op -> op_flags;
4297 namesv = cx->blk_eval.old_namesv;
4298 retop = cx->blk_eval.retop;
4299 evalcv = cx->blk_eval.cv;
4302 SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4303 gimme, SVs_TEMP, FALSE);
4304 PL_curpm = newpm; /* Don't pop $1 et al till now */
4307 assert(CvDEPTH(evalcv) == 1);
4309 CvDEPTH(evalcv) = 0;
4311 if (optype == OP_REQUIRE &&
4312 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4314 /* Unassume the success we assumed earlier. */
4315 (void)hv_delete(GvHVn(PL_incgv),
4316 SvPVX_const(namesv),
4317 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4319 Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4320 NOT_REACHED; /* NOTREACHED */
4321 /* die_unwind() did LEAVE, or we won't be here */
4324 LEAVE_with_name("eval");
4325 if (!(save_flags & OPf_SPECIAL)) {
4333 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4334 close to the related Perl_create_eval_scope. */
4336 Perl_delete_eval_scope(pTHX)
4347 LEAVE_with_name("eval_scope");
4348 PERL_UNUSED_VAR(newsp);
4349 PERL_UNUSED_VAR(gimme);
4350 PERL_UNUSED_VAR(optype);
4353 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4354 also needed by Perl_fold_constants. */
4356 Perl_create_eval_scope(pTHX_ U32 flags)
4359 const I32 gimme = GIMME_V;
4361 ENTER_with_name("eval_scope");
4364 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4367 PL_in_eval = EVAL_INEVAL;
4368 if (flags & G_KEEPERR)
4369 PL_in_eval |= EVAL_KEEPERR;
4372 if (flags & G_FAKINGEVAL) {
4373 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4380 PERL_CONTEXT * const cx = create_eval_scope(0);
4381 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4382 return DOCATCH(PL_op->op_next);
4397 PERL_UNUSED_VAR(optype);
4400 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
4401 SVs_PADTMP|SVs_TEMP, FALSE);
4402 PL_curpm = newpm; /* Don't pop $1 et al till now */
4404 LEAVE_with_name("eval_scope");
4413 const I32 gimme = GIMME_V;
4415 ENTER_with_name("given");
4418 if (PL_op->op_targ) {
4419 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4420 SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4421 PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4428 PUSHBLOCK(cx, CXt_GIVEN, SP);
4441 PERL_UNUSED_CONTEXT;
4444 assert(CxTYPE(cx) == CXt_GIVEN);
4447 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
4448 SVs_PADTMP|SVs_TEMP, FALSE);
4449 PL_curpm = newpm; /* Don't pop $1 et al till now */
4451 LEAVE_with_name("given");
4455 /* Helper routines used by pp_smartmatch */
4457 S_make_matcher(pTHX_ REGEXP *re)
4459 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4461 PERL_ARGS_ASSERT_MAKE_MATCHER;
4463 PM_SETRE(matcher, ReREFCNT_inc(re));
4465 SAVEFREEOP((OP *) matcher);
4466 ENTER_with_name("matcher"); SAVETMPS;
4472 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4476 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4478 PL_op = (OP *) matcher;
4481 (void) Perl_pp_match(aTHX);
4483 return (SvTRUEx(POPs));
4487 S_destroy_matcher(pTHX_ PMOP *matcher)
4489 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4490 PERL_UNUSED_ARG(matcher);
4493 LEAVE_with_name("matcher");
4496 /* Do a smart match */
4499 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4500 return do_smartmatch(NULL, NULL, 0);
4503 /* This version of do_smartmatch() implements the
4504 * table of smart matches that is found in perlsyn.
4507 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4511 bool object_on_left = FALSE;
4512 SV *e = TOPs; /* e is for 'expression' */
4513 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4515 /* Take care only to invoke mg_get() once for each argument.
4516 * Currently we do this by copying the SV if it's magical. */
4518 if (!copied && SvGMAGICAL(d))
4519 d = sv_mortalcopy(d);
4526 e = sv_mortalcopy(e);
4528 /* First of all, handle overload magic of the rightmost argument */
4531 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4532 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4534 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4541 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4544 SP -= 2; /* Pop the values */
4549 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4556 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4557 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4558 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4560 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4561 object_on_left = TRUE;
4564 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4566 if (object_on_left) {
4567 goto sm_any_sub; /* Treat objects like scalars */
4569 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4570 /* Test sub truth for each key */
4572 bool andedresults = TRUE;
4573 HV *hv = (HV*) SvRV(d);
4574 I32 numkeys = hv_iterinit(hv);
4575 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4578 while ( (he = hv_iternext(hv)) ) {
4579 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4580 ENTER_with_name("smartmatch_hash_key_test");
4583 PUSHs(hv_iterkeysv(he));
4585 c = call_sv(e, G_SCALAR);
4588 andedresults = FALSE;
4590 andedresults = SvTRUEx(POPs) && andedresults;
4592 LEAVE_with_name("smartmatch_hash_key_test");
4599 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4600 /* Test sub truth for each element */
4602 bool andedresults = TRUE;
4603 AV *av = (AV*) SvRV(d);
4604 const I32 len = av_tindex(av);
4605 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4608 for (i = 0; i <= len; ++i) {
4609 SV * const * const svp = av_fetch(av, i, FALSE);
4610 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4611 ENTER_with_name("smartmatch_array_elem_test");
4617 c = call_sv(e, G_SCALAR);
4620 andedresults = FALSE;
4622 andedresults = SvTRUEx(POPs) && andedresults;
4624 LEAVE_with_name("smartmatch_array_elem_test");
4633 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4634 ENTER_with_name("smartmatch_coderef");
4639 c = call_sv(e, G_SCALAR);
4643 else if (SvTEMP(TOPs))
4644 SvREFCNT_inc_void(TOPs);
4646 LEAVE_with_name("smartmatch_coderef");
4651 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4652 if (object_on_left) {
4653 goto sm_any_hash; /* Treat objects like scalars */
4655 else if (!SvOK(d)) {
4656 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4659 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4660 /* Check that the key-sets are identical */
4662 HV *other_hv = MUTABLE_HV(SvRV(d));
4665 U32 this_key_count = 0,
4666 other_key_count = 0;
4667 HV *hv = MUTABLE_HV(SvRV(e));
4669 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4670 /* Tied hashes don't know how many keys they have. */
4671 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4672 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4676 HV * const temp = other_hv;
4682 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4686 /* The hashes have the same number of keys, so it suffices
4687 to check that one is a subset of the other. */
4688 (void) hv_iterinit(hv);
4689 while ( (he = hv_iternext(hv)) ) {
4690 SV *key = hv_iterkeysv(he);
4692 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4695 if(!hv_exists_ent(other_hv, key, 0)) {
4696 (void) hv_iterinit(hv); /* reset iterator */
4702 (void) hv_iterinit(other_hv);
4703 while ( hv_iternext(other_hv) )
4707 other_key_count = HvUSEDKEYS(other_hv);
4709 if (this_key_count != other_key_count)
4714 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4715 AV * const other_av = MUTABLE_AV(SvRV(d));
4716 const SSize_t other_len = av_tindex(other_av) + 1;
4718 HV *hv = MUTABLE_HV(SvRV(e));
4720 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4721 for (i = 0; i < other_len; ++i) {
4722 SV ** const svp = av_fetch(other_av, i, FALSE);
4723 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4724 if (svp) { /* ??? When can this not happen? */
4725 if (hv_exists_ent(hv, *svp, 0))
4731 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4732 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4735 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4737 HV *hv = MUTABLE_HV(SvRV(e));
4739 (void) hv_iterinit(hv);
4740 while ( (he = hv_iternext(hv)) ) {
4741 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4742 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4743 (void) hv_iterinit(hv);
4744 destroy_matcher(matcher);
4748 destroy_matcher(matcher);
4754 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4755 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4762 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4763 if (object_on_left) {
4764 goto sm_any_array; /* Treat objects like scalars */
4766 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4767 AV * const other_av = MUTABLE_AV(SvRV(e));
4768 const SSize_t other_len = av_tindex(other_av) + 1;
4771 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4772 for (i = 0; i < other_len; ++i) {
4773 SV ** const svp = av_fetch(other_av, i, FALSE);
4775 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4776 if (svp) { /* ??? When can this not happen? */
4777 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4783 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4784 AV *other_av = MUTABLE_AV(SvRV(d));
4785 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4786 if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4790 const SSize_t other_len = av_tindex(other_av);
4792 if (NULL == seen_this) {
4793 seen_this = newHV();
4794 (void) sv_2mortal(MUTABLE_SV(seen_this));
4796 if (NULL == seen_other) {
4797 seen_other = newHV();
4798 (void) sv_2mortal(MUTABLE_SV(seen_other));
4800 for(i = 0; i <= other_len; ++i) {
4801 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4802 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4804 if (!this_elem || !other_elem) {
4805 if ((this_elem && SvOK(*this_elem))
4806 || (other_elem && SvOK(*other_elem)))
4809 else if (hv_exists_ent(seen_this,
4810 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4811 hv_exists_ent(seen_other,
4812 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4814 if (*this_elem != *other_elem)
4818 (void)hv_store_ent(seen_this,
4819 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4821 (void)hv_store_ent(seen_other,
4822 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4828 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4829 (void) do_smartmatch(seen_this, seen_other, 0);
4831 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4840 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4841 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4844 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4845 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4848 for(i = 0; i <= this_len; ++i) {
4849 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4850 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4851 if (svp && matcher_matches_sv(matcher, *svp)) {
4852 destroy_matcher(matcher);
4856 destroy_matcher(matcher);
4860 else if (!SvOK(d)) {
4861 /* undef ~~ array */
4862 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4865 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4866 for (i = 0; i <= this_len; ++i) {
4867 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4868 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4869 if (!svp || !SvOK(*svp))
4878 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4880 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4881 for (i = 0; i <= this_len; ++i) {
4882 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4889 /* infinite recursion isn't supposed to happen here */
4890 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4891 (void) do_smartmatch(NULL, NULL, 1);
4893 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4902 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4903 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4904 SV *t = d; d = e; e = t;
4905 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4908 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4909 SV *t = d; d = e; e = t;
4910 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4911 goto sm_regex_array;
4914 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4916 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4918 PUSHs(matcher_matches_sv(matcher, d)
4921 destroy_matcher(matcher);
4926 /* See if there is overload magic on left */
4927 else if (object_on_left && SvAMAGIC(d)) {
4929 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4930 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4933 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4941 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4944 else if (!SvOK(d)) {
4945 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4946 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4951 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4952 DEBUG_M(if (SvNIOK(e))
4953 Perl_deb(aTHX_ " applying rule Any-Num\n");
4955 Perl_deb(aTHX_ " applying rule Num-numish\n");
4957 /* numeric comparison */
4960 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4961 (void) Perl_pp_i_eq(aTHX);
4963 (void) Perl_pp_eq(aTHX);
4971 /* As a last resort, use string comparison */
4972 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4975 return Perl_pp_seq(aTHX);
4982 const I32 gimme = GIMME_V;
4984 /* This is essentially an optimization: if the match
4985 fails, we don't want to push a context and then
4986 pop it again right away, so we skip straight
4987 to the op that follows the leavewhen.
4988 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4990 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4991 RETURNOP(cLOGOP->op_other->op_next);
4993 ENTER_with_name("when");
4996 PUSHBLOCK(cx, CXt_WHEN, SP);
5011 cxix = dopoptogiven(cxstack_ix);
5013 /* diag_listed_as: Can't "when" outside a topicalizer */
5014 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5015 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5018 assert(CxTYPE(cx) == CXt_WHEN);
5021 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
5022 SVs_PADTMP|SVs_TEMP, FALSE);
5023 PL_curpm = newpm; /* pop $1 et al */
5025 LEAVE_with_name("when");
5027 if (cxix < cxstack_ix)
5030 cx = &cxstack[cxix];
5032 if (CxFOREACH(cx)) {
5033 /* clear off anything above the scope we're re-entering */
5034 I32 inner = PL_scopestack_ix;
5037 if (PL_scopestack_ix < inner)
5038 leave_scope(PL_scopestack[PL_scopestack_ix]);
5039 PL_curcop = cx->blk_oldcop;
5042 return cx->blk_loop.my_op->op_nextop;
5046 RETURNOP(cx->blk_givwhen.leave_op);
5059 PERL_UNUSED_VAR(gimme);
5061 cxix = dopoptowhen(cxstack_ix);
5063 DIE(aTHX_ "Can't \"continue\" outside a when block");
5065 if (cxix < cxstack_ix)
5069 assert(CxTYPE(cx) == CXt_WHEN);
5072 PL_curpm = newpm; /* pop $1 et al */
5074 LEAVE_with_name("when");
5075 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5083 cxix = dopoptogiven(cxstack_ix);
5085 DIE(aTHX_ "Can't \"break\" outside a given block");
5087 cx = &cxstack[cxix];
5089 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5091 if (cxix < cxstack_ix)
5094 /* Restore the sp at the time we entered the given block */
5097 return cx->blk_givwhen.leave_op;
5101 S_doparseform(pTHX_ SV *sv)
5104 char *s = SvPV(sv, len);
5106 char *base = NULL; /* start of current field */
5107 I32 skipspaces = 0; /* number of contiguous spaces seen */
5108 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5109 bool repeat = FALSE; /* ~~ seen on this line */
5110 bool postspace = FALSE; /* a text field may need right padding */
5113 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5115 bool ischop; /* it's a ^ rather than a @ */
5116 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5117 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5121 PERL_ARGS_ASSERT_DOPARSEFORM;
5124 Perl_croak(aTHX_ "Null picture in formline");
5126 if (SvTYPE(sv) >= SVt_PVMG) {
5127 /* This might, of course, still return NULL. */
5128 mg = mg_find(sv, PERL_MAGIC_fm);
5130 sv_upgrade(sv, SVt_PVMG);
5134 /* still the same as previously-compiled string? */
5135 SV *old = mg->mg_obj;
5136 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5137 && len == SvCUR(old)
5138 && strnEQ(SvPVX(old), SvPVX(sv), len)
5140 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5144 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5145 Safefree(mg->mg_ptr);
5151 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5152 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5155 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5156 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5160 /* estimate the buffer size needed */
5161 for (base = s; s <= send; s++) {
5162 if (*s == '\n' || *s == '@' || *s == '^')
5168 Newx(fops, maxops, U32);
5173 *fpc++ = FF_LINEMARK;
5174 noblank = repeat = FALSE;
5192 case ' ': case '\t':
5199 } /* else FALL THROUGH */
5207 *fpc++ = FF_LITERAL;
5215 *fpc++ = (U32)skipspaces;
5219 *fpc++ = FF_NEWLINE;
5223 arg = fpc - linepc + 1;
5230 *fpc++ = FF_LINEMARK;
5231 noblank = repeat = FALSE;
5240 ischop = s[-1] == '^';
5246 arg = (s - base) - 1;
5248 *fpc++ = FF_LITERAL;
5254 if (*s == '*') { /* @* or ^* */
5256 *fpc++ = 2; /* skip the @* or ^* */
5258 *fpc++ = FF_LINESNGL;
5261 *fpc++ = FF_LINEGLOB;
5263 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5264 arg = ischop ? FORM_NUM_BLANK : 0;
5269 const char * const f = ++s;
5272 arg |= FORM_NUM_POINT + (s - f);
5274 *fpc++ = s - base; /* fieldsize for FETCH */
5275 *fpc++ = FF_DECIMAL;
5277 unchopnum |= ! ischop;
5279 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5280 arg = ischop ? FORM_NUM_BLANK : 0;
5282 s++; /* skip the '0' first */
5286 const char * const f = ++s;
5289 arg |= FORM_NUM_POINT + (s - f);
5291 *fpc++ = s - base; /* fieldsize for FETCH */
5292 *fpc++ = FF_0DECIMAL;
5294 unchopnum |= ! ischop;
5296 else { /* text field */
5298 bool ismore = FALSE;
5301 while (*++s == '>') ;
5302 prespace = FF_SPACE;
5304 else if (*s == '|') {
5305 while (*++s == '|') ;
5306 prespace = FF_HALFSPACE;
5311 while (*++s == '<') ;
5314 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5318 *fpc++ = s - base; /* fieldsize for FETCH */
5320 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5323 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5337 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5340 mg->mg_ptr = (char *) fops;
5341 mg->mg_len = arg * sizeof(U32);
5342 mg->mg_obj = sv_copy;
5343 mg->mg_flags |= MGf_REFCOUNTED;
5345 if (unchopnum && repeat)
5346 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5353 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5355 /* Can value be printed in fldsize chars, using %*.*f ? */
5359 int intsize = fldsize - (value < 0 ? 1 : 0);
5361 if (frcsize & FORM_NUM_POINT)
5363 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5366 while (intsize--) pwr *= 10.0;
5367 while (frcsize--) eps /= 10.0;
5370 if (value + eps >= pwr)
5373 if (value - eps <= -pwr)
5380 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5382 SV * const datasv = FILTER_DATA(idx);
5383 const int filter_has_file = IoLINES(datasv);
5384 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5385 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5390 char *prune_from = NULL;
5391 bool read_from_cache = FALSE;
5395 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5397 assert(maxlen >= 0);
5400 /* I was having segfault trouble under Linux 2.2.5 after a
5401 parse error occured. (Had to hack around it with a test
5402 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5403 not sure where the trouble is yet. XXX */
5406 SV *const cache = datasv;
5409 const char *cache_p = SvPV(cache, cache_len);
5413 /* Running in block mode and we have some cached data already.
5415 if (cache_len >= umaxlen) {
5416 /* In fact, so much data we don't even need to call
5421 const char *const first_nl =
5422 (const char *)memchr(cache_p, '\n', cache_len);
5424 take = first_nl + 1 - cache_p;
5428 sv_catpvn(buf_sv, cache_p, take);
5429 sv_chop(cache, cache_p + take);
5430 /* Definitely not EOF */
5434 sv_catsv(buf_sv, cache);
5436 umaxlen -= cache_len;
5439 read_from_cache = TRUE;
5443 /* Filter API says that the filter appends to the contents of the buffer.
5444 Usually the buffer is "", so the details don't matter. But if it's not,
5445 then clearly what it contains is already filtered by this filter, so we
5446 don't want to pass it in a second time.
5447 I'm going to use a mortal in case the upstream filter croaks. */
5448 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5449 ? sv_newmortal() : buf_sv;
5450 SvUPGRADE(upstream, SVt_PV);
5452 if (filter_has_file) {
5453 status = FILTER_READ(idx+1, upstream, 0);
5456 if (filter_sub && status >= 0) {
5460 ENTER_with_name("call_filter_sub");
5465 DEFSV_set(upstream);
5469 PUSHs(filter_state);
5472 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5482 SV * const errsv = ERRSV;
5483 if (SvTRUE_NN(errsv))
5484 err = newSVsv(errsv);
5490 LEAVE_with_name("call_filter_sub");
5493 if (SvGMAGICAL(upstream)) {
5495 if (upstream == buf_sv) mg_free(buf_sv);
5497 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5498 if(!err && SvOK(upstream)) {
5499 got_p = SvPV_nomg(upstream, got_len);
5501 if (got_len > umaxlen) {
5502 prune_from = got_p + umaxlen;
5505 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5506 if (first_nl && first_nl + 1 < got_p + got_len) {
5507 /* There's a second line here... */
5508 prune_from = first_nl + 1;
5512 if (!err && prune_from) {
5513 /* Oh. Too long. Stuff some in our cache. */
5514 STRLEN cached_len = got_p + got_len - prune_from;
5515 SV *const cache = datasv;
5518 /* Cache should be empty. */
5519 assert(!SvCUR(cache));
5522 sv_setpvn(cache, prune_from, cached_len);
5523 /* If you ask for block mode, you may well split UTF-8 characters.
5524 "If it breaks, you get to keep both parts"
5525 (Your code is broken if you don't put them back together again
5526 before something notices.) */
5527 if (SvUTF8(upstream)) {
5530 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5532 /* Cannot just use sv_setpvn, as that could free the buffer
5533 before we have a chance to assign it. */
5534 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5535 got_len - cached_len);
5537 /* Can't yet be EOF */
5542 /* If they are at EOF but buf_sv has something in it, then they may never
5543 have touched the SV upstream, so it may be undefined. If we naively
5544 concatenate it then we get a warning about use of uninitialised value.
5546 if (!err && upstream != buf_sv &&
5548 sv_catsv_nomg(buf_sv, upstream);
5550 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5553 IoLINES(datasv) = 0;
5555 SvREFCNT_dec(filter_state);
5556 IoTOP_GV(datasv) = NULL;
5559 SvREFCNT_dec(filter_sub);
5560 IoBOTTOM_GV(datasv) = NULL;
5562 filter_del(S_run_user_filter);
5568 if (status == 0 && read_from_cache) {
5569 /* If we read some data from the cache (and by getting here it implies
5570 that we emptied the cache) then we aren't yet at EOF, and mustn't
5571 report that to our caller. */
5579 * c-indentation-style: bsd
5581 * indent-tabs-mode: nil
5584 * ex: set ts=8 sts=4 sw=4 et: