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);
1355 switch (cxstack[cxix].blk_gimme) {
1363 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1365 NOT_REACHED; /* NOTREACHED */
1369 Perl_is_lvalue_sub(pTHX)
1371 const I32 cxix = dopoptosub(cxstack_ix);
1372 assert(cxix >= 0); /* We should only be called from inside subs */
1374 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1375 return CxLVAL(cxstack + cxix);
1380 /* only used by PUSHSUB */
1382 Perl_was_lvalue_sub(pTHX)
1384 const I32 cxix = dopoptosub(cxstack_ix-1);
1385 assert(cxix >= 0); /* We should only be called from inside subs */
1387 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1388 return CxLVAL(cxstack + cxix);
1394 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1398 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1400 PERL_UNUSED_CONTEXT;
1403 for (i = startingblock; i >= 0; i--) {
1404 const PERL_CONTEXT * const cx = &cxstk[i];
1405 switch (CxTYPE(cx)) {
1409 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1410 * twice; the first for the normal foo() call, and the second
1411 * for a faked up re-entry into the sub to execute the
1412 * code block. Hide this faked entry from the world. */
1413 if (cx->cx_type & CXp_SUB_RE_FAKE)
1418 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1426 S_dopoptoeval(pTHX_ I32 startingblock)
1429 for (i = startingblock; i >= 0; i--) {
1430 const PERL_CONTEXT *cx = &cxstack[i];
1431 switch (CxTYPE(cx)) {
1435 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1443 S_dopoptoloop(pTHX_ I32 startingblock)
1446 for (i = startingblock; i >= 0; i--) {
1447 const PERL_CONTEXT * const cx = &cxstack[i];
1448 switch (CxTYPE(cx)) {
1454 /* diag_listed_as: Exiting subroutine via %s */
1455 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1456 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1457 if ((CxTYPE(cx)) == CXt_NULL)
1460 case CXt_LOOP_LAZYIV:
1461 case CXt_LOOP_LAZYSV:
1463 case CXt_LOOP_PLAIN:
1464 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1472 S_dopoptogiven(pTHX_ I32 startingblock)
1475 for (i = startingblock; i >= 0; i--) {
1476 const PERL_CONTEXT *cx = &cxstack[i];
1477 switch (CxTYPE(cx)) {
1481 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1483 case CXt_LOOP_PLAIN:
1484 assert(!CxFOREACHDEF(cx));
1486 case CXt_LOOP_LAZYIV:
1487 case CXt_LOOP_LAZYSV:
1489 if (CxFOREACHDEF(cx)) {
1490 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1499 S_dopoptowhen(pTHX_ I32 startingblock)
1502 for (i = startingblock; i >= 0; i--) {
1503 const PERL_CONTEXT *cx = &cxstack[i];
1504 switch (CxTYPE(cx)) {
1508 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1516 Perl_dounwind(pTHX_ I32 cxix)
1520 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1523 while (cxstack_ix > cxix) {
1525 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1526 DEBUG_CX("UNWIND"); \
1527 /* Note: we don't need to restore the base context info till the end. */
1528 switch (CxTYPE(cx)) {
1531 continue; /* not break */
1539 case CXt_LOOP_LAZYIV:
1540 case CXt_LOOP_LAZYSV:
1542 case CXt_LOOP_PLAIN:
1553 PERL_UNUSED_VAR(optype);
1557 Perl_qerror(pTHX_ SV *err)
1559 PERL_ARGS_ASSERT_QERROR;
1562 if (PL_in_eval & EVAL_KEEPERR) {
1563 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1567 sv_catsv(ERRSV, err);
1570 sv_catsv(PL_errors, err);
1572 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1574 ++PL_parser->error_count;
1578 Perl_die_unwind(pTHX_ SV *msv)
1580 SV *exceptsv = sv_mortalcopy(msv);
1581 U8 in_eval = PL_in_eval;
1582 PERL_ARGS_ASSERT_DIE_UNWIND;
1589 * Historically, perl used to set ERRSV ($@) early in the die
1590 * process and rely on it not getting clobbered during unwinding.
1591 * That sucked, because it was liable to get clobbered, so the
1592 * setting of ERRSV used to emit the exception from eval{} has
1593 * been moved to much later, after unwinding (see just before
1594 * JMPENV_JUMP below). However, some modules were relying on the
1595 * early setting, by examining $@ during unwinding to use it as
1596 * a flag indicating whether the current unwinding was caused by
1597 * an exception. It was never a reliable flag for that purpose,
1598 * being totally open to false positives even without actual
1599 * clobberage, but was useful enough for production code to
1600 * semantically rely on it.
1602 * We'd like to have a proper introspective interface that
1603 * explicitly describes the reason for whatever unwinding
1604 * operations are currently in progress, so that those modules
1605 * work reliably and $@ isn't further overloaded. But we don't
1606 * have one yet. In its absence, as a stopgap measure, ERRSV is
1607 * now *additionally* set here, before unwinding, to serve as the
1608 * (unreliable) flag that it used to.
1610 * This behaviour is temporary, and should be removed when a
1611 * proper way to detect exceptional unwinding has been developed.
1612 * As of 2010-12, the authors of modules relying on the hack
1613 * are aware of the issue, because the modules failed on
1614 * perls 5.13.{1..7} which had late setting of $@ without this
1615 * early-setting hack.
1617 if (!(in_eval & EVAL_KEEPERR)) {
1618 SvTEMP_off(exceptsv);
1619 sv_setsv(ERRSV, exceptsv);
1622 if (in_eval & EVAL_KEEPERR) {
1623 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1627 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1628 && PL_curstackinfo->si_prev)
1642 JMPENV *restartjmpenv;
1645 if (cxix < cxstack_ix)
1648 POPBLOCK(cx,PL_curpm);
1649 if (CxTYPE(cx) != CXt_EVAL) {
1651 const char* message = SvPVx_const(exceptsv, msglen);
1652 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1653 PerlIO_write(Perl_error_log, message, msglen);
1657 namesv = cx->blk_eval.old_namesv;
1659 oldcop = cx->blk_oldcop;
1661 restartjmpenv = cx->blk_eval.cur_top_env;
1662 restartop = cx->blk_eval.retop;
1664 if (gimme == G_SCALAR)
1665 *++newsp = &PL_sv_undef;
1666 PL_stack_sp = newsp;
1670 if (optype == OP_REQUIRE) {
1671 assert (PL_curcop == oldcop);
1672 (void)hv_store(GvHVn(PL_incgv),
1673 SvPVX_const(namesv),
1674 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1676 /* note that unlike pp_entereval, pp_require isn't
1677 * supposed to trap errors. So now that we've popped the
1678 * EVAL that pp_require pushed, and processed the error
1679 * message, rethrow the error */
1680 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1681 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1684 if (!(in_eval & EVAL_KEEPERR))
1685 sv_setsv(ERRSV, exceptsv);
1686 PL_restartjmpenv = restartjmpenv;
1687 PL_restartop = restartop;
1689 NOT_REACHED; /* NOTREACHED */
1693 write_to_stderr(exceptsv);
1695 NOT_REACHED; /* NOTREACHED */
1701 if (SvTRUE(left) != SvTRUE(right))
1709 =head1 CV Manipulation Functions
1711 =for apidoc caller_cx
1713 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1714 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1715 information returned to Perl by C<caller>. Note that XSUBs don't get a
1716 stack frame, so C<caller_cx(0, NULL)> will return information for the
1717 immediately-surrounding Perl code.
1719 This function skips over the automatic calls to C<&DB::sub> made on the
1720 behalf of the debugger. If the stack frame requested was a sub called by
1721 C<DB::sub>, the return value will be the frame for the call to
1722 C<DB::sub>, since that has the correct line number/etc. for the call
1723 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1724 frame for the sub call itself.
1729 const PERL_CONTEXT *
1730 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1732 I32 cxix = dopoptosub(cxstack_ix);
1733 const PERL_CONTEXT *cx;
1734 const PERL_CONTEXT *ccstack = cxstack;
1735 const PERL_SI *top_si = PL_curstackinfo;
1738 /* we may be in a higher stacklevel, so dig down deeper */
1739 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1740 top_si = top_si->si_prev;
1741 ccstack = top_si->si_cxstack;
1742 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1746 /* caller() should not report the automatic calls to &DB::sub */
1747 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1748 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1752 cxix = dopoptosub_at(ccstack, cxix - 1);
1755 cx = &ccstack[cxix];
1756 if (dbcxp) *dbcxp = cx;
1758 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1759 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1760 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1761 field below is defined for any cx. */
1762 /* caller() should not report the automatic calls to &DB::sub */
1763 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1764 cx = &ccstack[dbcxix];
1773 const PERL_CONTEXT *cx;
1774 const PERL_CONTEXT *dbcx;
1775 I32 gimme = GIMME_V;
1776 const HEK *stash_hek;
1778 bool has_arg = MAXARG && TOPs;
1787 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1789 if (gimme != G_ARRAY) {
1797 assert(CopSTASH(cx->blk_oldcop));
1798 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1799 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1801 if (gimme != G_ARRAY) {
1804 PUSHs(&PL_sv_undef);
1807 sv_sethek(TARG, stash_hek);
1816 PUSHs(&PL_sv_undef);
1819 sv_sethek(TARG, stash_hek);
1822 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1823 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1824 cx->blk_sub.retop, TRUE);
1826 lcop = cx->blk_oldcop;
1827 mPUSHi((I32)CopLINE(lcop));
1830 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1831 /* So is ccstack[dbcxix]. */
1832 if (CvHASGV(dbcx->blk_sub.cv)) {
1833 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1834 PUSHs(boolSV(CxHASARGS(cx)));
1837 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1838 PUSHs(boolSV(CxHASARGS(cx)));
1842 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1845 gimme = (I32)cx->blk_gimme;
1846 if (gimme == G_VOID)
1847 PUSHs(&PL_sv_undef);
1849 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1850 if (CxTYPE(cx) == CXt_EVAL) {
1852 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1853 SV *cur_text = cx->blk_eval.cur_text;
1854 if (SvCUR(cur_text) >= 2) {
1855 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1856 SvUTF8(cur_text)|SVs_TEMP));
1859 /* I think this is will always be "", but be sure */
1860 PUSHs(sv_2mortal(newSVsv(cur_text)));
1866 else if (cx->blk_eval.old_namesv) {
1867 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1870 /* eval BLOCK (try blocks have old_namesv == 0) */
1872 PUSHs(&PL_sv_undef);
1873 PUSHs(&PL_sv_undef);
1877 PUSHs(&PL_sv_undef);
1878 PUSHs(&PL_sv_undef);
1880 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1881 && CopSTASH_eq(PL_curcop, PL_debstash))
1883 AV * const ary = cx->blk_sub.argarray;
1884 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1886 Perl_init_dbargs(aTHX);
1888 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1889 av_extend(PL_dbargs, AvFILLp(ary) + off);
1890 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1891 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1893 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1896 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1898 if (old_warnings == pWARN_NONE)
1899 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1900 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1901 mask = &PL_sv_undef ;
1902 else if (old_warnings == pWARN_ALL ||
1903 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1904 /* Get the bit mask for $warnings::Bits{all}, because
1905 * it could have been extended by warnings::register */
1907 HV * const bits = get_hv("warnings::Bits", 0);
1908 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1909 mask = newSVsv(*bits_all);
1912 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1916 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1920 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1921 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1931 if (MAXARG < 1 || (!TOPs && !POPs))
1932 tmps = NULL, len = 0;
1934 tmps = SvPVx_const(POPs, len);
1935 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1940 /* like pp_nextstate, but used instead when the debugger is active */
1944 PL_curcop = (COP*)PL_op;
1945 TAINT_NOT; /* Each statement is presumed innocent */
1946 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1951 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1952 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
1956 const I32 gimme = G_ARRAY;
1958 GV * const gv = PL_DBgv;
1961 if (gv && isGV_with_GP(gv))
1964 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1965 DIE(aTHX_ "No DB::DB routine defined");
1967 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1968 /* don't do recursive DB::DB call */
1982 (void)(*CvXSUB(cv))(aTHX_ cv);
1988 PUSHBLOCK(cx, CXt_SUB, SP);
1990 cx->blk_sub.retop = PL_op->op_next;
1992 if (CvDEPTH(cv) >= 2) {
1993 PERL_STACK_OVERFLOW_CHECK();
1994 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1997 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1998 RETURNOP(CvSTART(cv));
2005 /* S_leave_common: Common code that many functions in this file use on
2008 /* SVs on the stack that have any of the flags passed in are left as is.
2009 Other SVs are protected via the mortals stack if lvalue is true, and
2012 Also, taintedness is cleared.
2016 S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
2017 U32 flags, bool lvalue)
2020 PERL_ARGS_ASSERT_LEAVE_COMMON;
2023 if (flags & SVs_PADTMP) {
2024 flags &= ~SVs_PADTMP;
2027 if (gimme == G_SCALAR) {
2029 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2032 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2033 : sv_mortalcopy(*SP);
2035 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2038 *++MARK = &PL_sv_undef;
2042 else if (gimme == G_ARRAY) {
2043 /* in case LEAVE wipes old return values */
2044 while (++MARK <= SP) {
2045 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2049 ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
2050 : sv_mortalcopy(*MARK);
2051 TAINT_NOT; /* Each item is independent */
2054 /* When this function was called with MARK == newsp, we reach this
2055 * point with SP == newsp. */
2065 I32 gimme = GIMME_V;
2067 ENTER_with_name("block");
2070 PUSHBLOCK(cx, CXt_BLOCK, SP);
2083 if (PL_op->op_flags & OPf_SPECIAL) {
2084 cx = &cxstack[cxstack_ix];
2085 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2090 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2092 SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
2093 PL_op->op_private & OPpLVALUE);
2094 PL_curpm = newpm; /* Don't pop $1 et al till now */
2096 LEAVE_with_name("block");
2102 S_outside_integer(pTHX_ SV *sv)
2105 const NV nv = SvNV_nomg(sv);
2106 if (Perl_isinfnan(nv))
2108 #ifdef NV_PRESERVES_UV
2109 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2112 if (nv <= (NV)IV_MIN)
2115 ((nv > (NV)UV_MAX ||
2116 SvUV_nomg(sv) > (UV)IV_MAX)))
2127 const I32 gimme = GIMME_V;
2128 void *itervar; /* location of the iteration variable */
2129 U8 cxtype = CXt_LOOP_FOR;
2131 ENTER_with_name("loop1");
2134 if (PL_op->op_targ) { /* "my" variable */
2135 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2136 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2137 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2138 SVs_PADSTALE, SVs_PADSTALE);
2140 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2142 itervar = PL_comppad;
2144 itervar = &PAD_SVl(PL_op->op_targ);
2147 else if (LIKELY(isGV(TOPs))) { /* symbol table variable */
2148 GV * const gv = MUTABLE_GV(POPs);
2149 SV** svp = &GvSV(gv);
2150 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2152 itervar = (void *)gv;
2153 save_aliased_sv(gv);
2156 SV * const sv = POPs;
2157 assert(SvTYPE(sv) == SVt_PVMG);
2158 assert(SvMAGIC(sv));
2159 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2160 itervar = (void *)sv;
2161 cxtype |= CXp_FOR_LVREF;
2164 if (PL_op->op_private & OPpITER_DEF)
2165 cxtype |= CXp_FOR_DEF;
2167 ENTER_with_name("loop2");
2169 PUSHBLOCK(cx, cxtype, SP);
2170 PUSHLOOP_FOR(cx, itervar, MARK);
2171 if (PL_op->op_flags & OPf_STACKED) {
2172 SV *maybe_ary = POPs;
2173 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2175 SV * const right = maybe_ary;
2176 if (UNLIKELY(cxtype & CXp_FOR_LVREF))
2177 DIE(aTHX_ "Assigned value is not a reference");
2180 if (RANGE_IS_NUMERIC(sv,right)) {
2181 cx->cx_type &= ~CXTYPEMASK;
2182 cx->cx_type |= CXt_LOOP_LAZYIV;
2183 /* Make sure that no-one re-orders cop.h and breaks our
2185 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2186 if (S_outside_integer(aTHX_ sv) ||
2187 S_outside_integer(aTHX_ right))
2188 DIE(aTHX_ "Range iterator outside integer range");
2189 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2190 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2192 /* for correct -Dstv display */
2193 cx->blk_oldsp = sp - PL_stack_base;
2197 cx->cx_type &= ~CXTYPEMASK;
2198 cx->cx_type |= CXt_LOOP_LAZYSV;
2199 /* Make sure that no-one re-orders cop.h and breaks our
2201 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2202 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2203 cx->blk_loop.state_u.lazysv.end = right;
2204 SvREFCNT_inc(right);
2205 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2206 /* This will do the upgrade to SVt_PV, and warn if the value
2207 is uninitialised. */
2208 (void) SvPV_nolen_const(right);
2209 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2210 to replace !SvOK() with a pointer to "". */
2212 SvREFCNT_dec(right);
2213 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2217 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2218 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2219 SvREFCNT_inc(maybe_ary);
2220 cx->blk_loop.state_u.ary.ix =
2221 (PL_op->op_private & OPpITER_REVERSED) ?
2222 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2226 else { /* iterating over items on the stack */
2227 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2228 if (PL_op->op_private & OPpITER_REVERSED) {
2229 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2232 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2243 const I32 gimme = GIMME_V;
2245 ENTER_with_name("loop1");
2247 ENTER_with_name("loop2");
2249 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2250 PUSHLOOP_PLAIN(cx, SP);
2265 assert(CxTYPE_is_LOOP(cx));
2267 newsp = PL_stack_base + cx->blk_loop.resetsp;
2269 SP = leave_common(newsp, SP, MARK, gimme, 0,
2270 PL_op->op_private & OPpLVALUE);
2273 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2274 PL_curpm = newpm; /* ... and pop $1 et al */
2276 LEAVE_with_name("loop2");
2277 LEAVE_with_name("loop1");
2283 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2284 PERL_CONTEXT *cx, PMOP *newpm)
2286 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2287 if (gimme == G_SCALAR) {
2288 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2290 const char *what = NULL;
2292 assert(MARK+1 == SP);
2293 if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
2294 !SvSMAGICAL(TOPs)) {
2296 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2297 : "a readonly value" : "a temporary";
2302 /* sub:lvalue{} will take us here. */
2311 "Can't return %s from lvalue subroutine", what
2316 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2317 if (!SvPADTMP(*SP)) {
2318 *++newsp = SvREFCNT_inc(*SP);
2323 /* FREETMPS could clobber it */
2324 SV *sv = SvREFCNT_inc(*SP);
2326 *++newsp = sv_mortalcopy(sv);
2333 ? sv_mortalcopy(*SP)
2335 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2340 *++newsp = &PL_sv_undef;
2342 if (CxLVAL(cx) & OPpDEREF) {
2345 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2349 else if (gimme == G_ARRAY) {
2350 assert (!(CxLVAL(cx) & OPpDEREF));
2351 if (ref || !CxLVAL(cx))
2352 while (++MARK <= SP)
2354 SvFLAGS(*MARK) & SVs_PADTMP
2355 ? sv_mortalcopy(*MARK)
2358 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2359 else while (++MARK <= SP) {
2360 if (*MARK != &PL_sv_undef
2361 && (SvPADTMP(*MARK) || SvREADONLY(*MARK))
2363 const bool ro = cBOOL( SvREADONLY(*MARK) );
2365 /* Might be flattened array after $#array = */
2372 /* diag_listed_as: Can't return %s from lvalue subroutine */
2374 "Can't return a %s from lvalue subroutine",
2375 ro ? "readonly value" : "temporary");
2381 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2384 PL_stack_sp = newsp;
2391 bool popsub2 = FALSE;
2392 bool clear_errsv = FALSE;
2402 const I32 cxix = dopoptosub(cxstack_ix);
2405 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2406 * sort block, which is a CXt_NULL
2409 PL_stack_base[1] = *PL_stack_sp;
2410 PL_stack_sp = PL_stack_base + 1;
2414 DIE(aTHX_ "Can't return outside a subroutine");
2416 if (cxix < cxstack_ix)
2419 if (CxMULTICALL(&cxstack[cxix])) {
2420 gimme = cxstack[cxix].blk_gimme;
2421 if (gimme == G_VOID)
2422 PL_stack_sp = PL_stack_base;
2423 else if (gimme == G_SCALAR) {
2424 PL_stack_base[1] = *PL_stack_sp;
2425 PL_stack_sp = PL_stack_base + 1;
2431 switch (CxTYPE(cx)) {
2434 lval = !!CvLVALUE(cx->blk_sub.cv);
2435 retop = cx->blk_sub.retop;
2436 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2439 if (!(PL_in_eval & EVAL_KEEPERR))
2442 namesv = cx->blk_eval.old_namesv;
2443 retop = cx->blk_eval.retop;
2446 if (optype == OP_REQUIRE &&
2447 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2449 /* Unassume the success we assumed earlier. */
2450 (void)hv_delete(GvHVn(PL_incgv),
2451 SvPVX_const(namesv),
2452 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2454 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2458 retop = cx->blk_sub.retop;
2462 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2466 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2468 if (gimme == G_SCALAR) {
2471 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2472 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2473 && !SvMAGICAL(TOPs)) {
2474 *++newsp = SvREFCNT_inc(*SP);
2479 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2481 *++newsp = sv_mortalcopy(sv);
2485 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2486 && !SvMAGICAL(*SP)) {
2490 *++newsp = sv_mortalcopy(*SP);
2493 *++newsp = sv_mortalcopy(*SP);
2496 *++newsp = &PL_sv_undef;
2498 else if (gimme == G_ARRAY) {
2499 while (++MARK <= SP) {
2500 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2501 && !SvGMAGICAL(*MARK)
2502 ? *MARK : sv_mortalcopy(*MARK);
2503 TAINT_NOT; /* Each item is independent */
2506 PL_stack_sp = newsp;
2510 /* Stack values are safe: */
2513 POPSUB(cx,sv); /* release CV and @_ ... */
2517 PL_curpm = newpm; /* ... and pop $1 et al */
2526 /* This duplicates parts of pp_leavesub, so that it can share code with
2537 if (CxMULTICALL(&cxstack[cxstack_ix]))
2541 cxstack_ix++; /* temporarily protect top context */
2545 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2548 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2550 PL_curpm = newpm; /* ... and pop $1 et al */
2553 return cx->blk_sub.retop;
2557 S_unwind_loop(pTHX_ const char * const opname)
2560 if (PL_op->op_flags & OPf_SPECIAL) {
2561 cxix = dopoptoloop(cxstack_ix);
2563 /* diag_listed_as: Can't "last" outside a loop block */
2564 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2569 const char * const label =
2570 PL_op->op_flags & OPf_STACKED
2571 ? SvPV(TOPs,label_len)
2572 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2573 const U32 label_flags =
2574 PL_op->op_flags & OPf_STACKED
2576 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2578 cxix = dopoptolabel(label, label_len, label_flags);
2580 /* diag_listed_as: Label not found for "last %s" */
2581 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2583 SVfARG(PL_op->op_flags & OPf_STACKED
2584 && !SvGMAGICAL(TOPp1s)
2586 : newSVpvn_flags(label,
2588 label_flags | SVs_TEMP)));
2590 if (cxix < cxstack_ix)
2606 S_unwind_loop(aTHX_ "last");
2609 cxstack_ix++; /* temporarily protect top context */
2610 switch (CxTYPE(cx)) {
2611 case CXt_LOOP_LAZYIV:
2612 case CXt_LOOP_LAZYSV:
2614 case CXt_LOOP_PLAIN:
2616 newsp = PL_stack_base + cx->blk_loop.resetsp;
2617 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2621 nextop = cx->blk_sub.retop;
2625 nextop = cx->blk_eval.retop;
2629 nextop = cx->blk_sub.retop;
2632 DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2636 PL_stack_sp = newsp;
2640 /* Stack values are safe: */
2642 case CXt_LOOP_LAZYIV:
2643 case CXt_LOOP_PLAIN:
2644 case CXt_LOOP_LAZYSV:
2646 POPLOOP(cx); /* release loop vars ... */
2650 POPSUB(cx,sv); /* release CV and @_ ... */
2653 PL_curpm = newpm; /* ... and pop $1 et al */
2656 PERL_UNUSED_VAR(optype);
2657 PERL_UNUSED_VAR(gimme);
2664 const I32 inner = PL_scopestack_ix;
2666 S_unwind_loop(aTHX_ "next");
2668 /* clear off anything above the scope we're re-entering, but
2669 * save the rest until after a possible continue block */
2671 if (PL_scopestack_ix < inner)
2672 leave_scope(PL_scopestack[PL_scopestack_ix]);
2673 PL_curcop = cx->blk_oldcop;
2675 return (cx)->blk_loop.my_op->op_nextop;
2680 const I32 cxix = S_unwind_loop(aTHX_ "redo");
2683 OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2685 if (redo_op->op_type == OP_ENTER) {
2686 /* pop one less context to avoid $x being freed in while (my $x..) */
2688 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2689 redo_op = redo_op->op_next;
2693 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2694 LEAVE_SCOPE(oldsave);
2696 PL_curcop = cx->blk_oldcop;
2702 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2705 static const char* const too_deep = "Target of goto is too deeply nested";
2707 PERL_ARGS_ASSERT_DOFINDLABEL;
2710 Perl_croak(aTHX_ "%s", too_deep);
2711 if (o->op_type == OP_LEAVE ||
2712 o->op_type == OP_SCOPE ||
2713 o->op_type == OP_LEAVELOOP ||
2714 o->op_type == OP_LEAVESUB ||
2715 o->op_type == OP_LEAVETRY)
2717 *ops++ = cUNOPo->op_first;
2719 Perl_croak(aTHX_ "%s", too_deep);
2722 if (o->op_flags & OPf_KIDS) {
2724 /* First try all the kids at this level, since that's likeliest. */
2725 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2726 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2727 STRLEN kid_label_len;
2728 U32 kid_label_flags;
2729 const char *kid_label = CopLABEL_len_flags(kCOP,
2730 &kid_label_len, &kid_label_flags);
2732 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2735 (const U8*)kid_label, kid_label_len,
2736 (const U8*)label, len) == 0)
2738 (const U8*)label, len,
2739 (const U8*)kid_label, kid_label_len) == 0)
2740 : ( len == kid_label_len && ((kid_label == label)
2741 || memEQ(kid_label, label, len)))))
2745 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2746 if (kid == PL_lastgotoprobe)
2748 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2751 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2752 ops[-1]->op_type == OP_DBSTATE)
2757 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2766 /* also used for: pp_dump() */
2774 #define GOTO_DEPTH 64
2775 OP *enterops[GOTO_DEPTH];
2776 const char *label = NULL;
2777 STRLEN label_len = 0;
2778 U32 label_flags = 0;
2779 const bool do_dump = (PL_op->op_type == OP_DUMP);
2780 static const char* const must_have_label = "goto must have label";
2782 if (PL_op->op_flags & OPf_STACKED) {
2783 /* goto EXPR or goto &foo */
2785 SV * const sv = POPs;
2788 /* This egregious kludge implements goto &subroutine */
2789 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2792 CV *cv = MUTABLE_CV(SvRV(sv));
2793 AV *arg = GvAV(PL_defgv);
2797 if (!CvROOT(cv) && !CvXSUB(cv)) {
2798 const GV * const gv = CvGV(cv);
2802 /* autoloaded stub? */
2803 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2805 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2807 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2808 if (autogv && (cv = GvCV(autogv)))
2810 tmpstr = sv_newmortal();
2811 gv_efullname3(tmpstr, gv, NULL);
2812 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2814 DIE(aTHX_ "Goto undefined subroutine");
2817 /* First do some returnish stuff. */
2818 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2820 cxix = dopoptosub(cxstack_ix);
2821 if (cxix < cxstack_ix) {
2824 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2830 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2831 if (CxTYPE(cx) == CXt_EVAL) {
2834 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2835 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2837 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2838 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2840 else if (CxMULTICALL(cx))
2843 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2845 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2846 AV* av = cx->blk_sub.argarray;
2848 /* abandon the original @_ if it got reified or if it is
2849 the same as the current @_ */
2850 if (AvREAL(av) || av == arg) {
2854 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2856 else CLEAR_ARGARRAY(av);
2858 /* We donate this refcount later to the callee’s pad. */
2859 SvREFCNT_inc_simple_void(arg);
2860 if (CxTYPE(cx) == CXt_SUB &&
2861 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2862 SvREFCNT_dec(cx->blk_sub.cv);
2863 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2864 LEAVE_SCOPE(oldsave);
2866 /* A destructor called during LEAVE_SCOPE could have undefined
2867 * our precious cv. See bug #99850. */
2868 if (!CvROOT(cv) && !CvXSUB(cv)) {
2869 const GV * const gv = CvGV(cv);
2872 SV * const tmpstr = sv_newmortal();
2873 gv_efullname3(tmpstr, gv, NULL);
2874 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2877 DIE(aTHX_ "Goto undefined subroutine");
2880 /* Now do some callish stuff. */
2882 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2886 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2887 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2890 PERL_UNUSED_VAR(newsp);
2891 PERL_UNUSED_VAR(gimme);
2893 /* put GvAV(defgv) back onto stack */
2895 EXTEND(SP, items+1); /* @_ could have been extended. */
2900 bool r = cBOOL(AvREAL(arg));
2901 for (index=0; index<items; index++)
2905 SV ** const svp = av_fetch(arg, index, 0);
2906 sv = svp ? *svp : NULL;
2908 else sv = AvARRAY(arg)[index];
2910 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2911 : sv_2mortal(newSVavdefelem(arg, index, 1));
2916 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2917 /* Restore old @_ */
2918 arg = GvAV(PL_defgv);
2919 GvAV(PL_defgv) = cx->blk_sub.savearray;
2923 retop = cx->blk_sub.retop;
2924 /* XS subs don't have a CxSUB, so pop it */
2925 POPBLOCK(cx, PL_curpm);
2926 /* Push a mark for the start of arglist */
2929 (void)(*CvXSUB(cv))(aTHX_ cv);
2934 PADLIST * const padlist = CvPADLIST(cv);
2935 cx->blk_sub.cv = cv;
2936 cx->blk_sub.olddepth = CvDEPTH(cv);
2939 if (CvDEPTH(cv) < 2)
2940 SvREFCNT_inc_simple_void_NN(cv);
2942 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2943 sub_crush_depth(cv);
2944 pad_push(padlist, CvDEPTH(cv));
2946 PL_curcop = cx->blk_oldcop;
2948 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2951 CX_CURPAD_SAVE(cx->blk_sub);
2953 /* cx->blk_sub.argarray has no reference count, so we
2954 need something to hang on to our argument array so
2955 that cx->blk_sub.argarray does not end up pointing
2956 to freed memory as the result of undef *_. So put
2957 it in the callee’s pad, donating our refer-
2960 SvREFCNT_dec(PAD_SVl(0));
2961 PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2964 /* GvAV(PL_defgv) might have been modified on scope
2965 exit, so restore it. */
2966 if (arg != GvAV(PL_defgv)) {
2967 AV * const av = GvAV(PL_defgv);
2968 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2972 else SvREFCNT_dec(arg);
2973 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2974 Perl_get_db_sub(aTHX_ NULL, cv);
2976 CV * const gotocv = get_cvs("DB::goto", 0);
2978 PUSHMARK( PL_stack_sp );
2979 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2984 retop = CvSTART(cv);
2985 goto putback_return;
2990 label = SvPV_nomg_const(sv, label_len);
2991 label_flags = SvUTF8(sv);
2994 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2995 /* goto LABEL or dump LABEL */
2996 label = cPVOP->op_pv;
2997 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2998 label_len = strlen(label);
3000 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
3005 OP *gotoprobe = NULL;
3006 bool leaving_eval = FALSE;
3007 bool in_block = FALSE;
3008 PERL_CONTEXT *last_eval_cx = NULL;
3012 PL_lastgotoprobe = NULL;
3014 for (ix = cxstack_ix; ix >= 0; ix--) {
3016 switch (CxTYPE(cx)) {
3018 leaving_eval = TRUE;
3019 if (!CxTRYBLOCK(cx)) {
3020 gotoprobe = (last_eval_cx ?
3021 last_eval_cx->blk_eval.old_eval_root :
3026 /* else fall through */
3027 case CXt_LOOP_LAZYIV:
3028 case CXt_LOOP_LAZYSV:
3030 case CXt_LOOP_PLAIN:
3033 gotoprobe = OpSIBLING(cx->blk_oldcop);
3039 gotoprobe = OpSIBLING(cx->blk_oldcop);
3042 gotoprobe = PL_main_root;
3045 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3046 gotoprobe = CvROOT(cx->blk_sub.cv);
3052 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3055 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3056 CxTYPE(cx), (long) ix);
3057 gotoprobe = PL_main_root;
3063 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3064 enterops, enterops + GOTO_DEPTH);
3067 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3068 sibl1->op_type == OP_UNSTACK &&
3069 (sibl2 = OpSIBLING(sibl1)))
3071 retop = dofindlabel(sibl2,
3072 label, label_len, label_flags, enterops,
3073 enterops + GOTO_DEPTH);
3078 PL_lastgotoprobe = gotoprobe;
3081 DIE(aTHX_ "Can't find label %"UTF8f,
3082 UTF8fARG(label_flags, label_len, label));
3084 /* if we're leaving an eval, check before we pop any frames
3085 that we're not going to punt, otherwise the error
3088 if (leaving_eval && *enterops && enterops[1]) {
3090 for (i = 1; enterops[i]; i++)
3091 if (enterops[i]->op_type == OP_ENTERITER)
3092 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3095 if (*enterops && enterops[1]) {
3096 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3098 deprecate("\"goto\" to jump into a construct");
3101 /* pop unwanted frames */
3103 if (ix < cxstack_ix) {
3107 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3110 oldsave = PL_scopestack[PL_scopestack_ix];
3111 LEAVE_SCOPE(oldsave);
3114 /* push wanted frames */
3116 if (*enterops && enterops[1]) {
3117 OP * const oldop = PL_op;
3118 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3119 for (; enterops[ix]; ix++) {
3120 PL_op = enterops[ix];
3121 /* Eventually we may want to stack the needed arguments
3122 * for each op. For now, we punt on the hard ones. */
3123 if (PL_op->op_type == OP_ENTERITER)
3124 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3125 PL_op->op_ppaddr(aTHX);
3133 if (!retop) retop = PL_main_start;
3135 PL_restartop = retop;
3136 PL_do_undump = TRUE;
3140 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3141 PL_do_undump = FALSE;
3159 anum = 0; (void)POPs;
3165 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3168 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3171 PL_exit_flags |= PERL_EXIT_EXPECTED;
3173 PUSHs(&PL_sv_undef);
3180 S_save_lines(pTHX_ AV *array, SV *sv)
3182 const char *s = SvPVX_const(sv);
3183 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3186 PERL_ARGS_ASSERT_SAVE_LINES;
3188 while (s && s < send) {
3190 SV * const tmpstr = newSV_type(SVt_PVMG);
3192 t = (const char *)memchr(s, '\n', send - s);
3198 sv_setpvn(tmpstr, s, t - s);
3199 av_store(array, line++, tmpstr);
3207 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3209 0 is used as continue inside eval,
3211 3 is used for a die caught by an inner eval - continue inner loop
3213 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3214 establish a local jmpenv to handle exception traps.
3219 S_docatch(pTHX_ OP *o)
3222 OP * const oldop = PL_op;
3226 assert(CATCH_GET == TRUE);
3233 assert(cxstack_ix >= 0);
3234 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3235 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3240 /* die caught by an inner eval - continue inner loop */
3241 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3242 PL_restartjmpenv = NULL;
3243 PL_op = PL_restartop;
3252 NOT_REACHED; /* NOTREACHED */
3261 =for apidoc find_runcv
3263 Locate the CV corresponding to the currently executing sub or eval.
3264 If db_seqp is non_null, skip CVs that are in the DB package and populate
3265 *db_seqp with the cop sequence number at the point that the DB:: code was
3266 entered. (This allows debuggers to eval in the scope of the breakpoint
3267 rather than in the scope of the debugger itself.)
3273 Perl_find_runcv(pTHX_ U32 *db_seqp)
3275 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3278 /* If this becomes part of the API, it might need a better name. */
3280 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3287 PL_curcop == &PL_compiling
3289 : PL_curcop->cop_seq;
3291 for (si = PL_curstackinfo; si; si = si->si_prev) {
3293 for (ix = si->si_cxix; ix >= 0; ix--) {
3294 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3296 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3297 cv = cx->blk_sub.cv;
3298 /* skip DB:: code */
3299 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3300 *db_seqp = cx->blk_oldcop->cop_seq;
3303 if (cx->cx_type & CXp_SUB_RE)
3306 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3307 cv = cx->blk_eval.cv;
3310 case FIND_RUNCV_padid_eq:
3312 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3315 case FIND_RUNCV_level_eq:
3316 if (level++ != arg) continue;
3324 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3328 /* Run yyparse() in a setjmp wrapper. Returns:
3329 * 0: yyparse() successful
3330 * 1: yyparse() failed
3334 S_try_yyparse(pTHX_ int gramtype)
3339 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3343 ret = yyparse(gramtype) ? 1 : 0;
3350 NOT_REACHED; /* NOTREACHED */
3357 /* Compile a require/do or an eval ''.
3359 * outside is the lexically enclosing CV (if any) that invoked us.
3360 * seq is the current COP scope value.
3361 * hh is the saved hints hash, if any.
3363 * Returns a bool indicating whether the compile was successful; if so,
3364 * PL_eval_start contains the first op of the compiled code; otherwise,
3367 * This function is called from two places: pp_require and pp_entereval.
3368 * These can be distinguished by whether PL_op is entereval.
3372 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3375 OP * const saveop = PL_op;
3376 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3377 COP * const oldcurcop = PL_curcop;
3378 bool in_require = (saveop->op_type == OP_REQUIRE);
3382 PL_in_eval = (in_require
3383 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3385 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3386 ? EVAL_RE_REPARSING : 0)));
3390 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3392 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3393 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3394 cxstack[cxstack_ix].blk_gimme = gimme;
3396 CvOUTSIDE_SEQ(evalcv) = seq;
3397 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3399 /* set up a scratch pad */
3401 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3402 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3405 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3407 /* make sure we compile in the right package */
3409 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3410 SAVEGENERICSV(PL_curstash);
3411 PL_curstash = (HV *)CopSTASH(PL_curcop);
3412 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3413 else SvREFCNT_inc_simple_void(PL_curstash);
3415 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3416 SAVESPTR(PL_beginav);
3417 PL_beginav = newAV();
3418 SAVEFREESV(PL_beginav);
3419 SAVESPTR(PL_unitcheckav);
3420 PL_unitcheckav = newAV();
3421 SAVEFREESV(PL_unitcheckav);
3424 ENTER_with_name("evalcomp");
3425 SAVESPTR(PL_compcv);
3428 /* try to compile it */
3430 PL_eval_root = NULL;
3431 PL_curcop = &PL_compiling;
3432 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3433 PL_in_eval |= EVAL_KEEPERR;
3440 hv_clear(GvHV(PL_hintgv));
3443 PL_hints = saveop->op_private & OPpEVAL_COPHH
3444 ? oldcurcop->cop_hints : saveop->op_targ;
3446 /* making 'use re eval' not be in scope when compiling the
3447 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3448 * infinite recursion when S_has_runtime_code() gives a false
3449 * positive: the second time round, HINT_RE_EVAL isn't set so we
3450 * don't bother calling S_has_runtime_code() */
3451 if (PL_in_eval & EVAL_RE_REPARSING)
3452 PL_hints &= ~HINT_RE_EVAL;
3455 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3456 SvREFCNT_dec(GvHV(PL_hintgv));
3457 GvHV(PL_hintgv) = hh;
3460 SAVECOMPILEWARNINGS();
3462 if (PL_dowarn & G_WARN_ALL_ON)
3463 PL_compiling.cop_warnings = pWARN_ALL ;
3464 else if (PL_dowarn & G_WARN_ALL_OFF)
3465 PL_compiling.cop_warnings = pWARN_NONE ;
3467 PL_compiling.cop_warnings = pWARN_STD ;
3470 PL_compiling.cop_warnings =
3471 DUP_WARNINGS(oldcurcop->cop_warnings);
3472 cophh_free(CopHINTHASH_get(&PL_compiling));
3473 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3474 /* The label, if present, is the first entry on the chain. So rather
3475 than writing a blank label in front of it (which involves an
3476 allocation), just use the next entry in the chain. */
3477 PL_compiling.cop_hints_hash
3478 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3479 /* Check the assumption that this removed the label. */
3480 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3483 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3486 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3488 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3489 * so honour CATCH_GET and trap it here if necessary */
3491 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3493 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3494 SV **newsp; /* Used by POPBLOCK. */
3496 I32 optype; /* Used by POPEVAL. */
3502 PERL_UNUSED_VAR(newsp);
3503 PERL_UNUSED_VAR(optype);
3505 /* note that if yystatus == 3, then the EVAL CX block has already
3506 * been popped, and various vars restored */
3508 if (yystatus != 3) {
3510 op_free(PL_eval_root);
3511 PL_eval_root = NULL;
3513 SP = PL_stack_base + POPMARK; /* pop original mark */
3514 POPBLOCK(cx,PL_curpm);
3516 namesv = cx->blk_eval.old_namesv;
3517 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3518 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3524 /* If cx is still NULL, it means that we didn't go in the
3525 * POPEVAL branch. */
3526 cx = &cxstack[cxstack_ix];
3527 assert(CxTYPE(cx) == CXt_EVAL);
3528 namesv = cx->blk_eval.old_namesv;
3530 (void)hv_store(GvHVn(PL_incgv),
3531 SvPVX_const(namesv),
3532 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3534 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3537 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3540 if (!*(SvPV_nolen_const(errsv))) {
3541 sv_setpvs(errsv, "Compilation error");
3544 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3549 LEAVE_with_name("evalcomp");
3551 CopLINE_set(&PL_compiling, 0);
3552 SAVEFREEOP(PL_eval_root);
3553 cv_forget_slab(evalcv);
3555 DEBUG_x(dump_eval());
3557 /* Register with debugger: */
3558 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3559 CV * const cv = get_cvs("DB::postponed", 0);
3563 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3565 call_sv(MUTABLE_SV(cv), G_DISCARD);
3569 if (PL_unitcheckav) {
3570 OP *es = PL_eval_start;
3571 call_list(PL_scopestack_ix, PL_unitcheckav);
3575 /* compiled okay, so do it */
3577 CvDEPTH(evalcv) = 1;
3578 SP = PL_stack_base + POPMARK; /* pop original mark */
3579 PL_op = saveop; /* The caller may need it. */
3580 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3587 S_check_type_and_open(pTHX_ SV *name)
3592 const char *p = SvPV_const(name, len);
3595 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3597 /* checking here captures a reasonable error message when
3598 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3599 * user gets a confusing message about looking for the .pmc file
3600 * rather than for the .pm file.
3601 * This check prevents a \0 in @INC causing problems.
3603 if (!IS_SAFE_PATHNAME(p, len, "require"))
3606 /* on Win32 stat is expensive (it does an open() and close() twice and
3607 a couple other IO calls), the open will fail with a dir on its own with
3608 errno EACCES, so only do a stat to separate a dir from a real EACCES
3609 caused by user perms */
3611 /* we use the value of errno later to see how stat() or open() failed.
3612 * We don't want it set if the stat succeeded but we still failed,
3613 * such as if the name exists, but is a directory */
3616 st_rc = PerlLIO_stat(p, &st);
3618 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3623 #if !defined(PERLIO_IS_STDIO)
3624 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3626 retio = PerlIO_open(p, PERL_SCRIPT_MODE);
3629 /* EACCES stops the INC search early in pp_require to implement
3630 feature RT #113422 */
3631 if(!retio && errno == EACCES) { /* exists but probably a directory */
3633 st_rc = PerlLIO_stat(p, &st);
3635 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3646 #ifndef PERL_DISABLE_PMC
3648 S_doopen_pm(pTHX_ SV *name)
3651 const char *p = SvPV_const(name, namelen);
3653 PERL_ARGS_ASSERT_DOOPEN_PM;
3655 /* check the name before trying for the .pmc name to avoid the
3656 * warning referring to the .pmc which the user probably doesn't
3657 * know or care about
3659 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3662 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3663 SV *const pmcsv = sv_newmortal();
3666 SvSetSV_nosteal(pmcsv,name);
3667 sv_catpvs(pmcsv, "c");
3669 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3670 return check_type_and_open(pmcsv);
3672 return check_type_and_open(name);
3675 # define doopen_pm(name) check_type_and_open(name)
3676 #endif /* !PERL_DISABLE_PMC */
3678 /* require doesn't search for absolute names, or when the name is
3679 explicitly relative the current directory */
3680 PERL_STATIC_INLINE bool
3681 S_path_is_searchable(const char *name)
3683 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3685 if (PERL_FILE_IS_ABSOLUTE(name)
3687 || (*name == '.' && ((name[1] == '/' ||
3688 (name[1] == '.' && name[2] == '/'))
3689 || (name[1] == '\\' ||
3690 ( name[1] == '.' && name[2] == '\\')))
3693 || (*name == '.' && (name[1] == '/' ||
3694 (name[1] == '.' && name[2] == '/')))
3705 /* also used for: pp_dofile() */
3717 int vms_unixname = 0;
3720 const char *tryname = NULL;
3722 const I32 gimme = GIMME_V;
3723 int filter_has_file = 0;
3724 PerlIO *tryrsfp = NULL;
3725 SV *filter_cache = NULL;
3726 SV *filter_state = NULL;
3727 SV *filter_sub = NULL;
3731 bool path_searchable;
3735 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3736 sv = sv_2mortal(new_version(sv));
3737 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3738 upg_version(PL_patchlevel, TRUE);
3739 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3740 if ( vcmp(sv,PL_patchlevel) <= 0 )
3741 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3742 SVfARG(sv_2mortal(vnormal(sv))),
3743 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3747 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3750 SV * const req = SvRV(sv);
3751 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3753 /* get the left hand term */
3754 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3756 first = SvIV(*av_fetch(lav,0,0));
3757 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3758 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3759 || av_tindex(lav) > 1 /* FP with > 3 digits */
3760 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3762 DIE(aTHX_ "Perl %"SVf" required--this is only "
3764 SVfARG(sv_2mortal(vnormal(req))),
3765 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3768 else { /* probably 'use 5.10' or 'use 5.8' */
3772 if (av_tindex(lav)>=1)
3773 second = SvIV(*av_fetch(lav,1,0));
3775 second /= second >= 600 ? 100 : 10;
3776 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3777 (int)first, (int)second);
3778 upg_version(hintsv, TRUE);
3780 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3781 "--this is only %"SVf", stopped",
3782 SVfARG(sv_2mortal(vnormal(req))),
3783 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3784 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3793 DIE(aTHX_ "Missing or undefined argument to require");
3794 name = SvPV_nomg_const(sv, len);
3795 if (!(name && len > 0 && *name))
3796 DIE(aTHX_ "Missing or undefined argument to require");
3798 if (!IS_SAFE_PATHNAME(name, len, "require")) {
3799 DIE(aTHX_ "Can't locate %s: %s",
3800 pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3801 SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3804 TAINT_PROPER("require");
3806 path_searchable = path_is_searchable(name);
3809 /* The key in the %ENV hash is in the syntax of file passed as the argument
3810 * usually this is in UNIX format, but sometimes in VMS format, which
3811 * can result in a module being pulled in more than once.
3812 * To prevent this, the key must be stored in UNIX format if the VMS
3813 * name can be translated to UNIX.
3817 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3819 unixlen = strlen(unixname);
3825 /* if not VMS or VMS name can not be translated to UNIX, pass it
3828 unixname = (char *) name;
3831 if (PL_op->op_type == OP_REQUIRE) {
3832 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3833 unixname, unixlen, 0);
3835 if (*svp != &PL_sv_undef)
3838 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3839 "Compilation failed in require", unixname);
3843 LOADING_FILE_PROBE(unixname);
3845 /* prepare to compile file */
3847 if (!path_searchable) {
3848 /* At this point, name is SvPVX(sv) */
3850 tryrsfp = doopen_pm(sv);
3852 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3853 AV * const ar = GvAVn(PL_incgv);
3860 namesv = newSV_type(SVt_PV);
3861 for (i = 0; i <= AvFILL(ar); i++) {
3862 SV * const dirsv = *av_fetch(ar, i, TRUE);
3870 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3871 && !SvOBJECT(SvRV(loader)))
3873 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3877 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3878 PTR2UV(SvRV(dirsv)), name);
3879 tryname = SvPVX_const(namesv);
3882 if (SvPADTMP(nsv)) {
3883 nsv = sv_newmortal();
3884 SvSetSV_nosteal(nsv,sv);
3887 ENTER_with_name("call_INC");
3895 if (SvGMAGICAL(loader)) {
3896 SV *l = sv_newmortal();
3897 sv_setsv_nomg(l, loader);
3900 if (sv_isobject(loader))
3901 count = call_method("INC", G_ARRAY);
3903 count = call_sv(loader, G_ARRAY);
3913 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3914 && !isGV_with_GP(SvRV(arg))) {
3915 filter_cache = SvRV(arg);
3922 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3926 if (isGV_with_GP(arg)) {
3927 IO * const io = GvIO((const GV *)arg);
3932 tryrsfp = IoIFP(io);
3933 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3934 PerlIO_close(IoOFP(io));
3945 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3947 SvREFCNT_inc_simple_void_NN(filter_sub);
3950 filter_state = SP[i];
3951 SvREFCNT_inc_simple_void(filter_state);
3955 if (!tryrsfp && (filter_cache || filter_sub)) {
3956 tryrsfp = PerlIO_open(BIT_BUCKET,
3962 /* FREETMPS may free our filter_cache */
3963 SvREFCNT_inc_simple_void(filter_cache);
3967 LEAVE_with_name("call_INC");
3969 /* Now re-mortalize it. */
3970 sv_2mortal(filter_cache);
3972 /* Adjust file name if the hook has set an %INC entry.
3973 This needs to happen after the FREETMPS above. */
3974 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3976 tryname = SvPV_nolen_const(*svp);
3983 filter_has_file = 0;
3984 filter_cache = NULL;
3986 SvREFCNT_dec_NN(filter_state);
3987 filter_state = NULL;
3990 SvREFCNT_dec_NN(filter_sub);
3995 if (path_searchable) {
4000 dir = SvPV_nomg_const(dirsv, dirlen);
4006 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
4010 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4013 sv_setpv(namesv, unixdir);
4014 sv_catpv(namesv, unixname);
4016 # ifdef __SYMBIAN32__
4017 if (PL_origfilename[0] &&
4018 PL_origfilename[1] == ':' &&
4019 !(dir[0] && dir[1] == ':'))
4020 Perl_sv_setpvf(aTHX_ namesv,
4025 Perl_sv_setpvf(aTHX_ namesv,
4029 /* The equivalent of
4030 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4031 but without the need to parse the format string, or
4032 call strlen on either pointer, and with the correct
4033 allocation up front. */
4035 char *tmp = SvGROW(namesv, dirlen + len + 2);
4037 memcpy(tmp, dir, dirlen);
4040 /* Avoid '<dir>//<file>' */
4041 if (!dirlen || *(tmp-1) != '/') {
4044 /* So SvCUR_set reports the correct length below */
4048 /* name came from an SV, so it will have a '\0' at the
4049 end that we can copy as part of this memcpy(). */
4050 memcpy(tmp, name, len + 1);
4052 SvCUR_set(namesv, dirlen + len + 1);
4057 TAINT_PROPER("require");
4058 tryname = SvPVX_const(namesv);
4059 tryrsfp = doopen_pm(namesv);
4061 if (tryname[0] == '.' && tryname[1] == '/') {
4063 while (*++tryname == '/') {}
4067 else if (errno == EMFILE || errno == EACCES) {
4068 /* no point in trying other paths if out of handles;
4069 * on the other hand, if we couldn't open one of the
4070 * files, then going on with the search could lead to
4071 * unexpected results; see perl #113422
4080 saved_errno = errno; /* sv_2mortal can realloc things */
4083 if (PL_op->op_type == OP_REQUIRE) {
4084 if(saved_errno == EMFILE || saved_errno == EACCES) {
4085 /* diag_listed_as: Can't locate %s */
4086 DIE(aTHX_ "Can't locate %s: %s: %s",
4087 name, tryname, Strerror(saved_errno));
4089 if (namesv) { /* did we lookup @INC? */
4090 AV * const ar = GvAVn(PL_incgv);
4092 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4093 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4094 for (i = 0; i <= AvFILL(ar); i++) {
4095 sv_catpvs(inc, " ");
4096 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4098 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4099 const char *c, *e = name + len - 3;
4100 sv_catpv(msg, " (you may need to install the ");
4101 for (c = name; c < e; c++) {
4103 sv_catpvs(msg, "::");
4106 sv_catpvn(msg, c, 1);
4109 sv_catpv(msg, " module)");
4111 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4112 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4114 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4115 sv_catpv(msg, " (did you run h2ph?)");
4118 /* diag_listed_as: Can't locate %s */
4120 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4124 DIE(aTHX_ "Can't locate %s", name);
4131 SETERRNO(0, SS_NORMAL);
4133 /* Assume success here to prevent recursive requirement. */
4134 /* name is never assigned to again, so len is still strlen(name) */
4135 /* Check whether a hook in @INC has already filled %INC */
4137 (void)hv_store(GvHVn(PL_incgv),
4138 unixname, unixlen, newSVpv(tryname,0),0);
4140 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4142 (void)hv_store(GvHVn(PL_incgv),
4143 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4146 ENTER_with_name("eval");
4148 SAVECOPFILE_FREE(&PL_compiling);
4149 CopFILE_set(&PL_compiling, tryname);
4150 lex_start(NULL, tryrsfp, 0);
4152 if (filter_sub || filter_cache) {
4153 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4154 than hanging another SV from it. In turn, filter_add() optionally
4155 takes the SV to use as the filter (or creates a new SV if passed
4156 NULL), so simply pass in whatever value filter_cache has. */
4157 SV * const fc = filter_cache ? newSV(0) : NULL;
4159 if (fc) sv_copypv(fc, filter_cache);
4160 datasv = filter_add(S_run_user_filter, fc);
4161 IoLINES(datasv) = filter_has_file;
4162 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4163 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4166 /* switch to eval mode */
4167 PUSHBLOCK(cx, CXt_EVAL, SP);
4169 cx->blk_eval.retop = PL_op->op_next;
4171 SAVECOPLINE(&PL_compiling);
4172 CopLINE_set(&PL_compiling, 0);
4176 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4177 op = DOCATCH(PL_eval_start);
4179 op = PL_op->op_next;
4181 LOADED_FILE_PROBE(unixname);
4186 /* This is a op added to hold the hints hash for
4187 pp_entereval. The hash can be modified by the code
4188 being eval'ed, so we return a copy instead. */
4193 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4203 const I32 gimme = GIMME_V;
4204 const U32 was = PL_breakable_sub_gen;
4205 char tbuf[TYPE_DIGITS(long) + 12];
4206 bool saved_delete = FALSE;
4207 char *tmpbuf = tbuf;
4210 U32 seq, lex_flags = 0;
4211 HV *saved_hh = NULL;
4212 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4214 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4215 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4217 else if (PL_hints & HINT_LOCALIZE_HH || (
4218 PL_op->op_private & OPpEVAL_COPHH
4219 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4221 saved_hh = cop_hints_2hv(PL_curcop, 0);
4222 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4226 /* make sure we've got a plain PV (no overload etc) before testing
4227 * for taint. Making a copy here is probably overkill, but better
4228 * safe than sorry */
4230 const char * const p = SvPV_const(sv, len);
4232 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4233 lex_flags |= LEX_START_COPIED;
4235 if (bytes && SvUTF8(sv))
4236 SvPVbyte_force(sv, len);
4238 else if (bytes && SvUTF8(sv)) {
4239 /* Don't modify someone else's scalar */
4242 (void)sv_2mortal(sv);
4243 SvPVbyte_force(sv,len);
4244 lex_flags |= LEX_START_COPIED;
4247 TAINT_IF(SvTAINTED(sv));
4248 TAINT_PROPER("eval");
4250 ENTER_with_name("eval");
4251 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4252 ? LEX_IGNORE_UTF8_HINTS
4253 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4258 /* switch to eval mode */
4260 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4261 SV * const temp_sv = sv_newmortal();
4262 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4263 (unsigned long)++PL_evalseq,
4264 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4265 tmpbuf = SvPVX(temp_sv);
4266 len = SvCUR(temp_sv);
4269 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4270 SAVECOPFILE_FREE(&PL_compiling);
4271 CopFILE_set(&PL_compiling, tmpbuf+2);
4272 SAVECOPLINE(&PL_compiling);
4273 CopLINE_set(&PL_compiling, 1);
4274 /* special case: an eval '' executed within the DB package gets lexically
4275 * placed in the first non-DB CV rather than the current CV - this
4276 * allows the debugger to execute code, find lexicals etc, in the
4277 * scope of the code being debugged. Passing &seq gets find_runcv
4278 * to do the dirty work for us */
4279 runcv = find_runcv(&seq);
4281 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4283 cx->blk_eval.retop = PL_op->op_next;
4285 /* prepare to compile string */
4287 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4288 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4290 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4291 deleting the eval's FILEGV from the stash before gv_check() runs
4292 (i.e. before run-time proper). To work around the coredump that
4293 ensues, we always turn GvMULTI_on for any globals that were
4294 introduced within evals. See force_ident(). GSAR 96-10-12 */
4295 char *const safestr = savepvn(tmpbuf, len);
4296 SAVEDELETE(PL_defstash, safestr, len);
4297 saved_delete = TRUE;
4302 if (doeval(gimme, runcv, seq, saved_hh)) {
4303 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4304 ? (PERLDB_LINE || PERLDB_SAVESRC)
4305 : PERLDB_SAVESRC_NOSUBS) {
4306 /* Retain the filegv we created. */
4307 } else if (!saved_delete) {
4308 char *const safestr = savepvn(tmpbuf, len);
4309 SAVEDELETE(PL_defstash, safestr, len);
4311 return DOCATCH(PL_eval_start);
4313 /* We have already left the scope set up earlier thanks to the LEAVE
4315 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4316 ? (PERLDB_LINE || PERLDB_SAVESRC)
4317 : PERLDB_SAVESRC_INVALID) {
4318 /* Retain the filegv we created. */
4319 } else if (!saved_delete) {
4320 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4322 return PL_op->op_next;
4334 const U8 save_flags = PL_op -> op_flags;
4342 namesv = cx->blk_eval.old_namesv;
4343 retop = cx->blk_eval.retop;
4344 evalcv = cx->blk_eval.cv;
4346 SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
4347 gimme, SVs_TEMP, FALSE);
4348 PL_curpm = newpm; /* Don't pop $1 et al till now */
4351 assert(CvDEPTH(evalcv) == 1);
4353 CvDEPTH(evalcv) = 0;
4355 if (optype == OP_REQUIRE &&
4356 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4358 /* Unassume the success we assumed earlier. */
4359 (void)hv_delete(GvHVn(PL_incgv),
4360 SvPVX_const(namesv),
4361 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4363 Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4364 NOT_REACHED; /* NOTREACHED */
4365 /* die_unwind() did LEAVE, or we won't be here */
4368 LEAVE_with_name("eval");
4369 if (!(save_flags & OPf_SPECIAL)) {
4377 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4378 close to the related Perl_create_eval_scope. */
4380 Perl_delete_eval_scope(pTHX)
4391 LEAVE_with_name("eval_scope");
4392 PERL_UNUSED_VAR(newsp);
4393 PERL_UNUSED_VAR(gimme);
4394 PERL_UNUSED_VAR(optype);
4397 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4398 also needed by Perl_fold_constants. */
4400 Perl_create_eval_scope(pTHX_ U32 flags)
4403 const I32 gimme = GIMME_V;
4405 ENTER_with_name("eval_scope");
4408 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4411 PL_in_eval = EVAL_INEVAL;
4412 if (flags & G_KEEPERR)
4413 PL_in_eval |= EVAL_KEEPERR;
4416 if (flags & G_FAKINGEVAL) {
4417 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4424 PERL_CONTEXT * const cx = create_eval_scope(0);
4425 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4426 return DOCATCH(PL_op->op_next);
4441 PERL_UNUSED_VAR(optype);
4443 SP = leave_common(newsp, SP, newsp, gimme,
4444 SVs_PADTMP|SVs_TEMP, FALSE);
4445 PL_curpm = newpm; /* Don't pop $1 et al till now */
4447 LEAVE_with_name("eval_scope");
4456 const I32 gimme = GIMME_V;
4458 ENTER_with_name("given");
4461 if (PL_op->op_targ) {
4462 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4463 SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4464 PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4471 PUSHBLOCK(cx, CXt_GIVEN, SP);
4484 PERL_UNUSED_CONTEXT;
4487 assert(CxTYPE(cx) == CXt_GIVEN);
4489 SP = leave_common(newsp, SP, newsp, gimme,
4490 SVs_PADTMP|SVs_TEMP, FALSE);
4491 PL_curpm = newpm; /* Don't pop $1 et al till now */
4493 LEAVE_with_name("given");
4497 /* Helper routines used by pp_smartmatch */
4499 S_make_matcher(pTHX_ REGEXP *re)
4501 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4503 PERL_ARGS_ASSERT_MAKE_MATCHER;
4505 PM_SETRE(matcher, ReREFCNT_inc(re));
4507 SAVEFREEOP((OP *) matcher);
4508 ENTER_with_name("matcher"); SAVETMPS;
4514 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4519 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4521 PL_op = (OP *) matcher;
4524 (void) Perl_pp_match(aTHX);
4526 result = SvTRUEx(POPs);
4533 S_destroy_matcher(pTHX_ PMOP *matcher)
4535 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4536 PERL_UNUSED_ARG(matcher);
4539 LEAVE_with_name("matcher");
4542 /* Do a smart match */
4545 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4546 return do_smartmatch(NULL, NULL, 0);
4549 /* This version of do_smartmatch() implements the
4550 * table of smart matches that is found in perlsyn.
4553 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4557 bool object_on_left = FALSE;
4558 SV *e = TOPs; /* e is for 'expression' */
4559 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4561 /* Take care only to invoke mg_get() once for each argument.
4562 * Currently we do this by copying the SV if it's magical. */
4564 if (!copied && SvGMAGICAL(d))
4565 d = sv_mortalcopy(d);
4572 e = sv_mortalcopy(e);
4574 /* First of all, handle overload magic of the rightmost argument */
4577 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4578 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4580 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4587 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4590 SP -= 2; /* Pop the values */
4595 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4602 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4603 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4604 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4606 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4607 object_on_left = TRUE;
4610 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4612 if (object_on_left) {
4613 goto sm_any_sub; /* Treat objects like scalars */
4615 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4616 /* Test sub truth for each key */
4618 bool andedresults = TRUE;
4619 HV *hv = (HV*) SvRV(d);
4620 I32 numkeys = hv_iterinit(hv);
4621 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4624 while ( (he = hv_iternext(hv)) ) {
4625 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4626 ENTER_with_name("smartmatch_hash_key_test");
4629 PUSHs(hv_iterkeysv(he));
4631 c = call_sv(e, G_SCALAR);
4634 andedresults = FALSE;
4636 andedresults = SvTRUEx(POPs) && andedresults;
4638 LEAVE_with_name("smartmatch_hash_key_test");
4645 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4646 /* Test sub truth for each element */
4648 bool andedresults = TRUE;
4649 AV *av = (AV*) SvRV(d);
4650 const I32 len = av_tindex(av);
4651 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4654 for (i = 0; i <= len; ++i) {
4655 SV * const * const svp = av_fetch(av, i, FALSE);
4656 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4657 ENTER_with_name("smartmatch_array_elem_test");
4663 c = call_sv(e, G_SCALAR);
4666 andedresults = FALSE;
4668 andedresults = SvTRUEx(POPs) && andedresults;
4670 LEAVE_with_name("smartmatch_array_elem_test");
4679 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4680 ENTER_with_name("smartmatch_coderef");
4685 c = call_sv(e, G_SCALAR);
4689 else if (SvTEMP(TOPs))
4690 SvREFCNT_inc_void(TOPs);
4692 LEAVE_with_name("smartmatch_coderef");
4697 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4698 if (object_on_left) {
4699 goto sm_any_hash; /* Treat objects like scalars */
4701 else if (!SvOK(d)) {
4702 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4705 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4706 /* Check that the key-sets are identical */
4708 HV *other_hv = MUTABLE_HV(SvRV(d));
4711 U32 this_key_count = 0,
4712 other_key_count = 0;
4713 HV *hv = MUTABLE_HV(SvRV(e));
4715 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4716 /* Tied hashes don't know how many keys they have. */
4717 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4718 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4722 HV * const temp = other_hv;
4728 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4732 /* The hashes have the same number of keys, so it suffices
4733 to check that one is a subset of the other. */
4734 (void) hv_iterinit(hv);
4735 while ( (he = hv_iternext(hv)) ) {
4736 SV *key = hv_iterkeysv(he);
4738 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4741 if(!hv_exists_ent(other_hv, key, 0)) {
4742 (void) hv_iterinit(hv); /* reset iterator */
4748 (void) hv_iterinit(other_hv);
4749 while ( hv_iternext(other_hv) )
4753 other_key_count = HvUSEDKEYS(other_hv);
4755 if (this_key_count != other_key_count)
4760 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4761 AV * const other_av = MUTABLE_AV(SvRV(d));
4762 const SSize_t other_len = av_tindex(other_av) + 1;
4764 HV *hv = MUTABLE_HV(SvRV(e));
4766 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4767 for (i = 0; i < other_len; ++i) {
4768 SV ** const svp = av_fetch(other_av, i, FALSE);
4769 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4770 if (svp) { /* ??? When can this not happen? */
4771 if (hv_exists_ent(hv, *svp, 0))
4777 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4778 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4781 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4783 HV *hv = MUTABLE_HV(SvRV(e));
4785 (void) hv_iterinit(hv);
4786 while ( (he = hv_iternext(hv)) ) {
4787 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4789 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4791 (void) hv_iterinit(hv);
4792 destroy_matcher(matcher);
4797 destroy_matcher(matcher);
4803 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4804 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4811 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4812 if (object_on_left) {
4813 goto sm_any_array; /* Treat objects like scalars */
4815 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4816 AV * const other_av = MUTABLE_AV(SvRV(e));
4817 const SSize_t other_len = av_tindex(other_av) + 1;
4820 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4821 for (i = 0; i < other_len; ++i) {
4822 SV ** const svp = av_fetch(other_av, i, FALSE);
4824 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4825 if (svp) { /* ??? When can this not happen? */
4826 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4832 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4833 AV *other_av = MUTABLE_AV(SvRV(d));
4834 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4835 if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4839 const SSize_t other_len = av_tindex(other_av);
4841 if (NULL == seen_this) {
4842 seen_this = newHV();
4843 (void) sv_2mortal(MUTABLE_SV(seen_this));
4845 if (NULL == seen_other) {
4846 seen_other = newHV();
4847 (void) sv_2mortal(MUTABLE_SV(seen_other));
4849 for(i = 0; i <= other_len; ++i) {
4850 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4851 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4853 if (!this_elem || !other_elem) {
4854 if ((this_elem && SvOK(*this_elem))
4855 || (other_elem && SvOK(*other_elem)))
4858 else if (hv_exists_ent(seen_this,
4859 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4860 hv_exists_ent(seen_other,
4861 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4863 if (*this_elem != *other_elem)
4867 (void)hv_store_ent(seen_this,
4868 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4870 (void)hv_store_ent(seen_other,
4871 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4877 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4878 (void) do_smartmatch(seen_this, seen_other, 0);
4880 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4889 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4890 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4893 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4894 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4897 for(i = 0; i <= this_len; ++i) {
4898 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4899 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4901 if (svp && matcher_matches_sv(matcher, *svp)) {
4903 destroy_matcher(matcher);
4908 destroy_matcher(matcher);
4912 else if (!SvOK(d)) {
4913 /* undef ~~ array */
4914 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4917 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4918 for (i = 0; i <= this_len; ++i) {
4919 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4920 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4921 if (!svp || !SvOK(*svp))
4930 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4932 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4933 for (i = 0; i <= this_len; ++i) {
4934 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4941 /* infinite recursion isn't supposed to happen here */
4942 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4943 (void) do_smartmatch(NULL, NULL, 1);
4945 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4954 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4955 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4956 SV *t = d; d = e; e = t;
4957 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4960 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4961 SV *t = d; d = e; e = t;
4962 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4963 goto sm_regex_array;
4966 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4969 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4971 result = matcher_matches_sv(matcher, d);
4973 PUSHs(result ? &PL_sv_yes : &PL_sv_no);
4974 destroy_matcher(matcher);
4979 /* See if there is overload magic on left */
4980 else if (object_on_left && SvAMAGIC(d)) {
4982 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4983 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4986 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4994 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4997 else if (!SvOK(d)) {
4998 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4999 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
5004 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
5005 DEBUG_M(if (SvNIOK(e))
5006 Perl_deb(aTHX_ " applying rule Any-Num\n");
5008 Perl_deb(aTHX_ " applying rule Num-numish\n");
5010 /* numeric comparison */
5013 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
5014 (void) Perl_pp_i_eq(aTHX);
5016 (void) Perl_pp_eq(aTHX);
5024 /* As a last resort, use string comparison */
5025 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
5028 return Perl_pp_seq(aTHX);
5035 const I32 gimme = GIMME_V;
5037 /* This is essentially an optimization: if the match
5038 fails, we don't want to push a context and then
5039 pop it again right away, so we skip straight
5040 to the op that follows the leavewhen.
5041 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5043 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
5044 RETURNOP(cLOGOP->op_other->op_next);
5046 ENTER_with_name("when");
5049 PUSHBLOCK(cx, CXt_WHEN, SP);
5064 cxix = dopoptogiven(cxstack_ix);
5066 /* diag_listed_as: Can't "when" outside a topicalizer */
5067 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5068 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5071 assert(CxTYPE(cx) == CXt_WHEN);
5073 SP = leave_common(newsp, SP, newsp, gimme,
5074 SVs_PADTMP|SVs_TEMP, FALSE);
5075 PL_curpm = newpm; /* pop $1 et al */
5077 LEAVE_with_name("when");
5079 if (cxix < cxstack_ix)
5082 cx = &cxstack[cxix];
5084 if (CxFOREACH(cx)) {
5085 /* clear off anything above the scope we're re-entering */
5086 I32 inner = PL_scopestack_ix;
5089 if (PL_scopestack_ix < inner)
5090 leave_scope(PL_scopestack[PL_scopestack_ix]);
5091 PL_curcop = cx->blk_oldcop;
5094 return cx->blk_loop.my_op->op_nextop;
5098 RETURNOP(cx->blk_givwhen.leave_op);
5111 PERL_UNUSED_VAR(gimme);
5113 cxix = dopoptowhen(cxstack_ix);
5115 DIE(aTHX_ "Can't \"continue\" outside a when block");
5117 if (cxix < cxstack_ix)
5121 assert(CxTYPE(cx) == CXt_WHEN);
5124 PL_curpm = newpm; /* pop $1 et al */
5126 LEAVE_with_name("when");
5127 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5135 cxix = dopoptogiven(cxstack_ix);
5137 DIE(aTHX_ "Can't \"break\" outside a given block");
5139 cx = &cxstack[cxix];
5141 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5143 if (cxix < cxstack_ix)
5146 /* Restore the sp at the time we entered the given block */
5149 return cx->blk_givwhen.leave_op;
5153 S_doparseform(pTHX_ SV *sv)
5156 char *s = SvPV(sv, len);
5158 char *base = NULL; /* start of current field */
5159 I32 skipspaces = 0; /* number of contiguous spaces seen */
5160 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5161 bool repeat = FALSE; /* ~~ seen on this line */
5162 bool postspace = FALSE; /* a text field may need right padding */
5165 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5167 bool ischop; /* it's a ^ rather than a @ */
5168 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5169 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5173 PERL_ARGS_ASSERT_DOPARSEFORM;
5176 Perl_croak(aTHX_ "Null picture in formline");
5178 if (SvTYPE(sv) >= SVt_PVMG) {
5179 /* This might, of course, still return NULL. */
5180 mg = mg_find(sv, PERL_MAGIC_fm);
5182 sv_upgrade(sv, SVt_PVMG);
5186 /* still the same as previously-compiled string? */
5187 SV *old = mg->mg_obj;
5188 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5189 && len == SvCUR(old)
5190 && strnEQ(SvPVX(old), SvPVX(sv), len)
5192 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5196 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5197 Safefree(mg->mg_ptr);
5203 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5204 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5207 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5208 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5212 /* estimate the buffer size needed */
5213 for (base = s; s <= send; s++) {
5214 if (*s == '\n' || *s == '@' || *s == '^')
5220 Newx(fops, maxops, U32);
5225 *fpc++ = FF_LINEMARK;
5226 noblank = repeat = FALSE;
5244 case ' ': case '\t':
5251 } /* else FALL THROUGH */
5259 *fpc++ = FF_LITERAL;
5267 *fpc++ = (U32)skipspaces;
5271 *fpc++ = FF_NEWLINE;
5275 arg = fpc - linepc + 1;
5282 *fpc++ = FF_LINEMARK;
5283 noblank = repeat = FALSE;
5292 ischop = s[-1] == '^';
5298 arg = (s - base) - 1;
5300 *fpc++ = FF_LITERAL;
5306 if (*s == '*') { /* @* or ^* */
5308 *fpc++ = 2; /* skip the @* or ^* */
5310 *fpc++ = FF_LINESNGL;
5313 *fpc++ = FF_LINEGLOB;
5315 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5316 arg = ischop ? FORM_NUM_BLANK : 0;
5321 const char * const f = ++s;
5324 arg |= FORM_NUM_POINT + (s - f);
5326 *fpc++ = s - base; /* fieldsize for FETCH */
5327 *fpc++ = FF_DECIMAL;
5329 unchopnum |= ! ischop;
5331 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5332 arg = ischop ? FORM_NUM_BLANK : 0;
5334 s++; /* skip the '0' first */
5338 const char * const f = ++s;
5341 arg |= FORM_NUM_POINT + (s - f);
5343 *fpc++ = s - base; /* fieldsize for FETCH */
5344 *fpc++ = FF_0DECIMAL;
5346 unchopnum |= ! ischop;
5348 else { /* text field */
5350 bool ismore = FALSE;
5353 while (*++s == '>') ;
5354 prespace = FF_SPACE;
5356 else if (*s == '|') {
5357 while (*++s == '|') ;
5358 prespace = FF_HALFSPACE;
5363 while (*++s == '<') ;
5366 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5370 *fpc++ = s - base; /* fieldsize for FETCH */
5372 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5375 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5389 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5392 mg->mg_ptr = (char *) fops;
5393 mg->mg_len = arg * sizeof(U32);
5394 mg->mg_obj = sv_copy;
5395 mg->mg_flags |= MGf_REFCOUNTED;
5397 if (unchopnum && repeat)
5398 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5405 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5407 /* Can value be printed in fldsize chars, using %*.*f ? */
5411 int intsize = fldsize - (value < 0 ? 1 : 0);
5413 if (frcsize & FORM_NUM_POINT)
5415 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5418 while (intsize--) pwr *= 10.0;
5419 while (frcsize--) eps /= 10.0;
5422 if (value + eps >= pwr)
5425 if (value - eps <= -pwr)
5432 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5434 SV * const datasv = FILTER_DATA(idx);
5435 const int filter_has_file = IoLINES(datasv);
5436 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5437 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5442 char *prune_from = NULL;
5443 bool read_from_cache = FALSE;
5447 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5449 assert(maxlen >= 0);
5452 /* I was having segfault trouble under Linux 2.2.5 after a
5453 parse error occurred. (Had to hack around it with a test
5454 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5455 not sure where the trouble is yet. XXX */
5458 SV *const cache = datasv;
5461 const char *cache_p = SvPV(cache, cache_len);
5465 /* Running in block mode and we have some cached data already.
5467 if (cache_len >= umaxlen) {
5468 /* In fact, so much data we don't even need to call
5473 const char *const first_nl =
5474 (const char *)memchr(cache_p, '\n', cache_len);
5476 take = first_nl + 1 - cache_p;
5480 sv_catpvn(buf_sv, cache_p, take);
5481 sv_chop(cache, cache_p + take);
5482 /* Definitely not EOF */
5486 sv_catsv(buf_sv, cache);
5488 umaxlen -= cache_len;
5491 read_from_cache = TRUE;
5495 /* Filter API says that the filter appends to the contents of the buffer.
5496 Usually the buffer is "", so the details don't matter. But if it's not,
5497 then clearly what it contains is already filtered by this filter, so we
5498 don't want to pass it in a second time.
5499 I'm going to use a mortal in case the upstream filter croaks. */
5500 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5501 ? sv_newmortal() : buf_sv;
5502 SvUPGRADE(upstream, SVt_PV);
5504 if (filter_has_file) {
5505 status = FILTER_READ(idx+1, upstream, 0);
5508 if (filter_sub && status >= 0) {
5512 ENTER_with_name("call_filter_sub");
5517 DEFSV_set(upstream);
5521 PUSHs(filter_state);
5524 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5534 SV * const errsv = ERRSV;
5535 if (SvTRUE_NN(errsv))
5536 err = newSVsv(errsv);
5542 LEAVE_with_name("call_filter_sub");
5545 if (SvGMAGICAL(upstream)) {
5547 if (upstream == buf_sv) mg_free(buf_sv);
5549 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5550 if(!err && SvOK(upstream)) {
5551 got_p = SvPV_nomg(upstream, got_len);
5553 if (got_len > umaxlen) {
5554 prune_from = got_p + umaxlen;
5557 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5558 if (first_nl && first_nl + 1 < got_p + got_len) {
5559 /* There's a second line here... */
5560 prune_from = first_nl + 1;
5564 if (!err && prune_from) {
5565 /* Oh. Too long. Stuff some in our cache. */
5566 STRLEN cached_len = got_p + got_len - prune_from;
5567 SV *const cache = datasv;
5570 /* Cache should be empty. */
5571 assert(!SvCUR(cache));
5574 sv_setpvn(cache, prune_from, cached_len);
5575 /* If you ask for block mode, you may well split UTF-8 characters.
5576 "If it breaks, you get to keep both parts"
5577 (Your code is broken if you don't put them back together again
5578 before something notices.) */
5579 if (SvUTF8(upstream)) {
5582 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5584 /* Cannot just use sv_setpvn, as that could free the buffer
5585 before we have a chance to assign it. */
5586 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5587 got_len - cached_len);
5589 /* Can't yet be EOF */
5594 /* If they are at EOF but buf_sv has something in it, then they may never
5595 have touched the SV upstream, so it may be undefined. If we naively
5596 concatenate it then we get a warning about use of uninitialised value.
5598 if (!err && upstream != buf_sv &&
5600 sv_catsv_nomg(buf_sv, upstream);
5602 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5605 IoLINES(datasv) = 0;
5607 SvREFCNT_dec(filter_state);
5608 IoTOP_GV(datasv) = NULL;
5611 SvREFCNT_dec(filter_sub);
5612 IoBOTTOM_GV(datasv) = NULL;
5614 filter_del(S_run_user_filter);
5620 if (status == 0 && read_from_cache) {
5621 /* If we read some data from the cache (and by getting here it implies
5622 that we emptied the cache) then we aren't yet at EOF, and mustn't
5623 report that to our caller. */
5630 * ex: set ts=8 sts=4 sw=4 et: