3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
37 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
39 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
45 const PERL_CONTEXT *cx;
48 if (PL_op->op_private & OPpOFFBYONE) {
49 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
52 cxix = dopoptosub(cxstack_ix);
58 switch (cx->blk_gimme) {
77 PMOP *pm = (PMOP*)cLOGOP->op_other;
82 const regexp_engine *eng;
83 bool is_bare_re= FALSE;
85 if (PL_op->op_flags & OPf_STACKED) {
95 /* prevent recompiling under /o and ithreads. */
96 #if defined(USE_ITHREADS)
97 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
104 assert (re != (REGEXP*) &PL_sv_undef);
105 eng = re ? RX_ENGINE(re) : current_re_engine();
108 In the below logic: these are basically the same - check if this regcomp is part of a split.
110 (PL_op->op_pmflags & PMf_split )
111 (PL_op->op_next->op_type == OP_PUSHRE)
113 We could add a new mask for this and copy the PMf_split, if we did
114 some bit definition fiddling first.
116 For now we leave this
119 new_re = (eng->op_comp
121 : &Perl_re_op_compile
122 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
124 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
126 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
128 if (pm->op_pmflags & PMf_HAS_CV)
129 ReANY(new_re)->qr_anoncv
130 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
134 /* The match's LHS's get-magic might need to access this op's regexp
135 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
136 get-magic now before we replace the regexp. Hopefully this hack can
137 be replaced with the approach described at
138 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
140 if (pm->op_type == OP_MATCH) {
142 const bool was_tainted = TAINT_get;
143 if (pm->op_flags & OPf_STACKED)
145 else if (pm->op_targ)
146 lhs = PAD_SV(pm->op_targ);
149 /* Restore the previous value of PL_tainted (which may have been
150 modified by get-magic), to avoid incorrectly setting the
151 RXf_TAINTED flag with RX_TAINT_on further down. */
152 TAINT_set(was_tainted);
153 #ifdef NO_TAINT_SUPPORT
154 PERL_UNUSED_VAR(was_tainted);
157 tmp = reg_temp_copy(NULL, new_re);
158 ReREFCNT_dec(new_re);
164 PM_SETRE(pm, new_re);
168 if (TAINTING_get && TAINT_get) {
169 SvTAINTED_on((SV*)new_re);
173 #if !defined(USE_ITHREADS)
174 /* can't change the optree at runtime either */
175 /* PMf_KEEP is handled differently under threads to avoid these problems */
176 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
178 if (pm->op_pmflags & PMf_KEEP) {
179 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
180 cLOGOP->op_first->op_next = PL_op->op_next;
192 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
193 PMOP * const pm = (PMOP*) cLOGOP->op_other;
194 SV * const dstr = cx->sb_dstr;
197 char *orig = cx->sb_orig;
198 REGEXP * const rx = cx->sb_rx;
200 REGEXP *old = PM_GETRE(pm);
207 PM_SETRE(pm,ReREFCNT_inc(rx));
210 rxres_restore(&cx->sb_rxres, rx);
212 if (cx->sb_iters++) {
213 const SSize_t saviters = cx->sb_iters;
214 if (cx->sb_iters > cx->sb_maxiters)
215 DIE(aTHX_ "Substitution loop");
217 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
219 /* See "how taint works" above pp_subst() */
221 cx->sb_rxtainted |= SUBST_TAINT_REPL;
222 sv_catsv_nomg(dstr, POPs);
223 if (CxONCE(cx) || s < orig ||
224 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
225 (s == m), cx->sb_targ, NULL,
226 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
228 SV *targ = cx->sb_targ;
230 assert(cx->sb_strend >= s);
231 if(cx->sb_strend > s) {
232 if (DO_UTF8(dstr) && !SvUTF8(targ))
233 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
235 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
237 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
238 cx->sb_rxtainted |= SUBST_TAINT_PAT;
240 if (pm->op_pmflags & PMf_NONDESTRUCT) {
242 /* From here on down we're using the copy, and leaving the
243 original untouched. */
247 SV_CHECK_THINKFIRST_COW_DROP(targ);
248 if (isGV(targ)) Perl_croak_no_modify();
250 SvPV_set(targ, SvPVX(dstr));
251 SvCUR_set(targ, SvCUR(dstr));
252 SvLEN_set(targ, SvLEN(dstr));
255 SvPV_set(dstr, NULL);
258 mPUSHi(saviters - 1);
260 (void)SvPOK_only_UTF8(targ);
263 /* update the taint state of various various variables in
264 * preparation for final exit.
265 * See "how taint works" above pp_subst() */
267 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
268 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
269 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
271 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
273 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
274 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
276 SvTAINTED_on(TOPs); /* taint return value */
277 /* needed for mg_set below */
279 cBOOL(cx->sb_rxtainted &
280 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
284 /* PL_tainted must be correctly set for this mg_set */
287 LEAVE_SCOPE(cx->sb_oldsave);
290 RETURNOP(pm->op_next);
291 NOT_REACHED; /* NOTREACHED */
293 cx->sb_iters = saviters;
295 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
298 assert(!RX_SUBOFFSET(rx));
299 cx->sb_orig = orig = RX_SUBBEG(rx);
301 cx->sb_strend = s + (cx->sb_strend - m);
303 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
305 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
306 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
308 sv_catpvn_nomg(dstr, s, m-s);
310 cx->sb_s = RX_OFFS(rx)[0].end + orig;
311 { /* Update the pos() information. */
313 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
316 /* the string being matched against may no longer be a string,
317 * e.g. $_=0; s/.../$_++/ge */
320 SvPV_force_nomg_nolen(sv);
322 if (!(mg = mg_find_mglob(sv))) {
323 mg = sv_magicext_mglob(sv);
325 MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
328 (void)ReREFCNT_inc(rx);
329 /* update the taint state of various various variables in preparation
330 * for calling the code block.
331 * See "how taint works" above pp_subst() */
333 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
334 cx->sb_rxtainted |= SUBST_TAINT_PAT;
336 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
337 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
338 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
340 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
342 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
343 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
344 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
345 ? cx->sb_dstr : cx->sb_targ);
348 rxres_save(&cx->sb_rxres, rx);
350 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
354 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
359 PERL_ARGS_ASSERT_RXRES_SAVE;
362 if (!p || p[1] < RX_NPARENS(rx)) {
364 i = 7 + (RX_NPARENS(rx)+1) * 2;
366 i = 6 + (RX_NPARENS(rx)+1) * 2;
375 /* what (if anything) to free on croak */
376 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
377 RX_MATCH_COPIED_off(rx);
378 *p++ = RX_NPARENS(rx);
381 *p++ = PTR2UV(RX_SAVED_COPY(rx));
382 RX_SAVED_COPY(rx) = NULL;
385 *p++ = PTR2UV(RX_SUBBEG(rx));
386 *p++ = (UV)RX_SUBLEN(rx);
387 *p++ = (UV)RX_SUBOFFSET(rx);
388 *p++ = (UV)RX_SUBCOFFSET(rx);
389 for (i = 0; i <= RX_NPARENS(rx); ++i) {
390 *p++ = (UV)RX_OFFS(rx)[i].start;
391 *p++ = (UV)RX_OFFS(rx)[i].end;
396 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
401 PERL_ARGS_ASSERT_RXRES_RESTORE;
404 RX_MATCH_COPY_FREE(rx);
405 RX_MATCH_COPIED_set(rx, *p);
407 RX_NPARENS(rx) = *p++;
410 if (RX_SAVED_COPY(rx))
411 SvREFCNT_dec (RX_SAVED_COPY(rx));
412 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
416 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
417 RX_SUBLEN(rx) = (I32)(*p++);
418 RX_SUBOFFSET(rx) = (I32)*p++;
419 RX_SUBCOFFSET(rx) = (I32)*p++;
420 for (i = 0; i <= RX_NPARENS(rx); ++i) {
421 RX_OFFS(rx)[i].start = (I32)(*p++);
422 RX_OFFS(rx)[i].end = (I32)(*p++);
427 S_rxres_free(pTHX_ void **rsp)
429 UV * const p = (UV*)*rsp;
431 PERL_ARGS_ASSERT_RXRES_FREE;
435 void *tmp = INT2PTR(char*,*p);
438 U32 i = 9 + p[1] * 2;
440 U32 i = 8 + p[1] * 2;
445 SvREFCNT_dec (INT2PTR(SV*,p[2]));
448 PoisonFree(p, i, sizeof(UV));
457 #define FORM_NUM_BLANK (1<<30)
458 #define FORM_NUM_POINT (1<<29)
462 dSP; dMARK; dORIGMARK;
463 SV * const tmpForm = *++MARK;
464 SV *formsv; /* contains text of original format */
465 U32 *fpc; /* format ops program counter */
466 char *t; /* current append position in target string */
467 const char *f; /* current position in format string */
469 SV *sv = NULL; /* current item */
470 const char *item = NULL;/* string value of current item */
471 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
472 I32 itembytes = 0; /* as itemsize, but length in bytes */
473 I32 fieldsize = 0; /* width of current field */
474 I32 lines = 0; /* number of lines that have been output */
475 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
476 const char *chophere = NULL; /* where to chop current item */
477 STRLEN linemark = 0; /* pos of start of line in output */
479 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
480 STRLEN len; /* length of current sv */
481 STRLEN linemax; /* estimate of output size in bytes */
482 bool item_is_utf8 = FALSE;
483 bool targ_is_utf8 = FALSE;
486 U8 *source; /* source of bytes to append */
487 STRLEN to_copy; /* how may bytes to append */
488 char trans; /* what chars to translate */
490 mg = doparseform(tmpForm);
492 fpc = (U32*)mg->mg_ptr;
493 /* the actual string the format was compiled from.
494 * with overload etc, this may not match tmpForm */
498 SvPV_force(PL_formtarget, len);
499 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
500 SvTAINTED_on(PL_formtarget);
501 if (DO_UTF8(PL_formtarget))
503 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
504 t = SvGROW(PL_formtarget, len + linemax + 1);
505 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
507 f = SvPV_const(formsv, len);
511 const char *name = "???";
514 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
515 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
516 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
517 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
518 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
520 case FF_CHECKNL: name = "CHECKNL"; break;
521 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
522 case FF_SPACE: name = "SPACE"; break;
523 case FF_HALFSPACE: name = "HALFSPACE"; break;
524 case FF_ITEM: name = "ITEM"; break;
525 case FF_CHOP: name = "CHOP"; break;
526 case FF_LINEGLOB: name = "LINEGLOB"; break;
527 case FF_NEWLINE: name = "NEWLINE"; break;
528 case FF_MORE: name = "MORE"; break;
529 case FF_LINEMARK: name = "LINEMARK"; break;
530 case FF_END: name = "END"; break;
531 case FF_0DECIMAL: name = "0DECIMAL"; break;
532 case FF_LINESNGL: name = "LINESNGL"; break;
535 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
537 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
540 case FF_LINEMARK: /* start (or end) of a line */
541 linemark = t - SvPVX(PL_formtarget);
546 case FF_LITERAL: /* append <arg> literal chars */
551 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
554 case FF_SKIP: /* skip <arg> chars in format */
558 case FF_FETCH: /* get next item and set field size to <arg> */
567 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
570 SvTAINTED_on(PL_formtarget);
573 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
575 const char *s = item = SvPV_const(sv, len);
576 const char *send = s + len;
579 item_is_utf8 = DO_UTF8(sv);
591 if (itemsize == fieldsize)
594 itembytes = s - item;
599 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
601 const char *s = item = SvPV_const(sv, len);
602 const char *send = s + len;
606 item_is_utf8 = DO_UTF8(sv);
608 /* look for a legal split position */
616 /* provisional split point */
620 /* we delay testing fieldsize until after we've
621 * processed the possible split char directly
622 * following the last field char; so if fieldsize=3
623 * and item="a b cdef", we consume "a b", not "a".
624 * Ditto further down.
626 if (size == fieldsize)
630 if (strchr(PL_chopset, *s)) {
631 /* provisional split point */
632 /* for a non-space split char, we include
633 * the split char; hence the '+1' */
637 if (size == fieldsize)
649 if (!chophere || s == send) {
653 itembytes = chophere - item;
658 case FF_SPACE: /* append padding space (diff of field, item size) */
659 arg = fieldsize - itemsize;
667 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
668 arg = fieldsize - itemsize;
677 case FF_ITEM: /* append a text item, while blanking ctrl chars */
683 case FF_CHOP: /* (for ^*) chop the current item */
684 if (sv != &PL_sv_no) {
685 const char *s = chophere;
693 /* tied, overloaded or similar strangeness.
694 * Do it the hard way */
695 sv_setpvn(sv, s, len - (s-item));
700 case FF_LINESNGL: /* process ^* */
704 case FF_LINEGLOB: /* process @* */
706 const bool oneline = fpc[-1] == FF_LINESNGL;
707 const char *s = item = SvPV_const(sv, len);
708 const char *const send = s + len;
710 item_is_utf8 = DO_UTF8(sv);
721 to_copy = s - item - 1;
735 /* append to_copy bytes from source to PL_formstring.
736 * item_is_utf8 implies source is utf8.
737 * if trans, translate certain characters during the copy */
742 SvCUR_set(PL_formtarget,
743 t - SvPVX_const(PL_formtarget));
745 if (targ_is_utf8 && !item_is_utf8) {
746 source = tmp = bytes_to_utf8(source, &to_copy);
748 if (item_is_utf8 && !targ_is_utf8) {
750 /* Upgrade targ to UTF8, and then we reduce it to
751 a problem we have a simple solution for.
752 Don't need get magic. */
753 sv_utf8_upgrade_nomg(PL_formtarget);
755 /* re-calculate linemark */
756 s = (U8*)SvPVX(PL_formtarget);
757 /* the bytes we initially allocated to append the
758 * whole line may have been gobbled up during the
759 * upgrade, so allocate a whole new line's worth
764 linemark = s - (U8*)SvPVX(PL_formtarget);
766 /* Easy. They agree. */
767 assert (item_is_utf8 == targ_is_utf8);
770 /* @* and ^* are the only things that can exceed
771 * the linemax, so grow by the output size, plus
772 * a whole new form's worth in case of any further
774 grow = linemax + to_copy;
776 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
777 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
779 Copy(source, t, to_copy, char);
781 /* blank out ~ or control chars, depending on trans.
782 * works on bytes not chars, so relies on not
783 * matching utf8 continuation bytes */
785 U8 *send = s + to_copy;
788 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
795 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
801 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
804 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
807 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
810 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
812 /* If the field is marked with ^ and the value is undefined,
814 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
822 /* overflow evidence */
823 if (num_overflow(value, fieldsize, arg)) {
829 /* Formats aren't yet marked for locales, so assume "yes". */
831 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
833 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
834 STORE_LC_NUMERIC_SET_TO_NEEDED();
835 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
838 const char* qfmt = quadmath_format_single(fmt);
841 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
842 len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
844 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
849 /* we generate fmt ourselves so it is safe */
850 GCC_DIAG_IGNORE(-Wformat-nonliteral);
851 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
854 PERL_MY_SNPRINTF_POST_GUARD(len, max);
855 RESTORE_LC_NUMERIC();
860 case FF_NEWLINE: /* delete trailing spaces, then append \n */
862 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
867 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
870 if (arg) { /* repeat until fields exhausted? */
876 t = SvPVX(PL_formtarget) + linemark;
881 case FF_MORE: /* replace long end of string with '...' */
883 const char *s = chophere;
884 const char *send = item + len;
886 while (isSPACE(*s) && (s < send))
891 arg = fieldsize - itemsize;
898 if (strnEQ(s1," ",3)) {
899 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
909 case FF_END: /* tidy up, then return */
911 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
913 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
915 SvUTF8_on(PL_formtarget);
916 FmLINES(PL_formtarget) += lines;
918 if (fpc[-1] == FF_BLANK)
919 RETURNOP(cLISTOP->op_first);
931 if (PL_stack_base + *PL_markstack_ptr == SP) {
933 if (GIMME_V == G_SCALAR)
935 RETURNOP(PL_op->op_next->op_next);
937 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
938 Perl_pp_pushmark(aTHX); /* push dst */
939 Perl_pp_pushmark(aTHX); /* push src */
940 ENTER_with_name("grep"); /* enter outer scope */
943 if (PL_op->op_private & OPpGREP_LEX)
944 SAVESPTR(PAD_SVl(PL_op->op_targ));
947 ENTER_with_name("grep_item"); /* enter inner scope */
950 src = PL_stack_base[*PL_markstack_ptr];
952 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
956 if (PL_op->op_private & OPpGREP_LEX)
957 PAD_SVl(PL_op->op_targ) = src;
962 if (PL_op->op_type == OP_MAPSTART)
963 Perl_pp_pushmark(aTHX); /* push top */
964 return ((LOGOP*)PL_op->op_next)->op_other;
970 const I32 gimme = GIMME_V;
971 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
977 /* first, move source pointer to the next item in the source list */
978 ++PL_markstack_ptr[-1];
980 /* if there are new items, push them into the destination list */
981 if (items && gimme != G_VOID) {
982 /* might need to make room back there first */
983 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
984 /* XXX this implementation is very pessimal because the stack
985 * is repeatedly extended for every set of items. Is possible
986 * to do this without any stack extension or copying at all
987 * by maintaining a separate list over which the map iterates
988 * (like foreach does). --gsar */
990 /* everything in the stack after the destination list moves
991 * towards the end the stack by the amount of room needed */
992 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
994 /* items to shift up (accounting for the moved source pointer) */
995 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
997 /* This optimization is by Ben Tilly and it does
998 * things differently from what Sarathy (gsar)
999 * is describing. The downside of this optimization is
1000 * that leaves "holes" (uninitialized and hopefully unused areas)
1001 * to the Perl stack, but on the other hand this
1002 * shouldn't be a problem. If Sarathy's idea gets
1003 * implemented, this optimization should become
1004 * irrelevant. --jhi */
1006 shift = count; /* Avoid shifting too often --Ben Tilly */
1010 dst = (SP += shift);
1011 PL_markstack_ptr[-1] += shift;
1012 *PL_markstack_ptr += shift;
1016 /* copy the new items down to the destination list */
1017 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1018 if (gimme == G_ARRAY) {
1019 /* add returned items to the collection (making mortal copies
1020 * if necessary), then clear the current temps stack frame
1021 * *except* for those items. We do this splicing the items
1022 * into the start of the tmps frame (so some items may be on
1023 * the tmps stack twice), then moving PL_tmps_floor above
1024 * them, then freeing the frame. That way, the only tmps that
1025 * accumulate over iterations are the return values for map.
1026 * We have to do to this way so that everything gets correctly
1027 * freed if we die during the map.
1031 /* make space for the slice */
1032 EXTEND_MORTAL(items);
1033 tmpsbase = PL_tmps_floor + 1;
1034 Move(PL_tmps_stack + tmpsbase,
1035 PL_tmps_stack + tmpsbase + items,
1036 PL_tmps_ix - PL_tmps_floor,
1038 PL_tmps_ix += items;
1043 sv = sv_mortalcopy(sv);
1045 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1047 /* clear the stack frame except for the items */
1048 PL_tmps_floor += items;
1050 /* FREETMPS may have cleared the TEMP flag on some of the items */
1053 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1056 /* scalar context: we don't care about which values map returns
1057 * (we use undef here). And so we certainly don't want to do mortal
1058 * copies of meaningless values. */
1059 while (items-- > 0) {
1061 *dst-- = &PL_sv_undef;
1069 LEAVE_with_name("grep_item"); /* exit inner scope */
1072 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1074 (void)POPMARK; /* pop top */
1075 LEAVE_with_name("grep"); /* exit outer scope */
1076 (void)POPMARK; /* pop src */
1077 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1078 (void)POPMARK; /* pop dst */
1079 SP = PL_stack_base + POPMARK; /* pop original mark */
1080 if (gimme == G_SCALAR) {
1081 if (PL_op->op_private & OPpGREP_LEX) {
1082 SV* sv = sv_newmortal();
1083 sv_setiv(sv, items);
1091 else if (gimme == G_ARRAY)
1098 ENTER_with_name("grep_item"); /* enter inner scope */
1101 /* set $_ to the new source item */
1102 src = PL_stack_base[PL_markstack_ptr[-1]];
1103 if (SvPADTMP(src)) {
1104 src = sv_mortalcopy(src);
1107 if (PL_op->op_private & OPpGREP_LEX)
1108 PAD_SVl(PL_op->op_targ) = src;
1112 RETURNOP(cLOGOP->op_other);
1120 if (GIMME_V == G_ARRAY)
1122 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1123 return cLOGOP->op_other;
1132 if (GIMME_V == G_ARRAY) {
1133 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1137 SV * const targ = PAD_SV(PL_op->op_targ);
1140 if (PL_op->op_private & OPpFLIP_LINENUM) {
1141 if (GvIO(PL_last_in_gv)) {
1142 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1145 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1147 flip = SvIV(sv) == SvIV(GvSV(gv));
1153 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1154 if (PL_op->op_flags & OPf_SPECIAL) {
1162 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1165 sv_setpvs(TARG, "");
1171 /* This code tries to decide if "$left .. $right" should use the
1172 magical string increment, or if the range is numeric (we make
1173 an exception for .."0" [#18165]). AMS 20021031. */
1175 #define RANGE_IS_NUMERIC(left,right) ( \
1176 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1177 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1178 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1179 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1180 && (!SvOK(right) || looks_like_number(right))))
1186 if (GIMME_V == G_ARRAY) {
1192 if (RANGE_IS_NUMERIC(left,right)) {
1194 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1195 (SvOK(right) && (SvIOK(right)
1196 ? SvIsUV(right) && SvUV(right) > IV_MAX
1197 : SvNV_nomg(right) > IV_MAX)))
1198 DIE(aTHX_ "Range iterator outside integer range");
1199 i = SvIV_nomg(left);
1200 j = SvIV_nomg(right);
1202 /* Dance carefully around signed max. */
1203 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1206 /* The wraparound of signed integers is undefined
1207 * behavior, but here we aim for count >=1, and
1208 * negative count is just wrong. */
1213 Perl_croak(aTHX_ "Out of memory during list extend");
1220 SV * const sv = sv_2mortal(newSViv(i));
1222 if (n) /* avoid incrementing above IV_MAX */
1228 const char * const lpv = SvPV_nomg_const(left, llen);
1229 const char * const tmps = SvPV_nomg_const(right, len);
1231 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1232 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1234 if (strEQ(SvPVX_const(sv),tmps))
1236 sv = sv_2mortal(newSVsv(sv));
1243 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1247 if (PL_op->op_private & OPpFLIP_LINENUM) {
1248 if (GvIO(PL_last_in_gv)) {
1249 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1252 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1253 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1261 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1262 sv_catpvs(targ, "E0");
1272 static const char * const context_name[] = {
1274 NULL, /* CXt_WHEN never actually needs "block" */
1275 NULL, /* CXt_BLOCK never actually needs "block" */
1276 NULL, /* CXt_GIVEN never actually needs "block" */
1277 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1278 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1279 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1280 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1288 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1292 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1294 for (i = cxstack_ix; i >= 0; i--) {
1295 const PERL_CONTEXT * const cx = &cxstack[i];
1296 switch (CxTYPE(cx)) {
1302 /* diag_listed_as: Exiting subroutine via %s */
1303 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1304 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1305 if (CxTYPE(cx) == CXt_NULL)
1308 case CXt_LOOP_LAZYIV:
1309 case CXt_LOOP_LAZYSV:
1311 case CXt_LOOP_PLAIN:
1313 STRLEN cx_label_len = 0;
1314 U32 cx_label_flags = 0;
1315 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1317 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1320 (const U8*)cx_label, cx_label_len,
1321 (const U8*)label, len) == 0)
1323 (const U8*)label, len,
1324 (const U8*)cx_label, cx_label_len) == 0)
1325 : (len == cx_label_len && ((cx_label == label)
1326 || memEQ(cx_label, label, len))) )) {
1327 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1328 (long)i, cx_label));
1331 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1342 Perl_dowantarray(pTHX)
1344 const I32 gimme = block_gimme();
1345 return (gimme == G_VOID) ? G_SCALAR : gimme;
1349 Perl_block_gimme(pTHX)
1351 const I32 cxix = dopoptosub(cxstack_ix);
1356 gimme = (cxstack[cxix].blk_gimme & G_WANT);
1358 Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1364 Perl_is_lvalue_sub(pTHX)
1366 const I32 cxix = dopoptosub(cxstack_ix);
1367 assert(cxix >= 0); /* We should only be called from inside subs */
1369 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1370 return CxLVAL(cxstack + cxix);
1375 /* only used by PUSHSUB */
1377 Perl_was_lvalue_sub(pTHX)
1379 const I32 cxix = dopoptosub(cxstack_ix-1);
1380 assert(cxix >= 0); /* We should only be called from inside subs */
1382 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1383 return CxLVAL(cxstack + cxix);
1389 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1393 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1395 PERL_UNUSED_CONTEXT;
1398 for (i = startingblock; i >= 0; i--) {
1399 const PERL_CONTEXT * const cx = &cxstk[i];
1400 switch (CxTYPE(cx)) {
1404 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1405 * twice; the first for the normal foo() call, and the second
1406 * for a faked up re-entry into the sub to execute the
1407 * code block. Hide this faked entry from the world. */
1408 if (cx->cx_type & CXp_SUB_RE_FAKE)
1413 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1421 S_dopoptoeval(pTHX_ I32 startingblock)
1424 for (i = startingblock; i >= 0; i--) {
1425 const PERL_CONTEXT *cx = &cxstack[i];
1426 switch (CxTYPE(cx)) {
1430 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1438 S_dopoptoloop(pTHX_ I32 startingblock)
1441 for (i = startingblock; i >= 0; i--) {
1442 const PERL_CONTEXT * const cx = &cxstack[i];
1443 switch (CxTYPE(cx)) {
1449 /* diag_listed_as: Exiting subroutine via %s */
1450 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1451 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1452 if ((CxTYPE(cx)) == CXt_NULL)
1455 case CXt_LOOP_LAZYIV:
1456 case CXt_LOOP_LAZYSV:
1458 case CXt_LOOP_PLAIN:
1459 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1467 S_dopoptogiven(pTHX_ I32 startingblock)
1470 for (i = startingblock; i >= 0; i--) {
1471 const PERL_CONTEXT *cx = &cxstack[i];
1472 switch (CxTYPE(cx)) {
1476 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1478 case CXt_LOOP_PLAIN:
1479 assert(!CxFOREACHDEF(cx));
1481 case CXt_LOOP_LAZYIV:
1482 case CXt_LOOP_LAZYSV:
1484 if (CxFOREACHDEF(cx)) {
1485 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1494 S_dopoptowhen(pTHX_ I32 startingblock)
1497 for (i = startingblock; i >= 0; i--) {
1498 const PERL_CONTEXT *cx = &cxstack[i];
1499 switch (CxTYPE(cx)) {
1503 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1511 Perl_dounwind(pTHX_ I32 cxix)
1515 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1518 while (cxstack_ix > cxix) {
1520 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1521 DEBUG_CX("UNWIND"); \
1522 /* Note: we don't need to restore the base context info till the end. */
1523 switch (CxTYPE(cx)) {
1526 continue; /* not break */
1534 case CXt_LOOP_LAZYIV:
1535 case CXt_LOOP_LAZYSV:
1537 case CXt_LOOP_PLAIN:
1548 PERL_UNUSED_VAR(optype);
1552 Perl_qerror(pTHX_ SV *err)
1554 PERL_ARGS_ASSERT_QERROR;
1557 if (PL_in_eval & EVAL_KEEPERR) {
1558 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1562 sv_catsv(ERRSV, err);
1565 sv_catsv(PL_errors, err);
1567 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1569 ++PL_parser->error_count;
1573 Perl_die_unwind(pTHX_ SV *msv)
1575 SV *exceptsv = sv_mortalcopy(msv);
1576 U8 in_eval = PL_in_eval;
1577 PERL_ARGS_ASSERT_DIE_UNWIND;
1584 * Historically, perl used to set ERRSV ($@) early in the die
1585 * process and rely on it not getting clobbered during unwinding.
1586 * That sucked, because it was liable to get clobbered, so the
1587 * setting of ERRSV used to emit the exception from eval{} has
1588 * been moved to much later, after unwinding (see just before
1589 * JMPENV_JUMP below). However, some modules were relying on the
1590 * early setting, by examining $@ during unwinding to use it as
1591 * a flag indicating whether the current unwinding was caused by
1592 * an exception. It was never a reliable flag for that purpose,
1593 * being totally open to false positives even without actual
1594 * clobberage, but was useful enough for production code to
1595 * semantically rely on it.
1597 * We'd like to have a proper introspective interface that
1598 * explicitly describes the reason for whatever unwinding
1599 * operations are currently in progress, so that those modules
1600 * work reliably and $@ isn't further overloaded. But we don't
1601 * have one yet. In its absence, as a stopgap measure, ERRSV is
1602 * now *additionally* set here, before unwinding, to serve as the
1603 * (unreliable) flag that it used to.
1605 * This behaviour is temporary, and should be removed when a
1606 * proper way to detect exceptional unwinding has been developed.
1607 * As of 2010-12, the authors of modules relying on the hack
1608 * are aware of the issue, because the modules failed on
1609 * perls 5.13.{1..7} which had late setting of $@ without this
1610 * early-setting hack.
1612 if (!(in_eval & EVAL_KEEPERR)) {
1613 SvTEMP_off(exceptsv);
1614 sv_setsv(ERRSV, exceptsv);
1617 if (in_eval & EVAL_KEEPERR) {
1618 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1622 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1623 && PL_curstackinfo->si_prev)
1637 JMPENV *restartjmpenv;
1640 if (cxix < cxstack_ix)
1643 POPBLOCK(cx,PL_curpm);
1644 if (CxTYPE(cx) != CXt_EVAL) {
1646 const char* message = SvPVx_const(exceptsv, msglen);
1647 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1648 PerlIO_write(Perl_error_log, message, msglen);
1652 namesv = cx->blk_eval.old_namesv;
1654 oldcop = cx->blk_oldcop;
1656 restartjmpenv = cx->blk_eval.cur_top_env;
1657 restartop = cx->blk_eval.retop;
1659 if (gimme == G_SCALAR)
1660 *++newsp = &PL_sv_undef;
1661 PL_stack_sp = newsp;
1665 if (optype == OP_REQUIRE) {
1666 assert (PL_curcop == oldcop);
1667 (void)hv_store(GvHVn(PL_incgv),
1668 SvPVX_const(namesv),
1669 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1671 /* note that unlike pp_entereval, pp_require isn't
1672 * supposed to trap errors. So now that we've popped the
1673 * EVAL that pp_require pushed, and processed the error
1674 * message, rethrow the error */
1675 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1676 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1679 if (!(in_eval & EVAL_KEEPERR))
1680 sv_setsv(ERRSV, exceptsv);
1681 PL_restartjmpenv = restartjmpenv;
1682 PL_restartop = restartop;
1684 NOT_REACHED; /* NOTREACHED */
1688 write_to_stderr(exceptsv);
1690 NOT_REACHED; /* NOTREACHED */
1696 if (SvTRUE(left) != SvTRUE(right))
1704 =head1 CV Manipulation Functions
1706 =for apidoc caller_cx
1708 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1709 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1710 information returned to Perl by C<caller>. Note that XSUBs don't get a
1711 stack frame, so C<caller_cx(0, NULL)> will return information for the
1712 immediately-surrounding Perl code.
1714 This function skips over the automatic calls to C<&DB::sub> made on the
1715 behalf of the debugger. If the stack frame requested was a sub called by
1716 C<DB::sub>, the return value will be the frame for the call to
1717 C<DB::sub>, since that has the correct line number/etc. for the call
1718 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1719 frame for the sub call itself.
1724 const PERL_CONTEXT *
1725 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1727 I32 cxix = dopoptosub(cxstack_ix);
1728 const PERL_CONTEXT *cx;
1729 const PERL_CONTEXT *ccstack = cxstack;
1730 const PERL_SI *top_si = PL_curstackinfo;
1733 /* we may be in a higher stacklevel, so dig down deeper */
1734 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1735 top_si = top_si->si_prev;
1736 ccstack = top_si->si_cxstack;
1737 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1741 /* caller() should not report the automatic calls to &DB::sub */
1742 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1743 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1747 cxix = dopoptosub_at(ccstack, cxix - 1);
1750 cx = &ccstack[cxix];
1751 if (dbcxp) *dbcxp = cx;
1753 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1754 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1755 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1756 field below is defined for any cx. */
1757 /* caller() should not report the automatic calls to &DB::sub */
1758 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1759 cx = &ccstack[dbcxix];
1768 const PERL_CONTEXT *cx;
1769 const PERL_CONTEXT *dbcx;
1770 I32 gimme = GIMME_V;
1771 const HEK *stash_hek;
1773 bool has_arg = MAXARG && TOPs;
1782 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1784 if (gimme != G_ARRAY) {
1792 assert(CopSTASH(cx->blk_oldcop));
1793 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1794 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1796 if (gimme != G_ARRAY) {
1799 PUSHs(&PL_sv_undef);
1802 sv_sethek(TARG, stash_hek);
1811 PUSHs(&PL_sv_undef);
1814 sv_sethek(TARG, stash_hek);
1817 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1818 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1819 cx->blk_sub.retop, TRUE);
1821 lcop = cx->blk_oldcop;
1822 mPUSHi((I32)CopLINE(lcop));
1825 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1826 /* So is ccstack[dbcxix]. */
1827 if (CvHASGV(dbcx->blk_sub.cv)) {
1828 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1829 PUSHs(boolSV(CxHASARGS(cx)));
1832 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1833 PUSHs(boolSV(CxHASARGS(cx)));
1837 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1840 gimme = (I32)cx->blk_gimme;
1841 if (gimme == G_VOID)
1842 PUSHs(&PL_sv_undef);
1844 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1845 if (CxTYPE(cx) == CXt_EVAL) {
1847 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1848 SV *cur_text = cx->blk_eval.cur_text;
1849 if (SvCUR(cur_text) >= 2) {
1850 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1851 SvUTF8(cur_text)|SVs_TEMP));
1854 /* I think this is will always be "", but be sure */
1855 PUSHs(sv_2mortal(newSVsv(cur_text)));
1861 else if (cx->blk_eval.old_namesv) {
1862 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1865 /* eval BLOCK (try blocks have old_namesv == 0) */
1867 PUSHs(&PL_sv_undef);
1868 PUSHs(&PL_sv_undef);
1872 PUSHs(&PL_sv_undef);
1873 PUSHs(&PL_sv_undef);
1875 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1876 && CopSTASH_eq(PL_curcop, PL_debstash))
1878 AV * const ary = cx->blk_sub.argarray;
1879 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1881 Perl_init_dbargs(aTHX);
1883 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1884 av_extend(PL_dbargs, AvFILLp(ary) + off);
1885 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1886 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1888 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1891 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1893 if (old_warnings == pWARN_NONE)
1894 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1895 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1896 mask = &PL_sv_undef ;
1897 else if (old_warnings == pWARN_ALL ||
1898 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1899 /* Get the bit mask for $warnings::Bits{all}, because
1900 * it could have been extended by warnings::register */
1902 HV * const bits = get_hv("warnings::Bits", 0);
1903 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1904 mask = newSVsv(*bits_all);
1907 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1911 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1915 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1916 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1926 if (MAXARG < 1 || (!TOPs && !POPs))
1927 tmps = NULL, len = 0;
1929 tmps = SvPVx_const(POPs, len);
1930 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1935 /* like pp_nextstate, but used instead when the debugger is active */
1939 PL_curcop = (COP*)PL_op;
1940 TAINT_NOT; /* Each statement is presumed innocent */
1941 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1946 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1947 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
1951 const I32 gimme = G_ARRAY;
1953 GV * const gv = PL_DBgv;
1956 if (gv && isGV_with_GP(gv))
1959 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1960 DIE(aTHX_ "No DB::DB routine defined");
1962 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1963 /* don't do recursive DB::DB call */
1977 (void)(*CvXSUB(cv))(aTHX_ cv);
1983 PUSHBLOCK(cx, CXt_SUB, SP);
1985 cx->blk_sub.retop = PL_op->op_next;
1987 if (CvDEPTH(cv) >= 2) {
1988 PERL_STACK_OVERFLOW_CHECK();
1989 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1992 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1993 RETURNOP(CvSTART(cv));
2000 /* S_leave_common: Common code that many functions in this file use on
2003 /* SVs on the stack that have any of the flags passed in are left as is.
2004 Other SVs are protected via the mortals stack if lvalue is true, and
2007 Also, taintedness is cleared.
2011 S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
2012 U32 flags, bool lvalue)
2015 PERL_ARGS_ASSERT_LEAVE_COMMON;
2018 if (flags & SVs_PADTMP) {
2019 flags &= ~SVs_PADTMP;
2022 if (gimme == G_SCALAR) {
2024 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2027 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2028 : sv_mortalcopy(*SP);
2030 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2033 *++MARK = &PL_sv_undef;
2037 else if (gimme == G_ARRAY) {
2038 /* in case LEAVE wipes old return values */
2039 while (++MARK <= SP) {
2040 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2044 ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
2045 : sv_mortalcopy(*MARK);
2046 TAINT_NOT; /* Each item is independent */
2049 /* When this function was called with MARK == newsp, we reach this
2050 * point with SP == newsp. */
2060 I32 gimme = GIMME_V;
2062 ENTER_with_name("block");
2065 PUSHBLOCK(cx, CXt_BLOCK, SP);
2078 if (PL_op->op_flags & OPf_SPECIAL) {
2079 cx = &cxstack[cxstack_ix];
2080 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2085 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2087 SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
2088 PL_op->op_private & OPpLVALUE);
2089 PL_curpm = newpm; /* Don't pop $1 et al till now */
2091 LEAVE_with_name("block");
2097 S_outside_integer(pTHX_ SV *sv)
2100 const NV nv = SvNV_nomg(sv);
2101 if (Perl_isinfnan(nv))
2103 #ifdef NV_PRESERVES_UV
2104 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2107 if (nv <= (NV)IV_MIN)
2110 ((nv > (NV)UV_MAX ||
2111 SvUV_nomg(sv) > (UV)IV_MAX)))
2122 const I32 gimme = GIMME_V;
2123 void *itervar; /* location of the iteration variable */
2124 U8 cxtype = CXt_LOOP_FOR;
2126 ENTER_with_name("loop1");
2129 if (PL_op->op_targ) { /* "my" variable */
2130 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2131 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2132 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2133 SVs_PADSTALE, SVs_PADSTALE);
2135 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2137 itervar = PL_comppad;
2139 itervar = &PAD_SVl(PL_op->op_targ);
2142 else if (LIKELY(isGV(TOPs))) { /* symbol table variable */
2143 GV * const gv = MUTABLE_GV(POPs);
2144 SV** svp = &GvSV(gv);
2145 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2147 itervar = (void *)gv;
2148 save_aliased_sv(gv);
2151 SV * const sv = POPs;
2152 assert(SvTYPE(sv) == SVt_PVMG);
2153 assert(SvMAGIC(sv));
2154 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2155 itervar = (void *)sv;
2156 cxtype |= CXp_FOR_LVREF;
2159 if (PL_op->op_private & OPpITER_DEF)
2160 cxtype |= CXp_FOR_DEF;
2162 ENTER_with_name("loop2");
2164 PUSHBLOCK(cx, cxtype, SP);
2165 PUSHLOOP_FOR(cx, itervar, MARK);
2166 if (PL_op->op_flags & OPf_STACKED) {
2167 SV *maybe_ary = POPs;
2168 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2170 SV * const right = maybe_ary;
2171 if (UNLIKELY(cxtype & CXp_FOR_LVREF))
2172 DIE(aTHX_ "Assigned value is not a reference");
2175 if (RANGE_IS_NUMERIC(sv,right)) {
2176 cx->cx_type &= ~CXTYPEMASK;
2177 cx->cx_type |= CXt_LOOP_LAZYIV;
2178 /* Make sure that no-one re-orders cop.h and breaks our
2180 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2181 if (S_outside_integer(aTHX_ sv) ||
2182 S_outside_integer(aTHX_ right))
2183 DIE(aTHX_ "Range iterator outside integer range");
2184 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2185 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2187 /* for correct -Dstv display */
2188 cx->blk_oldsp = sp - PL_stack_base;
2192 cx->cx_type &= ~CXTYPEMASK;
2193 cx->cx_type |= CXt_LOOP_LAZYSV;
2194 /* Make sure that no-one re-orders cop.h and breaks our
2196 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2197 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2198 cx->blk_loop.state_u.lazysv.end = right;
2199 SvREFCNT_inc(right);
2200 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2201 /* This will do the upgrade to SVt_PV, and warn if the value
2202 is uninitialised. */
2203 (void) SvPV_nolen_const(right);
2204 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2205 to replace !SvOK() with a pointer to "". */
2207 SvREFCNT_dec(right);
2208 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2212 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2213 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2214 SvREFCNT_inc(maybe_ary);
2215 cx->blk_loop.state_u.ary.ix =
2216 (PL_op->op_private & OPpITER_REVERSED) ?
2217 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2221 else { /* iterating over items on the stack */
2222 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2223 if (PL_op->op_private & OPpITER_REVERSED) {
2224 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2227 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2238 const I32 gimme = GIMME_V;
2240 ENTER_with_name("loop1");
2242 ENTER_with_name("loop2");
2244 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2245 PUSHLOOP_PLAIN(cx, SP);
2260 assert(CxTYPE_is_LOOP(cx));
2262 newsp = PL_stack_base + cx->blk_loop.resetsp;
2264 SP = leave_common(newsp, SP, MARK, gimme, 0,
2265 PL_op->op_private & OPpLVALUE);
2268 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2269 PL_curpm = newpm; /* ... and pop $1 et al */
2271 LEAVE_with_name("loop2");
2272 LEAVE_with_name("loop1");
2278 /* This duplicates most of pp_leavesub, but with additional code to handle
2279 * return args in lvalue context. It was forked from pp_leavesub to
2280 * avoid slowing down that function any further.
2282 * Any changes made to this function may need to be copied to pp_leavesub
2296 const char *what = NULL;
2298 if (CxMULTICALL(&cxstack[cxstack_ix])) {
2299 /* entry zero of a stack is always PL_sv_undef, which
2300 * simplifies converting a '()' return into undef in scalar context */
2301 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2306 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2311 ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2312 if (gimme == G_SCALAR) {
2313 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2317 if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
2318 !SvSMAGICAL(TOPs)) {
2320 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2321 : "a readonly value" : "a temporary";
2326 /* sub:lvalue{} will take us here. */
2336 "Can't return %s from lvalue subroutine", what
2341 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2342 if (!SvPADTMP(*SP)) {
2343 *MARK = SvREFCNT_inc(*SP);
2348 /* FREETMPS could clobber it */
2349 SV *sv = SvREFCNT_inc(*SP);
2351 *MARK = sv_mortalcopy(sv);
2358 ? sv_mortalcopy(*SP)
2360 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2365 *MARK = &PL_sv_undef;
2369 if (CxLVAL(cx) & OPpDEREF) {
2372 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2376 else if (gimme == G_ARRAY) {
2377 assert (!(CxLVAL(cx) & OPpDEREF));
2378 if (ref || !CxLVAL(cx))
2379 for (; MARK <= SP; MARK++)
2381 SvFLAGS(*MARK) & SVs_PADTMP
2382 ? sv_mortalcopy(*MARK)
2385 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2386 else for (; MARK <= SP; MARK++) {
2387 if (*MARK != &PL_sv_undef
2388 && (SvPADTMP(*MARK) || SvREADONLY(*MARK))
2390 /* Might be flattened array after $#array = */
2391 what = SvREADONLY(*MARK)
2392 ? "a readonly value" : "a temporary";
2395 else if (!SvTEMP(*MARK))
2396 *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2402 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2404 PL_curpm = newpm; /* ... and pop $1 et al */
2407 return cx->blk_sub.retop;
2416 const I32 cxix = dopoptosub(cxstack_ix);
2418 assert(cxstack_ix >= 0);
2419 if (cxix < cxstack_ix) {
2421 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2422 * sort block, which is a CXt_NULL
2425 /* if we were in list context, we would have to splice out
2426 * any junk before the return args, like we do in the general
2427 * pp_return case, e.g.
2428 * sub f { for (junk1, junk2) { return arg1, arg2 }}
2430 assert(cxstack[0].blk_gimme == G_SCALAR);
2434 DIE(aTHX_ "Can't return outside a subroutine");
2439 cx = &cxstack[cxix];
2441 oldsp = PL_stack_base + cx->blk_oldsp;
2442 if (oldsp != MARK) {
2443 /* Handle extra junk on the stack. For example,
2444 * for (1,2) { return 3,4 }
2445 * leaves 1,2,3,4 on the stack. In list context we
2446 * have to splice out the 1,2; In scalar context for
2447 * for (1,2) { return }
2448 * we need to set sp = oldsp so that pp_leavesub knows
2449 * to push &PL_sv_undef onto the stack.
2450 * Note that in pp_return we only do the extra processing
2451 * required to handle junk; everything else we leave to
2454 SSize_t nargs = SP - MARK;
2456 if (cx->blk_gimme == G_ARRAY) {
2457 /* shift return args to base of call stack frame */
2458 Move(MARK + 1, oldsp + 1, nargs, SV*);
2459 PL_stack_sp = oldsp + nargs;
2463 PL_stack_sp = oldsp;
2466 /* fall through to a normal exit */
2467 switch (CxTYPE(cx)) {
2469 return CxTRYBLOCK(cx)
2470 ? Perl_pp_leavetry(aTHX)
2471 : Perl_pp_leaveeval(aTHX);
2473 return CvLVALUE(cx->blk_sub.cv)
2474 ? Perl_pp_leavesublv(aTHX)
2475 : Perl_pp_leavesub(aTHX);
2477 return Perl_pp_leavewrite(aTHX);
2479 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2485 S_unwind_loop(pTHX_ const char * const opname)
2488 if (PL_op->op_flags & OPf_SPECIAL) {
2489 cxix = dopoptoloop(cxstack_ix);
2491 /* diag_listed_as: Can't "last" outside a loop block */
2492 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2497 const char * const label =
2498 PL_op->op_flags & OPf_STACKED
2499 ? SvPV(TOPs,label_len)
2500 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2501 const U32 label_flags =
2502 PL_op->op_flags & OPf_STACKED
2504 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2506 cxix = dopoptolabel(label, label_len, label_flags);
2508 /* diag_listed_as: Label not found for "last %s" */
2509 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2511 SVfARG(PL_op->op_flags & OPf_STACKED
2512 && !SvGMAGICAL(TOPp1s)
2514 : newSVpvn_flags(label,
2516 label_flags | SVs_TEMP)));
2518 if (cxix < cxstack_ix)
2531 S_unwind_loop(aTHX_ "last");
2534 cxstack_ix++; /* temporarily protect top context */
2536 CxTYPE(cx) == CXt_LOOP_LAZYIV
2537 || CxTYPE(cx) == CXt_LOOP_LAZYSV
2538 || CxTYPE(cx) == CXt_LOOP_FOR
2539 || CxTYPE(cx) == CXt_LOOP_PLAIN
2541 newsp = PL_stack_base + cx->blk_loop.resetsp;
2542 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2545 PL_stack_sp = newsp;
2549 /* Stack values are safe: */
2550 POPLOOP(cx); /* release loop vars ... */
2552 PL_curpm = newpm; /* ... and pop $1 et al */
2554 PERL_UNUSED_VAR(gimme);
2561 const I32 inner = PL_scopestack_ix;
2563 S_unwind_loop(aTHX_ "next");
2565 /* clear off anything above the scope we're re-entering, but
2566 * save the rest until after a possible continue block */
2568 if (PL_scopestack_ix < inner)
2569 leave_scope(PL_scopestack[PL_scopestack_ix]);
2570 PL_curcop = cx->blk_oldcop;
2572 return (cx)->blk_loop.my_op->op_nextop;
2577 const I32 cxix = S_unwind_loop(aTHX_ "redo");
2580 OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2582 if (redo_op->op_type == OP_ENTER) {
2583 /* pop one less context to avoid $x being freed in while (my $x..) */
2585 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2586 redo_op = redo_op->op_next;
2590 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2591 LEAVE_SCOPE(oldsave);
2593 PL_curcop = cx->blk_oldcop;
2599 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2602 static const char* const too_deep = "Target of goto is too deeply nested";
2604 PERL_ARGS_ASSERT_DOFINDLABEL;
2607 Perl_croak(aTHX_ "%s", too_deep);
2608 if (o->op_type == OP_LEAVE ||
2609 o->op_type == OP_SCOPE ||
2610 o->op_type == OP_LEAVELOOP ||
2611 o->op_type == OP_LEAVESUB ||
2612 o->op_type == OP_LEAVETRY)
2614 *ops++ = cUNOPo->op_first;
2616 Perl_croak(aTHX_ "%s", too_deep);
2619 if (o->op_flags & OPf_KIDS) {
2621 /* First try all the kids at this level, since that's likeliest. */
2622 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2623 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2624 STRLEN kid_label_len;
2625 U32 kid_label_flags;
2626 const char *kid_label = CopLABEL_len_flags(kCOP,
2627 &kid_label_len, &kid_label_flags);
2629 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2632 (const U8*)kid_label, kid_label_len,
2633 (const U8*)label, len) == 0)
2635 (const U8*)label, len,
2636 (const U8*)kid_label, kid_label_len) == 0)
2637 : ( len == kid_label_len && ((kid_label == label)
2638 || memEQ(kid_label, label, len)))))
2642 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2643 if (kid == PL_lastgotoprobe)
2645 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2648 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2649 ops[-1]->op_type == OP_DBSTATE)
2654 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2663 /* also used for: pp_dump() */
2671 #define GOTO_DEPTH 64
2672 OP *enterops[GOTO_DEPTH];
2673 const char *label = NULL;
2674 STRLEN label_len = 0;
2675 U32 label_flags = 0;
2676 const bool do_dump = (PL_op->op_type == OP_DUMP);
2677 static const char* const must_have_label = "goto must have label";
2679 if (PL_op->op_flags & OPf_STACKED) {
2680 /* goto EXPR or goto &foo */
2682 SV * const sv = POPs;
2685 /* This egregious kludge implements goto &subroutine */
2686 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2689 CV *cv = MUTABLE_CV(SvRV(sv));
2690 AV *arg = GvAV(PL_defgv);
2694 if (!CvROOT(cv) && !CvXSUB(cv)) {
2695 const GV * const gv = CvGV(cv);
2699 /* autoloaded stub? */
2700 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2702 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2704 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2705 if (autogv && (cv = GvCV(autogv)))
2707 tmpstr = sv_newmortal();
2708 gv_efullname3(tmpstr, gv, NULL);
2709 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2711 DIE(aTHX_ "Goto undefined subroutine");
2714 /* First do some returnish stuff. */
2715 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2717 cxix = dopoptosub(cxstack_ix);
2718 if (cxix < cxstack_ix) {
2721 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2727 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2728 if (CxTYPE(cx) == CXt_EVAL) {
2731 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2732 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2734 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2735 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2737 else if (CxMULTICALL(cx))
2740 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2742 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2743 AV* av = cx->blk_sub.argarray;
2745 /* abandon the original @_ if it got reified or if it is
2746 the same as the current @_ */
2747 if (AvREAL(av) || av == arg) {
2751 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2753 else CLEAR_ARGARRAY(av);
2755 /* We donate this refcount later to the callee’s pad. */
2756 SvREFCNT_inc_simple_void(arg);
2757 if (CxTYPE(cx) == CXt_SUB &&
2758 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2759 SvREFCNT_dec(cx->blk_sub.cv);
2760 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2761 LEAVE_SCOPE(oldsave);
2763 /* A destructor called during LEAVE_SCOPE could have undefined
2764 * our precious cv. See bug #99850. */
2765 if (!CvROOT(cv) && !CvXSUB(cv)) {
2766 const GV * const gv = CvGV(cv);
2769 SV * const tmpstr = sv_newmortal();
2770 gv_efullname3(tmpstr, gv, NULL);
2771 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2774 DIE(aTHX_ "Goto undefined subroutine");
2777 /* Now do some callish stuff. */
2779 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2783 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2784 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2787 PERL_UNUSED_VAR(newsp);
2788 PERL_UNUSED_VAR(gimme);
2790 /* put GvAV(defgv) back onto stack */
2792 EXTEND(SP, items+1); /* @_ could have been extended. */
2797 bool r = cBOOL(AvREAL(arg));
2798 for (index=0; index<items; index++)
2802 SV ** const svp = av_fetch(arg, index, 0);
2803 sv = svp ? *svp : NULL;
2805 else sv = AvARRAY(arg)[index];
2807 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2808 : sv_2mortal(newSVavdefelem(arg, index, 1));
2813 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2814 /* Restore old @_ */
2815 arg = GvAV(PL_defgv);
2816 GvAV(PL_defgv) = cx->blk_sub.savearray;
2820 retop = cx->blk_sub.retop;
2821 /* XS subs don't have a CxSUB, so pop it */
2822 POPBLOCK(cx, PL_curpm);
2823 /* Push a mark for the start of arglist */
2826 (void)(*CvXSUB(cv))(aTHX_ cv);
2831 PADLIST * const padlist = CvPADLIST(cv);
2832 cx->blk_sub.cv = cv;
2833 cx->blk_sub.olddepth = CvDEPTH(cv);
2836 if (CvDEPTH(cv) < 2)
2837 SvREFCNT_inc_simple_void_NN(cv);
2839 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2840 sub_crush_depth(cv);
2841 pad_push(padlist, CvDEPTH(cv));
2843 PL_curcop = cx->blk_oldcop;
2845 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2848 CX_CURPAD_SAVE(cx->blk_sub);
2850 /* cx->blk_sub.argarray has no reference count, so we
2851 need something to hang on to our argument array so
2852 that cx->blk_sub.argarray does not end up pointing
2853 to freed memory as the result of undef *_. So put
2854 it in the callee’s pad, donating our refer-
2857 SvREFCNT_dec(PAD_SVl(0));
2858 PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2861 /* GvAV(PL_defgv) might have been modified on scope
2862 exit, so restore it. */
2863 if (arg != GvAV(PL_defgv)) {
2864 AV * const av = GvAV(PL_defgv);
2865 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2869 else SvREFCNT_dec(arg);
2870 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2871 Perl_get_db_sub(aTHX_ NULL, cv);
2873 CV * const gotocv = get_cvs("DB::goto", 0);
2875 PUSHMARK( PL_stack_sp );
2876 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2881 retop = CvSTART(cv);
2882 goto putback_return;
2887 label = SvPV_nomg_const(sv, label_len);
2888 label_flags = SvUTF8(sv);
2891 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2892 /* goto LABEL or dump LABEL */
2893 label = cPVOP->op_pv;
2894 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2895 label_len = strlen(label);
2897 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2902 OP *gotoprobe = NULL;
2903 bool leaving_eval = FALSE;
2904 bool in_block = FALSE;
2905 PERL_CONTEXT *last_eval_cx = NULL;
2909 PL_lastgotoprobe = NULL;
2911 for (ix = cxstack_ix; ix >= 0; ix--) {
2913 switch (CxTYPE(cx)) {
2915 leaving_eval = TRUE;
2916 if (!CxTRYBLOCK(cx)) {
2917 gotoprobe = (last_eval_cx ?
2918 last_eval_cx->blk_eval.old_eval_root :
2923 /* else fall through */
2924 case CXt_LOOP_LAZYIV:
2925 case CXt_LOOP_LAZYSV:
2927 case CXt_LOOP_PLAIN:
2930 gotoprobe = OpSIBLING(cx->blk_oldcop);
2936 gotoprobe = OpSIBLING(cx->blk_oldcop);
2939 gotoprobe = PL_main_root;
2942 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2943 gotoprobe = CvROOT(cx->blk_sub.cv);
2949 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2952 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
2953 CxTYPE(cx), (long) ix);
2954 gotoprobe = PL_main_root;
2960 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
2961 enterops, enterops + GOTO_DEPTH);
2964 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
2965 sibl1->op_type == OP_UNSTACK &&
2966 (sibl2 = OpSIBLING(sibl1)))
2968 retop = dofindlabel(sibl2,
2969 label, label_len, label_flags, enterops,
2970 enterops + GOTO_DEPTH);
2975 PL_lastgotoprobe = gotoprobe;
2978 DIE(aTHX_ "Can't find label %"UTF8f,
2979 UTF8fARG(label_flags, label_len, label));
2981 /* if we're leaving an eval, check before we pop any frames
2982 that we're not going to punt, otherwise the error
2985 if (leaving_eval && *enterops && enterops[1]) {
2987 for (i = 1; enterops[i]; i++)
2988 if (enterops[i]->op_type == OP_ENTERITER)
2989 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2992 if (*enterops && enterops[1]) {
2993 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2995 deprecate("\"goto\" to jump into a construct");
2998 /* pop unwanted frames */
3000 if (ix < cxstack_ix) {
3004 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3007 oldsave = PL_scopestack[PL_scopestack_ix];
3008 LEAVE_SCOPE(oldsave);
3011 /* push wanted frames */
3013 if (*enterops && enterops[1]) {
3014 OP * const oldop = PL_op;
3015 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3016 for (; enterops[ix]; ix++) {
3017 PL_op = enterops[ix];
3018 /* Eventually we may want to stack the needed arguments
3019 * for each op. For now, we punt on the hard ones. */
3020 if (PL_op->op_type == OP_ENTERITER)
3021 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3022 PL_op->op_ppaddr(aTHX);
3030 if (!retop) retop = PL_main_start;
3032 PL_restartop = retop;
3033 PL_do_undump = TRUE;
3037 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3038 PL_do_undump = FALSE;
3056 anum = 0; (void)POPs;
3062 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3065 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3068 PL_exit_flags |= PERL_EXIT_EXPECTED;
3070 PUSHs(&PL_sv_undef);
3077 S_save_lines(pTHX_ AV *array, SV *sv)
3079 const char *s = SvPVX_const(sv);
3080 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3083 PERL_ARGS_ASSERT_SAVE_LINES;
3085 while (s && s < send) {
3087 SV * const tmpstr = newSV_type(SVt_PVMG);
3089 t = (const char *)memchr(s, '\n', send - s);
3095 sv_setpvn(tmpstr, s, t - s);
3096 av_store(array, line++, tmpstr);
3104 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3106 0 is used as continue inside eval,
3108 3 is used for a die caught by an inner eval - continue inner loop
3110 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3111 establish a local jmpenv to handle exception traps.
3116 S_docatch(pTHX_ OP *o)
3119 OP * const oldop = PL_op;
3123 assert(CATCH_GET == TRUE);
3130 assert(cxstack_ix >= 0);
3131 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3132 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3137 /* die caught by an inner eval - continue inner loop */
3138 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3139 PL_restartjmpenv = NULL;
3140 PL_op = PL_restartop;
3149 NOT_REACHED; /* NOTREACHED */
3158 =for apidoc find_runcv
3160 Locate the CV corresponding to the currently executing sub or eval.
3161 If db_seqp is non_null, skip CVs that are in the DB package and populate
3162 *db_seqp with the cop sequence number at the point that the DB:: code was
3163 entered. (This allows debuggers to eval in the scope of the breakpoint
3164 rather than in the scope of the debugger itself.)
3170 Perl_find_runcv(pTHX_ U32 *db_seqp)
3172 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3175 /* If this becomes part of the API, it might need a better name. */
3177 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3184 PL_curcop == &PL_compiling
3186 : PL_curcop->cop_seq;
3188 for (si = PL_curstackinfo; si; si = si->si_prev) {
3190 for (ix = si->si_cxix; ix >= 0; ix--) {
3191 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3193 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3194 cv = cx->blk_sub.cv;
3195 /* skip DB:: code */
3196 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3197 *db_seqp = cx->blk_oldcop->cop_seq;
3200 if (cx->cx_type & CXp_SUB_RE)
3203 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3204 cv = cx->blk_eval.cv;
3207 case FIND_RUNCV_padid_eq:
3209 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3212 case FIND_RUNCV_level_eq:
3213 if (level++ != arg) continue;
3221 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3225 /* Run yyparse() in a setjmp wrapper. Returns:
3226 * 0: yyparse() successful
3227 * 1: yyparse() failed
3231 S_try_yyparse(pTHX_ int gramtype)
3236 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3240 ret = yyparse(gramtype) ? 1 : 0;
3247 NOT_REACHED; /* NOTREACHED */
3254 /* Compile a require/do or an eval ''.
3256 * outside is the lexically enclosing CV (if any) that invoked us.
3257 * seq is the current COP scope value.
3258 * hh is the saved hints hash, if any.
3260 * Returns a bool indicating whether the compile was successful; if so,
3261 * PL_eval_start contains the first op of the compiled code; otherwise,
3264 * This function is called from two places: pp_require and pp_entereval.
3265 * These can be distinguished by whether PL_op is entereval.
3269 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3272 OP * const saveop = PL_op;
3273 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3274 COP * const oldcurcop = PL_curcop;
3275 bool in_require = (saveop->op_type == OP_REQUIRE);
3279 PL_in_eval = (in_require
3280 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3282 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3283 ? EVAL_RE_REPARSING : 0)));
3287 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3289 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3290 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3291 cxstack[cxstack_ix].blk_gimme = gimme;
3293 CvOUTSIDE_SEQ(evalcv) = seq;
3294 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3296 /* set up a scratch pad */
3298 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3299 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3302 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3304 /* make sure we compile in the right package */
3306 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3307 SAVEGENERICSV(PL_curstash);
3308 PL_curstash = (HV *)CopSTASH(PL_curcop);
3309 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3310 else SvREFCNT_inc_simple_void(PL_curstash);
3312 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3313 SAVESPTR(PL_beginav);
3314 PL_beginav = newAV();
3315 SAVEFREESV(PL_beginav);
3316 SAVESPTR(PL_unitcheckav);
3317 PL_unitcheckav = newAV();
3318 SAVEFREESV(PL_unitcheckav);
3321 ENTER_with_name("evalcomp");
3322 SAVESPTR(PL_compcv);
3325 /* try to compile it */
3327 PL_eval_root = NULL;
3328 PL_curcop = &PL_compiling;
3329 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3330 PL_in_eval |= EVAL_KEEPERR;
3337 hv_clear(GvHV(PL_hintgv));
3340 PL_hints = saveop->op_private & OPpEVAL_COPHH
3341 ? oldcurcop->cop_hints : saveop->op_targ;
3343 /* making 'use re eval' not be in scope when compiling the
3344 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3345 * infinite recursion when S_has_runtime_code() gives a false
3346 * positive: the second time round, HINT_RE_EVAL isn't set so we
3347 * don't bother calling S_has_runtime_code() */
3348 if (PL_in_eval & EVAL_RE_REPARSING)
3349 PL_hints &= ~HINT_RE_EVAL;
3352 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3353 SvREFCNT_dec(GvHV(PL_hintgv));
3354 GvHV(PL_hintgv) = hh;
3357 SAVECOMPILEWARNINGS();
3359 if (PL_dowarn & G_WARN_ALL_ON)
3360 PL_compiling.cop_warnings = pWARN_ALL ;
3361 else if (PL_dowarn & G_WARN_ALL_OFF)
3362 PL_compiling.cop_warnings = pWARN_NONE ;
3364 PL_compiling.cop_warnings = pWARN_STD ;
3367 PL_compiling.cop_warnings =
3368 DUP_WARNINGS(oldcurcop->cop_warnings);
3369 cophh_free(CopHINTHASH_get(&PL_compiling));
3370 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3371 /* The label, if present, is the first entry on the chain. So rather
3372 than writing a blank label in front of it (which involves an
3373 allocation), just use the next entry in the chain. */
3374 PL_compiling.cop_hints_hash
3375 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3376 /* Check the assumption that this removed the label. */
3377 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3380 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3383 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3385 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3386 * so honour CATCH_GET and trap it here if necessary */
3388 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3390 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3391 SV **newsp; /* Used by POPBLOCK. */
3393 I32 optype; /* Used by POPEVAL. */
3399 PERL_UNUSED_VAR(newsp);
3400 PERL_UNUSED_VAR(optype);
3402 /* note that if yystatus == 3, then the EVAL CX block has already
3403 * been popped, and various vars restored */
3405 if (yystatus != 3) {
3407 op_free(PL_eval_root);
3408 PL_eval_root = NULL;
3410 SP = PL_stack_base + POPMARK; /* pop original mark */
3411 POPBLOCK(cx,PL_curpm);
3413 namesv = cx->blk_eval.old_namesv;
3414 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3415 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3421 /* If cx is still NULL, it means that we didn't go in the
3422 * POPEVAL branch. */
3423 cx = &cxstack[cxstack_ix];
3424 assert(CxTYPE(cx) == CXt_EVAL);
3425 namesv = cx->blk_eval.old_namesv;
3427 (void)hv_store(GvHVn(PL_incgv),
3428 SvPVX_const(namesv),
3429 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3431 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3434 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3437 if (!*(SvPV_nolen_const(errsv))) {
3438 sv_setpvs(errsv, "Compilation error");
3441 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3446 LEAVE_with_name("evalcomp");
3448 CopLINE_set(&PL_compiling, 0);
3449 SAVEFREEOP(PL_eval_root);
3450 cv_forget_slab(evalcv);
3452 DEBUG_x(dump_eval());
3454 /* Register with debugger: */
3455 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3456 CV * const cv = get_cvs("DB::postponed", 0);
3460 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3462 call_sv(MUTABLE_SV(cv), G_DISCARD);
3466 if (PL_unitcheckav) {
3467 OP *es = PL_eval_start;
3468 call_list(PL_scopestack_ix, PL_unitcheckav);
3472 /* compiled okay, so do it */
3474 CvDEPTH(evalcv) = 1;
3475 SP = PL_stack_base + POPMARK; /* pop original mark */
3476 PL_op = saveop; /* The caller may need it. */
3477 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3484 S_check_type_and_open(pTHX_ SV *name)
3489 const char *p = SvPV_const(name, len);
3492 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3494 /* checking here captures a reasonable error message when
3495 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3496 * user gets a confusing message about looking for the .pmc file
3497 * rather than for the .pm file.
3498 * This check prevents a \0 in @INC causing problems.
3500 if (!IS_SAFE_PATHNAME(p, len, "require"))
3503 /* on Win32 stat is expensive (it does an open() and close() twice and
3504 a couple other IO calls), the open will fail with a dir on its own with
3505 errno EACCES, so only do a stat to separate a dir from a real EACCES
3506 caused by user perms */
3508 /* we use the value of errno later to see how stat() or open() failed.
3509 * We don't want it set if the stat succeeded but we still failed,
3510 * such as if the name exists, but is a directory */
3513 st_rc = PerlLIO_stat(p, &st);
3515 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3520 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3522 /* EACCES stops the INC search early in pp_require to implement
3523 feature RT #113422 */
3524 if(!retio && errno == EACCES) { /* exists but probably a directory */
3526 st_rc = PerlLIO_stat(p, &st);
3528 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3539 #ifndef PERL_DISABLE_PMC
3541 S_doopen_pm(pTHX_ SV *name)
3544 const char *p = SvPV_const(name, namelen);
3546 PERL_ARGS_ASSERT_DOOPEN_PM;
3548 /* check the name before trying for the .pmc name to avoid the
3549 * warning referring to the .pmc which the user probably doesn't
3550 * know or care about
3552 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3555 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3556 SV *const pmcsv = sv_newmortal();
3559 SvSetSV_nosteal(pmcsv,name);
3560 sv_catpvs(pmcsv, "c");
3562 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3563 return check_type_and_open(pmcsv);
3565 return check_type_and_open(name);
3568 # define doopen_pm(name) check_type_and_open(name)
3569 #endif /* !PERL_DISABLE_PMC */
3571 /* require doesn't search for absolute names, or when the name is
3572 explicitly relative the current directory */
3573 PERL_STATIC_INLINE bool
3574 S_path_is_searchable(const char *name)
3576 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3578 if (PERL_FILE_IS_ABSOLUTE(name)
3580 || (*name == '.' && ((name[1] == '/' ||
3581 (name[1] == '.' && name[2] == '/'))
3582 || (name[1] == '\\' ||
3583 ( name[1] == '.' && name[2] == '\\')))
3586 || (*name == '.' && (name[1] == '/' ||
3587 (name[1] == '.' && name[2] == '/')))
3598 /* also used for: pp_dofile() */
3610 int vms_unixname = 0;
3613 const char *tryname = NULL;
3615 const I32 gimme = GIMME_V;
3616 int filter_has_file = 0;
3617 PerlIO *tryrsfp = NULL;
3618 SV *filter_cache = NULL;
3619 SV *filter_state = NULL;
3620 SV *filter_sub = NULL;
3624 bool path_searchable;
3628 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3629 sv = sv_2mortal(new_version(sv));
3630 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3631 upg_version(PL_patchlevel, TRUE);
3632 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3633 if ( vcmp(sv,PL_patchlevel) <= 0 )
3634 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3635 SVfARG(sv_2mortal(vnormal(sv))),
3636 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3640 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3643 SV * const req = SvRV(sv);
3644 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3646 /* get the left hand term */
3647 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3649 first = SvIV(*av_fetch(lav,0,0));
3650 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3651 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3652 || av_tindex(lav) > 1 /* FP with > 3 digits */
3653 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3655 DIE(aTHX_ "Perl %"SVf" required--this is only "
3657 SVfARG(sv_2mortal(vnormal(req))),
3658 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3661 else { /* probably 'use 5.10' or 'use 5.8' */
3665 if (av_tindex(lav)>=1)
3666 second = SvIV(*av_fetch(lav,1,0));
3668 second /= second >= 600 ? 100 : 10;
3669 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3670 (int)first, (int)second);
3671 upg_version(hintsv, TRUE);
3673 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3674 "--this is only %"SVf", stopped",
3675 SVfARG(sv_2mortal(vnormal(req))),
3676 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3677 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3686 DIE(aTHX_ "Missing or undefined argument to require");
3687 name = SvPV_nomg_const(sv, len);
3688 if (!(name && len > 0 && *name))
3689 DIE(aTHX_ "Missing or undefined argument to require");
3691 if (!IS_SAFE_PATHNAME(name, len, "require")) {
3692 DIE(aTHX_ "Can't locate %s: %s",
3693 pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3694 SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3697 TAINT_PROPER("require");
3699 path_searchable = path_is_searchable(name);
3702 /* The key in the %ENV hash is in the syntax of file passed as the argument
3703 * usually this is in UNIX format, but sometimes in VMS format, which
3704 * can result in a module being pulled in more than once.
3705 * To prevent this, the key must be stored in UNIX format if the VMS
3706 * name can be translated to UNIX.
3710 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3712 unixlen = strlen(unixname);
3718 /* if not VMS or VMS name can not be translated to UNIX, pass it
3721 unixname = (char *) name;
3724 if (PL_op->op_type == OP_REQUIRE) {
3725 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3726 unixname, unixlen, 0);
3728 if (*svp != &PL_sv_undef)
3731 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3732 "Compilation failed in require", unixname);
3736 LOADING_FILE_PROBE(unixname);
3738 /* prepare to compile file */
3740 if (!path_searchable) {
3741 /* At this point, name is SvPVX(sv) */
3743 tryrsfp = doopen_pm(sv);
3745 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3746 AV * const ar = GvAVn(PL_incgv);
3753 namesv = newSV_type(SVt_PV);
3754 for (i = 0; i <= AvFILL(ar); i++) {
3755 SV * const dirsv = *av_fetch(ar, i, TRUE);
3763 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3764 && !SvOBJECT(SvRV(loader)))
3766 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3770 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3771 PTR2UV(SvRV(dirsv)), name);
3772 tryname = SvPVX_const(namesv);
3775 if (SvPADTMP(nsv)) {
3776 nsv = sv_newmortal();
3777 SvSetSV_nosteal(nsv,sv);
3780 ENTER_with_name("call_INC");
3788 if (SvGMAGICAL(loader)) {
3789 SV *l = sv_newmortal();
3790 sv_setsv_nomg(l, loader);
3793 if (sv_isobject(loader))
3794 count = call_method("INC", G_ARRAY);
3796 count = call_sv(loader, G_ARRAY);
3806 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3807 && !isGV_with_GP(SvRV(arg))) {
3808 filter_cache = SvRV(arg);
3815 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3819 if (isGV_with_GP(arg)) {
3820 IO * const io = GvIO((const GV *)arg);
3825 tryrsfp = IoIFP(io);
3826 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3827 PerlIO_close(IoOFP(io));
3838 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3840 SvREFCNT_inc_simple_void_NN(filter_sub);
3843 filter_state = SP[i];
3844 SvREFCNT_inc_simple_void(filter_state);
3848 if (!tryrsfp && (filter_cache || filter_sub)) {
3849 tryrsfp = PerlIO_open(BIT_BUCKET,
3855 /* FREETMPS may free our filter_cache */
3856 SvREFCNT_inc_simple_void(filter_cache);
3860 LEAVE_with_name("call_INC");
3862 /* Now re-mortalize it. */
3863 sv_2mortal(filter_cache);
3865 /* Adjust file name if the hook has set an %INC entry.
3866 This needs to happen after the FREETMPS above. */
3867 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3869 tryname = SvPV_nolen_const(*svp);
3876 filter_has_file = 0;
3877 filter_cache = NULL;
3879 SvREFCNT_dec_NN(filter_state);
3880 filter_state = NULL;
3883 SvREFCNT_dec_NN(filter_sub);
3888 if (path_searchable) {
3893 dir = SvPV_nomg_const(dirsv, dirlen);
3899 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3903 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3906 sv_setpv(namesv, unixdir);
3907 sv_catpv(namesv, unixname);
3909 # ifdef __SYMBIAN32__
3910 if (PL_origfilename[0] &&
3911 PL_origfilename[1] == ':' &&
3912 !(dir[0] && dir[1] == ':'))
3913 Perl_sv_setpvf(aTHX_ namesv,
3918 Perl_sv_setpvf(aTHX_ namesv,
3922 /* The equivalent of
3923 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3924 but without the need to parse the format string, or
3925 call strlen on either pointer, and with the correct
3926 allocation up front. */
3928 char *tmp = SvGROW(namesv, dirlen + len + 2);
3930 memcpy(tmp, dir, dirlen);
3933 /* Avoid '<dir>//<file>' */
3934 if (!dirlen || *(tmp-1) != '/') {
3937 /* So SvCUR_set reports the correct length below */
3941 /* name came from an SV, so it will have a '\0' at the
3942 end that we can copy as part of this memcpy(). */
3943 memcpy(tmp, name, len + 1);
3945 SvCUR_set(namesv, dirlen + len + 1);
3950 TAINT_PROPER("require");
3951 tryname = SvPVX_const(namesv);
3952 tryrsfp = doopen_pm(namesv);
3954 if (tryname[0] == '.' && tryname[1] == '/') {
3956 while (*++tryname == '/') {}
3960 else if (errno == EMFILE || errno == EACCES) {
3961 /* no point in trying other paths if out of handles;
3962 * on the other hand, if we couldn't open one of the
3963 * files, then going on with the search could lead to
3964 * unexpected results; see perl #113422
3973 saved_errno = errno; /* sv_2mortal can realloc things */
3976 if (PL_op->op_type == OP_REQUIRE) {
3977 if(saved_errno == EMFILE || saved_errno == EACCES) {
3978 /* diag_listed_as: Can't locate %s */
3979 DIE(aTHX_ "Can't locate %s: %s: %s",
3980 name, tryname, Strerror(saved_errno));
3982 if (namesv) { /* did we lookup @INC? */
3983 AV * const ar = GvAVn(PL_incgv);
3985 SV *const msg = newSVpvs_flags("", SVs_TEMP);
3986 SV *const inc = newSVpvs_flags("", SVs_TEMP);
3987 for (i = 0; i <= AvFILL(ar); i++) {
3988 sv_catpvs(inc, " ");
3989 sv_catsv(inc, *av_fetch(ar, i, TRUE));
3991 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
3992 const char *c, *e = name + len - 3;
3993 sv_catpv(msg, " (you may need to install the ");
3994 for (c = name; c < e; c++) {
3996 sv_catpvs(msg, "::");
3999 sv_catpvn(msg, c, 1);
4002 sv_catpv(msg, " module)");
4004 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4005 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4007 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4008 sv_catpv(msg, " (did you run h2ph?)");
4011 /* diag_listed_as: Can't locate %s */
4013 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4017 DIE(aTHX_ "Can't locate %s", name);
4024 SETERRNO(0, SS_NORMAL);
4026 /* Assume success here to prevent recursive requirement. */
4027 /* name is never assigned to again, so len is still strlen(name) */
4028 /* Check whether a hook in @INC has already filled %INC */
4030 (void)hv_store(GvHVn(PL_incgv),
4031 unixname, unixlen, newSVpv(tryname,0),0);
4033 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4035 (void)hv_store(GvHVn(PL_incgv),
4036 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4039 ENTER_with_name("eval");
4041 SAVECOPFILE_FREE(&PL_compiling);
4042 CopFILE_set(&PL_compiling, tryname);
4043 lex_start(NULL, tryrsfp, 0);
4045 if (filter_sub || filter_cache) {
4046 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4047 than hanging another SV from it. In turn, filter_add() optionally
4048 takes the SV to use as the filter (or creates a new SV if passed
4049 NULL), so simply pass in whatever value filter_cache has. */
4050 SV * const fc = filter_cache ? newSV(0) : NULL;
4052 if (fc) sv_copypv(fc, filter_cache);
4053 datasv = filter_add(S_run_user_filter, fc);
4054 IoLINES(datasv) = filter_has_file;
4055 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4056 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4059 /* switch to eval mode */
4060 PUSHBLOCK(cx, CXt_EVAL, SP);
4062 cx->blk_eval.retop = PL_op->op_next;
4064 SAVECOPLINE(&PL_compiling);
4065 CopLINE_set(&PL_compiling, 0);
4069 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4070 op = DOCATCH(PL_eval_start);
4072 op = PL_op->op_next;
4074 LOADED_FILE_PROBE(unixname);
4079 /* This is a op added to hold the hints hash for
4080 pp_entereval. The hash can be modified by the code
4081 being eval'ed, so we return a copy instead. */
4086 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4096 const I32 gimme = GIMME_V;
4097 const U32 was = PL_breakable_sub_gen;
4098 char tbuf[TYPE_DIGITS(long) + 12];
4099 bool saved_delete = FALSE;
4100 char *tmpbuf = tbuf;
4103 U32 seq, lex_flags = 0;
4104 HV *saved_hh = NULL;
4105 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4107 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4108 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4110 else if (PL_hints & HINT_LOCALIZE_HH || (
4111 PL_op->op_private & OPpEVAL_COPHH
4112 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4114 saved_hh = cop_hints_2hv(PL_curcop, 0);
4115 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4119 /* make sure we've got a plain PV (no overload etc) before testing
4120 * for taint. Making a copy here is probably overkill, but better
4121 * safe than sorry */
4123 const char * const p = SvPV_const(sv, len);
4125 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4126 lex_flags |= LEX_START_COPIED;
4128 if (bytes && SvUTF8(sv))
4129 SvPVbyte_force(sv, len);
4131 else if (bytes && SvUTF8(sv)) {
4132 /* Don't modify someone else's scalar */
4135 (void)sv_2mortal(sv);
4136 SvPVbyte_force(sv,len);
4137 lex_flags |= LEX_START_COPIED;
4140 TAINT_IF(SvTAINTED(sv));
4141 TAINT_PROPER("eval");
4143 ENTER_with_name("eval");
4144 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4145 ? LEX_IGNORE_UTF8_HINTS
4146 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4151 /* switch to eval mode */
4153 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4154 SV * const temp_sv = sv_newmortal();
4155 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4156 (unsigned long)++PL_evalseq,
4157 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4158 tmpbuf = SvPVX(temp_sv);
4159 len = SvCUR(temp_sv);
4162 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4163 SAVECOPFILE_FREE(&PL_compiling);
4164 CopFILE_set(&PL_compiling, tmpbuf+2);
4165 SAVECOPLINE(&PL_compiling);
4166 CopLINE_set(&PL_compiling, 1);
4167 /* special case: an eval '' executed within the DB package gets lexically
4168 * placed in the first non-DB CV rather than the current CV - this
4169 * allows the debugger to execute code, find lexicals etc, in the
4170 * scope of the code being debugged. Passing &seq gets find_runcv
4171 * to do the dirty work for us */
4172 runcv = find_runcv(&seq);
4174 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4176 cx->blk_eval.retop = PL_op->op_next;
4178 /* prepare to compile string */
4180 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4181 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4183 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4184 deleting the eval's FILEGV from the stash before gv_check() runs
4185 (i.e. before run-time proper). To work around the coredump that
4186 ensues, we always turn GvMULTI_on for any globals that were
4187 introduced within evals. See force_ident(). GSAR 96-10-12 */
4188 char *const safestr = savepvn(tmpbuf, len);
4189 SAVEDELETE(PL_defstash, safestr, len);
4190 saved_delete = TRUE;
4195 if (doeval(gimme, runcv, seq, saved_hh)) {
4196 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4197 ? PERLDB_LINE_OR_SAVESRC
4198 : PERLDB_SAVESRC_NOSUBS) {
4199 /* Retain the filegv we created. */
4200 } else if (!saved_delete) {
4201 char *const safestr = savepvn(tmpbuf, len);
4202 SAVEDELETE(PL_defstash, safestr, len);
4204 return DOCATCH(PL_eval_start);
4206 /* We have already left the scope set up earlier thanks to the LEAVE
4208 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4209 ? PERLDB_LINE_OR_SAVESRC
4210 : PERLDB_SAVESRC_INVALID) {
4211 /* Retain the filegv we created. */
4212 } else if (!saved_delete) {
4213 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4215 return PL_op->op_next;
4230 /* grab this value before POPEVAL restores old PL_in_eval */
4231 bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4236 namesv = cx->blk_eval.old_namesv;
4237 retop = cx->blk_eval.retop;
4238 evalcv = cx->blk_eval.cv;
4240 SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
4241 gimme, SVs_TEMP, FALSE);
4242 PL_curpm = newpm; /* Don't pop $1 et al till now */
4245 assert(CvDEPTH(evalcv) == 1);
4247 CvDEPTH(evalcv) = 0;
4249 if (optype == OP_REQUIRE &&
4250 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4252 /* Unassume the success we assumed earlier. */
4253 (void)hv_delete(GvHVn(PL_incgv),
4254 SvPVX_const(namesv),
4255 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4257 Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4258 NOT_REACHED; /* NOTREACHED */
4259 /* die_unwind() did LEAVE, or we won't be here */
4262 LEAVE_with_name("eval");
4270 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4271 close to the related Perl_create_eval_scope. */
4273 Perl_delete_eval_scope(pTHX)
4284 LEAVE_with_name("eval_scope");
4285 PERL_UNUSED_VAR(newsp);
4286 PERL_UNUSED_VAR(gimme);
4287 PERL_UNUSED_VAR(optype);
4290 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4291 also needed by Perl_fold_constants. */
4293 Perl_create_eval_scope(pTHX_ U32 flags)
4296 const I32 gimme = GIMME_V;
4298 ENTER_with_name("eval_scope");
4301 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4304 PL_in_eval = EVAL_INEVAL;
4305 if (flags & G_KEEPERR)
4306 PL_in_eval |= EVAL_KEEPERR;
4309 if (flags & G_FAKINGEVAL) {
4310 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4317 PERL_CONTEXT * const cx = create_eval_scope(0);
4318 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4319 return DOCATCH(PL_op->op_next);
4334 retop = cx->blk_eval.retop;
4336 PERL_UNUSED_VAR(optype);
4338 SP = leave_common(newsp, SP, newsp, gimme,
4339 SVs_PADTMP|SVs_TEMP, FALSE);
4340 PL_curpm = newpm; /* Don't pop $1 et al till now */
4342 LEAVE_with_name("eval_scope");
4351 const I32 gimme = GIMME_V;
4353 ENTER_with_name("given");
4356 if (PL_op->op_targ) {
4357 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4358 SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4359 PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4366 PUSHBLOCK(cx, CXt_GIVEN, SP);
4379 PERL_UNUSED_CONTEXT;
4382 assert(CxTYPE(cx) == CXt_GIVEN);
4384 SP = leave_common(newsp, SP, newsp, gimme,
4385 SVs_PADTMP|SVs_TEMP, FALSE);
4386 PL_curpm = newpm; /* Don't pop $1 et al till now */
4388 LEAVE_with_name("given");
4392 /* Helper routines used by pp_smartmatch */
4394 S_make_matcher(pTHX_ REGEXP *re)
4396 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4398 PERL_ARGS_ASSERT_MAKE_MATCHER;
4400 PM_SETRE(matcher, ReREFCNT_inc(re));
4402 SAVEFREEOP((OP *) matcher);
4403 ENTER_with_name("matcher"); SAVETMPS;
4409 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4414 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4416 PL_op = (OP *) matcher;
4419 (void) Perl_pp_match(aTHX);
4421 result = SvTRUEx(POPs);
4428 S_destroy_matcher(pTHX_ PMOP *matcher)
4430 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4431 PERL_UNUSED_ARG(matcher);
4434 LEAVE_with_name("matcher");
4437 /* Do a smart match */
4440 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4441 return do_smartmatch(NULL, NULL, 0);
4444 /* This version of do_smartmatch() implements the
4445 * table of smart matches that is found in perlsyn.
4448 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4452 bool object_on_left = FALSE;
4453 SV *e = TOPs; /* e is for 'expression' */
4454 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4456 /* Take care only to invoke mg_get() once for each argument.
4457 * Currently we do this by copying the SV if it's magical. */
4459 if (!copied && SvGMAGICAL(d))
4460 d = sv_mortalcopy(d);
4467 e = sv_mortalcopy(e);
4469 /* First of all, handle overload magic of the rightmost argument */
4472 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4473 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4475 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4482 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4485 SP -= 2; /* Pop the values */
4490 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4497 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4498 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4499 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4501 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4502 object_on_left = TRUE;
4505 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4507 if (object_on_left) {
4508 goto sm_any_sub; /* Treat objects like scalars */
4510 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4511 /* Test sub truth for each key */
4513 bool andedresults = TRUE;
4514 HV *hv = (HV*) SvRV(d);
4515 I32 numkeys = hv_iterinit(hv);
4516 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4519 while ( (he = hv_iternext(hv)) ) {
4520 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4521 ENTER_with_name("smartmatch_hash_key_test");
4524 PUSHs(hv_iterkeysv(he));
4526 c = call_sv(e, G_SCALAR);
4529 andedresults = FALSE;
4531 andedresults = SvTRUEx(POPs) && andedresults;
4533 LEAVE_with_name("smartmatch_hash_key_test");
4540 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4541 /* Test sub truth for each element */
4543 bool andedresults = TRUE;
4544 AV *av = (AV*) SvRV(d);
4545 const I32 len = av_tindex(av);
4546 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4549 for (i = 0; i <= len; ++i) {
4550 SV * const * const svp = av_fetch(av, i, FALSE);
4551 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4552 ENTER_with_name("smartmatch_array_elem_test");
4558 c = call_sv(e, G_SCALAR);
4561 andedresults = FALSE;
4563 andedresults = SvTRUEx(POPs) && andedresults;
4565 LEAVE_with_name("smartmatch_array_elem_test");
4574 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4575 ENTER_with_name("smartmatch_coderef");
4580 c = call_sv(e, G_SCALAR);
4584 else if (SvTEMP(TOPs))
4585 SvREFCNT_inc_void(TOPs);
4587 LEAVE_with_name("smartmatch_coderef");
4592 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4593 if (object_on_left) {
4594 goto sm_any_hash; /* Treat objects like scalars */
4596 else if (!SvOK(d)) {
4597 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4600 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4601 /* Check that the key-sets are identical */
4603 HV *other_hv = MUTABLE_HV(SvRV(d));
4606 U32 this_key_count = 0,
4607 other_key_count = 0;
4608 HV *hv = MUTABLE_HV(SvRV(e));
4610 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4611 /* Tied hashes don't know how many keys they have. */
4612 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4613 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4617 HV * const temp = other_hv;
4623 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4627 /* The hashes have the same number of keys, so it suffices
4628 to check that one is a subset of the other. */
4629 (void) hv_iterinit(hv);
4630 while ( (he = hv_iternext(hv)) ) {
4631 SV *key = hv_iterkeysv(he);
4633 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4636 if(!hv_exists_ent(other_hv, key, 0)) {
4637 (void) hv_iterinit(hv); /* reset iterator */
4643 (void) hv_iterinit(other_hv);
4644 while ( hv_iternext(other_hv) )
4648 other_key_count = HvUSEDKEYS(other_hv);
4650 if (this_key_count != other_key_count)
4655 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4656 AV * const other_av = MUTABLE_AV(SvRV(d));
4657 const SSize_t other_len = av_tindex(other_av) + 1;
4659 HV *hv = MUTABLE_HV(SvRV(e));
4661 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4662 for (i = 0; i < other_len; ++i) {
4663 SV ** const svp = av_fetch(other_av, i, FALSE);
4664 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4665 if (svp) { /* ??? When can this not happen? */
4666 if (hv_exists_ent(hv, *svp, 0))
4672 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4673 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4676 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4678 HV *hv = MUTABLE_HV(SvRV(e));
4680 (void) hv_iterinit(hv);
4681 while ( (he = hv_iternext(hv)) ) {
4682 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4684 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4686 (void) hv_iterinit(hv);
4687 destroy_matcher(matcher);
4692 destroy_matcher(matcher);
4698 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4699 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4706 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4707 if (object_on_left) {
4708 goto sm_any_array; /* Treat objects like scalars */
4710 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4711 AV * const other_av = MUTABLE_AV(SvRV(e));
4712 const SSize_t other_len = av_tindex(other_av) + 1;
4715 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4716 for (i = 0; i < other_len; ++i) {
4717 SV ** const svp = av_fetch(other_av, i, FALSE);
4719 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4720 if (svp) { /* ??? When can this not happen? */
4721 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4727 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4728 AV *other_av = MUTABLE_AV(SvRV(d));
4729 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4730 if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4734 const SSize_t other_len = av_tindex(other_av);
4736 if (NULL == seen_this) {
4737 seen_this = newHV();
4738 (void) sv_2mortal(MUTABLE_SV(seen_this));
4740 if (NULL == seen_other) {
4741 seen_other = newHV();
4742 (void) sv_2mortal(MUTABLE_SV(seen_other));
4744 for(i = 0; i <= other_len; ++i) {
4745 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4746 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4748 if (!this_elem || !other_elem) {
4749 if ((this_elem && SvOK(*this_elem))
4750 || (other_elem && SvOK(*other_elem)))
4753 else if (hv_exists_ent(seen_this,
4754 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4755 hv_exists_ent(seen_other,
4756 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4758 if (*this_elem != *other_elem)
4762 (void)hv_store_ent(seen_this,
4763 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4765 (void)hv_store_ent(seen_other,
4766 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4772 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4773 (void) do_smartmatch(seen_this, seen_other, 0);
4775 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4784 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4785 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4788 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4789 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4792 for(i = 0; i <= this_len; ++i) {
4793 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4794 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4796 if (svp && matcher_matches_sv(matcher, *svp)) {
4798 destroy_matcher(matcher);
4803 destroy_matcher(matcher);
4807 else if (!SvOK(d)) {
4808 /* undef ~~ array */
4809 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4812 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4813 for (i = 0; i <= this_len; ++i) {
4814 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4815 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4816 if (!svp || !SvOK(*svp))
4825 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4827 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4828 for (i = 0; i <= this_len; ++i) {
4829 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4836 /* infinite recursion isn't supposed to happen here */
4837 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4838 (void) do_smartmatch(NULL, NULL, 1);
4840 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4849 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4850 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4851 SV *t = d; d = e; e = t;
4852 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4855 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4856 SV *t = d; d = e; e = t;
4857 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4858 goto sm_regex_array;
4861 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4864 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4866 result = matcher_matches_sv(matcher, d);
4868 PUSHs(result ? &PL_sv_yes : &PL_sv_no);
4869 destroy_matcher(matcher);
4874 /* See if there is overload magic on left */
4875 else if (object_on_left && SvAMAGIC(d)) {
4877 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4878 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4881 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4889 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4892 else if (!SvOK(d)) {
4893 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4894 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4899 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4900 DEBUG_M(if (SvNIOK(e))
4901 Perl_deb(aTHX_ " applying rule Any-Num\n");
4903 Perl_deb(aTHX_ " applying rule Num-numish\n");
4905 /* numeric comparison */
4908 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4909 (void) Perl_pp_i_eq(aTHX);
4911 (void) Perl_pp_eq(aTHX);
4919 /* As a last resort, use string comparison */
4920 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4923 return Perl_pp_seq(aTHX);
4930 const I32 gimme = GIMME_V;
4932 /* This is essentially an optimization: if the match
4933 fails, we don't want to push a context and then
4934 pop it again right away, so we skip straight
4935 to the op that follows the leavewhen.
4936 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4938 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4939 RETURNOP(cLOGOP->op_other->op_next);
4941 ENTER_with_name("when");
4944 PUSHBLOCK(cx, CXt_WHEN, SP);
4959 cxix = dopoptogiven(cxstack_ix);
4961 /* diag_listed_as: Can't "when" outside a topicalizer */
4962 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
4963 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
4966 assert(CxTYPE(cx) == CXt_WHEN);
4968 SP = leave_common(newsp, SP, newsp, gimme,
4969 SVs_PADTMP|SVs_TEMP, FALSE);
4970 PL_curpm = newpm; /* pop $1 et al */
4972 LEAVE_with_name("when");
4974 if (cxix < cxstack_ix)
4977 cx = &cxstack[cxix];
4979 if (CxFOREACH(cx)) {
4980 /* clear off anything above the scope we're re-entering */
4981 I32 inner = PL_scopestack_ix;
4984 if (PL_scopestack_ix < inner)
4985 leave_scope(PL_scopestack[PL_scopestack_ix]);
4986 PL_curcop = cx->blk_oldcop;
4989 return cx->blk_loop.my_op->op_nextop;
4993 RETURNOP(cx->blk_givwhen.leave_op);
5006 PERL_UNUSED_VAR(gimme);
5008 cxix = dopoptowhen(cxstack_ix);
5010 DIE(aTHX_ "Can't \"continue\" outside a when block");
5012 if (cxix < cxstack_ix)
5016 assert(CxTYPE(cx) == CXt_WHEN);
5019 PL_curpm = newpm; /* pop $1 et al */
5021 LEAVE_with_name("when");
5022 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5030 cxix = dopoptogiven(cxstack_ix);
5032 DIE(aTHX_ "Can't \"break\" outside a given block");
5034 cx = &cxstack[cxix];
5036 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5038 if (cxix < cxstack_ix)
5041 /* Restore the sp at the time we entered the given block */
5044 return cx->blk_givwhen.leave_op;
5048 S_doparseform(pTHX_ SV *sv)
5051 char *s = SvPV(sv, len);
5053 char *base = NULL; /* start of current field */
5054 I32 skipspaces = 0; /* number of contiguous spaces seen */
5055 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5056 bool repeat = FALSE; /* ~~ seen on this line */
5057 bool postspace = FALSE; /* a text field may need right padding */
5060 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5062 bool ischop; /* it's a ^ rather than a @ */
5063 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5064 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5068 PERL_ARGS_ASSERT_DOPARSEFORM;
5071 Perl_croak(aTHX_ "Null picture in formline");
5073 if (SvTYPE(sv) >= SVt_PVMG) {
5074 /* This might, of course, still return NULL. */
5075 mg = mg_find(sv, PERL_MAGIC_fm);
5077 sv_upgrade(sv, SVt_PVMG);
5081 /* still the same as previously-compiled string? */
5082 SV *old = mg->mg_obj;
5083 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5084 && len == SvCUR(old)
5085 && strnEQ(SvPVX(old), SvPVX(sv), len)
5087 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5091 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5092 Safefree(mg->mg_ptr);
5098 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5099 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5102 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5103 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5107 /* estimate the buffer size needed */
5108 for (base = s; s <= send; s++) {
5109 if (*s == '\n' || *s == '@' || *s == '^')
5115 Newx(fops, maxops, U32);
5120 *fpc++ = FF_LINEMARK;
5121 noblank = repeat = FALSE;
5139 case ' ': case '\t':
5146 } /* else FALL THROUGH */
5154 *fpc++ = FF_LITERAL;
5162 *fpc++ = (U32)skipspaces;
5166 *fpc++ = FF_NEWLINE;
5170 arg = fpc - linepc + 1;
5177 *fpc++ = FF_LINEMARK;
5178 noblank = repeat = FALSE;
5187 ischop = s[-1] == '^';
5193 arg = (s - base) - 1;
5195 *fpc++ = FF_LITERAL;
5201 if (*s == '*') { /* @* or ^* */
5203 *fpc++ = 2; /* skip the @* or ^* */
5205 *fpc++ = FF_LINESNGL;
5208 *fpc++ = FF_LINEGLOB;
5210 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5211 arg = ischop ? FORM_NUM_BLANK : 0;
5216 const char * const f = ++s;
5219 arg |= FORM_NUM_POINT + (s - f);
5221 *fpc++ = s - base; /* fieldsize for FETCH */
5222 *fpc++ = FF_DECIMAL;
5224 unchopnum |= ! ischop;
5226 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5227 arg = ischop ? FORM_NUM_BLANK : 0;
5229 s++; /* skip the '0' first */
5233 const char * const f = ++s;
5236 arg |= FORM_NUM_POINT + (s - f);
5238 *fpc++ = s - base; /* fieldsize for FETCH */
5239 *fpc++ = FF_0DECIMAL;
5241 unchopnum |= ! ischop;
5243 else { /* text field */
5245 bool ismore = FALSE;
5248 while (*++s == '>') ;
5249 prespace = FF_SPACE;
5251 else if (*s == '|') {
5252 while (*++s == '|') ;
5253 prespace = FF_HALFSPACE;
5258 while (*++s == '<') ;
5261 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5265 *fpc++ = s - base; /* fieldsize for FETCH */
5267 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5270 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5284 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5287 mg->mg_ptr = (char *) fops;
5288 mg->mg_len = arg * sizeof(U32);
5289 mg->mg_obj = sv_copy;
5290 mg->mg_flags |= MGf_REFCOUNTED;
5292 if (unchopnum && repeat)
5293 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5300 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5302 /* Can value be printed in fldsize chars, using %*.*f ? */
5306 int intsize = fldsize - (value < 0 ? 1 : 0);
5308 if (frcsize & FORM_NUM_POINT)
5310 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5313 while (intsize--) pwr *= 10.0;
5314 while (frcsize--) eps /= 10.0;
5317 if (value + eps >= pwr)
5320 if (value - eps <= -pwr)
5327 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5329 SV * const datasv = FILTER_DATA(idx);
5330 const int filter_has_file = IoLINES(datasv);
5331 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5332 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5337 char *prune_from = NULL;
5338 bool read_from_cache = FALSE;
5342 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5344 assert(maxlen >= 0);
5347 /* I was having segfault trouble under Linux 2.2.5 after a
5348 parse error occurred. (Had to hack around it with a test
5349 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5350 not sure where the trouble is yet. XXX */
5353 SV *const cache = datasv;
5356 const char *cache_p = SvPV(cache, cache_len);
5360 /* Running in block mode and we have some cached data already.
5362 if (cache_len >= umaxlen) {
5363 /* In fact, so much data we don't even need to call
5368 const char *const first_nl =
5369 (const char *)memchr(cache_p, '\n', cache_len);
5371 take = first_nl + 1 - cache_p;
5375 sv_catpvn(buf_sv, cache_p, take);
5376 sv_chop(cache, cache_p + take);
5377 /* Definitely not EOF */
5381 sv_catsv(buf_sv, cache);
5383 umaxlen -= cache_len;
5386 read_from_cache = TRUE;
5390 /* Filter API says that the filter appends to the contents of the buffer.
5391 Usually the buffer is "", so the details don't matter. But if it's not,
5392 then clearly what it contains is already filtered by this filter, so we
5393 don't want to pass it in a second time.
5394 I'm going to use a mortal in case the upstream filter croaks. */
5395 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5396 ? sv_newmortal() : buf_sv;
5397 SvUPGRADE(upstream, SVt_PV);
5399 if (filter_has_file) {
5400 status = FILTER_READ(idx+1, upstream, 0);
5403 if (filter_sub && status >= 0) {
5407 ENTER_with_name("call_filter_sub");
5412 DEFSV_set(upstream);
5416 PUSHs(filter_state);
5419 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5429 SV * const errsv = ERRSV;
5430 if (SvTRUE_NN(errsv))
5431 err = newSVsv(errsv);
5437 LEAVE_with_name("call_filter_sub");
5440 if (SvGMAGICAL(upstream)) {
5442 if (upstream == buf_sv) mg_free(buf_sv);
5444 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5445 if(!err && SvOK(upstream)) {
5446 got_p = SvPV_nomg(upstream, got_len);
5448 if (got_len > umaxlen) {
5449 prune_from = got_p + umaxlen;
5452 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5453 if (first_nl && first_nl + 1 < got_p + got_len) {
5454 /* There's a second line here... */
5455 prune_from = first_nl + 1;
5459 if (!err && prune_from) {
5460 /* Oh. Too long. Stuff some in our cache. */
5461 STRLEN cached_len = got_p + got_len - prune_from;
5462 SV *const cache = datasv;
5465 /* Cache should be empty. */
5466 assert(!SvCUR(cache));
5469 sv_setpvn(cache, prune_from, cached_len);
5470 /* If you ask for block mode, you may well split UTF-8 characters.
5471 "If it breaks, you get to keep both parts"
5472 (Your code is broken if you don't put them back together again
5473 before something notices.) */
5474 if (SvUTF8(upstream)) {
5477 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5479 /* Cannot just use sv_setpvn, as that could free the buffer
5480 before we have a chance to assign it. */
5481 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5482 got_len - cached_len);
5484 /* Can't yet be EOF */
5489 /* If they are at EOF but buf_sv has something in it, then they may never
5490 have touched the SV upstream, so it may be undefined. If we naively
5491 concatenate it then we get a warning about use of uninitialised value.
5493 if (!err && upstream != buf_sv &&
5495 sv_catsv_nomg(buf_sv, upstream);
5497 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5500 IoLINES(datasv) = 0;
5502 SvREFCNT_dec(filter_state);
5503 IoTOP_GV(datasv) = NULL;
5506 SvREFCNT_dec(filter_sub);
5507 IoBOTTOM_GV(datasv) = NULL;
5509 filter_del(S_run_user_filter);
5515 if (status == 0 && read_from_cache) {
5516 /* If we read some data from the cache (and by getting here it implies
5517 that we emptied the cache) then we aren't yet at EOF, and mustn't
5518 report that to our caller. */
5525 * ex: set ts=8 sts=4 sw=4 et: