3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
37 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
39 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
45 const PERL_CONTEXT *cx;
48 if (PL_op->op_private & OPpOFFBYONE) {
49 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
52 cxix = dopoptosub(cxstack_ix);
58 switch (cx->blk_gimme) {
77 PMOP *pm = (PMOP*)cLOGOP->op_other;
82 const regexp_engine *eng;
83 bool is_bare_re= FALSE;
85 if (PL_op->op_flags & OPf_STACKED) {
95 /* prevent recompiling under /o and ithreads. */
96 #if defined(USE_ITHREADS)
97 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
104 assert (re != (REGEXP*) &PL_sv_undef);
105 eng = re ? RX_ENGINE(re) : current_re_engine();
108 In the below logic: these are basically the same - check if this regcomp is part of a split.
110 (PL_op->op_pmflags & PMf_split )
111 (PL_op->op_next->op_type == OP_PUSHRE)
113 We could add a new mask for this and copy the PMf_split, if we did
114 some bit definition fiddling first.
116 For now we leave this
119 new_re = (eng->op_comp
121 : &Perl_re_op_compile
122 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
124 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
126 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
128 if (pm->op_pmflags & PMf_HAS_CV)
129 ReANY(new_re)->qr_anoncv
130 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
134 /* The match's LHS's get-magic might need to access this op's regexp
135 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
136 get-magic now before we replace the regexp. Hopefully this hack can
137 be replaced with the approach described at
138 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
140 if (pm->op_type == OP_MATCH) {
142 const bool was_tainted = TAINT_get;
143 if (pm->op_flags & OPf_STACKED)
145 else if (pm->op_targ)
146 lhs = PAD_SV(pm->op_targ);
149 /* Restore the previous value of PL_tainted (which may have been
150 modified by get-magic), to avoid incorrectly setting the
151 RXf_TAINTED flag with RX_TAINT_on further down. */
152 TAINT_set(was_tainted);
153 #ifdef NO_TAINT_SUPPORT
154 PERL_UNUSED_VAR(was_tainted);
157 tmp = reg_temp_copy(NULL, new_re);
158 ReREFCNT_dec(new_re);
164 PM_SETRE(pm, new_re);
168 if (TAINTING_get && TAINT_get) {
169 SvTAINTED_on((SV*)new_re);
173 #if !defined(USE_ITHREADS)
174 /* can't change the optree at runtime either */
175 /* PMf_KEEP is handled differently under threads to avoid these problems */
176 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
178 if (pm->op_pmflags & PMf_KEEP) {
179 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
180 cLOGOP->op_first->op_next = PL_op->op_next;
192 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
193 PMOP * const pm = (PMOP*) cLOGOP->op_other;
194 SV * const dstr = cx->sb_dstr;
197 char *orig = cx->sb_orig;
198 REGEXP * const rx = cx->sb_rx;
200 REGEXP *old = PM_GETRE(pm);
207 PM_SETRE(pm,ReREFCNT_inc(rx));
210 rxres_restore(&cx->sb_rxres, rx);
212 if (cx->sb_iters++) {
213 const SSize_t saviters = cx->sb_iters;
214 if (cx->sb_iters > cx->sb_maxiters)
215 DIE(aTHX_ "Substitution loop");
217 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
219 /* See "how taint works" above pp_subst() */
221 cx->sb_rxtainted |= SUBST_TAINT_REPL;
222 sv_catsv_nomg(dstr, POPs);
223 if (CxONCE(cx) || s < orig ||
224 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
225 (s == m), cx->sb_targ, NULL,
226 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
228 SV *targ = cx->sb_targ;
230 assert(cx->sb_strend >= s);
231 if(cx->sb_strend > s) {
232 if (DO_UTF8(dstr) && !SvUTF8(targ))
233 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
235 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
237 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
238 cx->sb_rxtainted |= SUBST_TAINT_PAT;
240 if (pm->op_pmflags & PMf_NONDESTRUCT) {
242 /* From here on down we're using the copy, and leaving the
243 original untouched. */
247 SV_CHECK_THINKFIRST_COW_DROP(targ);
248 if (isGV(targ)) Perl_croak_no_modify();
250 SvPV_set(targ, SvPVX(dstr));
251 SvCUR_set(targ, SvCUR(dstr));
252 SvLEN_set(targ, SvLEN(dstr));
255 SvPV_set(dstr, NULL);
258 mPUSHi(saviters - 1);
260 (void)SvPOK_only_UTF8(targ);
263 /* update the taint state of various various variables in
264 * preparation for final exit.
265 * See "how taint works" above pp_subst() */
267 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
268 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
269 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
271 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
273 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
274 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
276 SvTAINTED_on(TOPs); /* taint return value */
277 /* needed for mg_set below */
279 cBOOL(cx->sb_rxtainted &
280 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
284 /* PL_tainted must be correctly set for this mg_set */
287 LEAVE_SCOPE(cx->sb_oldsave);
290 RETURNOP(pm->op_next);
291 NOT_REACHED; /* NOTREACHED */
293 cx->sb_iters = saviters;
295 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
298 assert(!RX_SUBOFFSET(rx));
299 cx->sb_orig = orig = RX_SUBBEG(rx);
301 cx->sb_strend = s + (cx->sb_strend - m);
303 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
305 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
306 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
308 sv_catpvn_nomg(dstr, s, m-s);
310 cx->sb_s = RX_OFFS(rx)[0].end + orig;
311 { /* Update the pos() information. */
313 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
315 if (!(mg = mg_find_mglob(sv))) {
316 mg = sv_magicext_mglob(sv);
319 MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
322 (void)ReREFCNT_inc(rx);
323 /* update the taint state of various various variables in preparation
324 * for calling the code block.
325 * See "how taint works" above pp_subst() */
327 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
328 cx->sb_rxtainted |= SUBST_TAINT_PAT;
330 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
331 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
332 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
334 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
336 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
337 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
338 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
339 ? cx->sb_dstr : cx->sb_targ);
342 rxres_save(&cx->sb_rxres, rx);
344 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
348 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
353 PERL_ARGS_ASSERT_RXRES_SAVE;
356 if (!p || p[1] < RX_NPARENS(rx)) {
358 i = 7 + (RX_NPARENS(rx)+1) * 2;
360 i = 6 + (RX_NPARENS(rx)+1) * 2;
369 /* what (if anything) to free on croak */
370 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
371 RX_MATCH_COPIED_off(rx);
372 *p++ = RX_NPARENS(rx);
375 *p++ = PTR2UV(RX_SAVED_COPY(rx));
376 RX_SAVED_COPY(rx) = NULL;
379 *p++ = PTR2UV(RX_SUBBEG(rx));
380 *p++ = (UV)RX_SUBLEN(rx);
381 *p++ = (UV)RX_SUBOFFSET(rx);
382 *p++ = (UV)RX_SUBCOFFSET(rx);
383 for (i = 0; i <= RX_NPARENS(rx); ++i) {
384 *p++ = (UV)RX_OFFS(rx)[i].start;
385 *p++ = (UV)RX_OFFS(rx)[i].end;
390 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
395 PERL_ARGS_ASSERT_RXRES_RESTORE;
398 RX_MATCH_COPY_FREE(rx);
399 RX_MATCH_COPIED_set(rx, *p);
401 RX_NPARENS(rx) = *p++;
404 if (RX_SAVED_COPY(rx))
405 SvREFCNT_dec (RX_SAVED_COPY(rx));
406 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
410 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
411 RX_SUBLEN(rx) = (I32)(*p++);
412 RX_SUBOFFSET(rx) = (I32)*p++;
413 RX_SUBCOFFSET(rx) = (I32)*p++;
414 for (i = 0; i <= RX_NPARENS(rx); ++i) {
415 RX_OFFS(rx)[i].start = (I32)(*p++);
416 RX_OFFS(rx)[i].end = (I32)(*p++);
421 S_rxres_free(pTHX_ void **rsp)
423 UV * const p = (UV*)*rsp;
425 PERL_ARGS_ASSERT_RXRES_FREE;
429 void *tmp = INT2PTR(char*,*p);
432 U32 i = 9 + p[1] * 2;
434 U32 i = 8 + p[1] * 2;
439 SvREFCNT_dec (INT2PTR(SV*,p[2]));
442 PoisonFree(p, i, sizeof(UV));
451 #define FORM_NUM_BLANK (1<<30)
452 #define FORM_NUM_POINT (1<<29)
456 dSP; dMARK; dORIGMARK;
457 SV * const tmpForm = *++MARK;
458 SV *formsv; /* contains text of original format */
459 U32 *fpc; /* format ops program counter */
460 char *t; /* current append position in target string */
461 const char *f; /* current position in format string */
463 SV *sv = NULL; /* current item */
464 const char *item = NULL;/* string value of current item */
465 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
466 I32 itembytes = 0; /* as itemsize, but length in bytes */
467 I32 fieldsize = 0; /* width of current field */
468 I32 lines = 0; /* number of lines that have been output */
469 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
470 const char *chophere = NULL; /* where to chop current item */
471 STRLEN linemark = 0; /* pos of start of line in output */
473 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
474 STRLEN len; /* length of current sv */
475 STRLEN linemax; /* estimate of output size in bytes */
476 bool item_is_utf8 = FALSE;
477 bool targ_is_utf8 = FALSE;
480 U8 *source; /* source of bytes to append */
481 STRLEN to_copy; /* how may bytes to append */
482 char trans; /* what chars to translate */
484 mg = doparseform(tmpForm);
486 fpc = (U32*)mg->mg_ptr;
487 /* the actual string the format was compiled from.
488 * with overload etc, this may not match tmpForm */
492 SvPV_force(PL_formtarget, len);
493 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
494 SvTAINTED_on(PL_formtarget);
495 if (DO_UTF8(PL_formtarget))
497 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
498 t = SvGROW(PL_formtarget, len + linemax + 1);
499 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
501 f = SvPV_const(formsv, len);
505 const char *name = "???";
508 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
509 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
510 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
511 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
512 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
514 case FF_CHECKNL: name = "CHECKNL"; break;
515 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
516 case FF_SPACE: name = "SPACE"; break;
517 case FF_HALFSPACE: name = "HALFSPACE"; break;
518 case FF_ITEM: name = "ITEM"; break;
519 case FF_CHOP: name = "CHOP"; break;
520 case FF_LINEGLOB: name = "LINEGLOB"; break;
521 case FF_NEWLINE: name = "NEWLINE"; break;
522 case FF_MORE: name = "MORE"; break;
523 case FF_LINEMARK: name = "LINEMARK"; break;
524 case FF_END: name = "END"; break;
525 case FF_0DECIMAL: name = "0DECIMAL"; break;
526 case FF_LINESNGL: name = "LINESNGL"; break;
529 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
531 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
534 case FF_LINEMARK: /* start (or end) of a line */
535 linemark = t - SvPVX(PL_formtarget);
540 case FF_LITERAL: /* append <arg> literal chars */
545 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
548 case FF_SKIP: /* skip <arg> chars in format */
552 case FF_FETCH: /* get next item and set field size to <arg> */
561 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
564 SvTAINTED_on(PL_formtarget);
567 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
569 const char *s = item = SvPV_const(sv, len);
570 const char *send = s + len;
573 item_is_utf8 = DO_UTF8(sv);
585 if (itemsize == fieldsize)
588 itembytes = s - item;
593 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
595 const char *s = item = SvPV_const(sv, len);
596 const char *send = s + len;
600 item_is_utf8 = DO_UTF8(sv);
602 /* look for a legal split position */
610 /* provisional split point */
614 /* we delay testing fieldsize until after we've
615 * processed the possible split char directly
616 * following the last field char; so if fieldsize=3
617 * and item="a b cdef", we consume "a b", not "a".
618 * Ditto further down.
620 if (size == fieldsize)
624 if (strchr(PL_chopset, *s)) {
625 /* provisional split point */
626 /* for a non-space split char, we include
627 * the split char; hence the '+1' */
631 if (size == fieldsize)
643 if (!chophere || s == send) {
647 itembytes = chophere - item;
652 case FF_SPACE: /* append padding space (diff of field, item size) */
653 arg = fieldsize - itemsize;
661 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
662 arg = fieldsize - itemsize;
671 case FF_ITEM: /* append a text item, while blanking ctrl chars */
677 case FF_CHOP: /* (for ^*) chop the current item */
678 if (sv != &PL_sv_no) {
679 const char *s = chophere;
687 /* tied, overloaded or similar strangeness.
688 * Do it the hard way */
689 sv_setpvn(sv, s, len - (s-item));
694 case FF_LINESNGL: /* process ^* */
698 case FF_LINEGLOB: /* process @* */
700 const bool oneline = fpc[-1] == FF_LINESNGL;
701 const char *s = item = SvPV_const(sv, len);
702 const char *const send = s + len;
704 item_is_utf8 = DO_UTF8(sv);
715 to_copy = s - item - 1;
729 /* append to_copy bytes from source to PL_formstring.
730 * item_is_utf8 implies source is utf8.
731 * if trans, translate certain characters during the copy */
736 SvCUR_set(PL_formtarget,
737 t - SvPVX_const(PL_formtarget));
739 if (targ_is_utf8 && !item_is_utf8) {
740 source = tmp = bytes_to_utf8(source, &to_copy);
742 if (item_is_utf8 && !targ_is_utf8) {
744 /* Upgrade targ to UTF8, and then we reduce it to
745 a problem we have a simple solution for.
746 Don't need get magic. */
747 sv_utf8_upgrade_nomg(PL_formtarget);
749 /* re-calculate linemark */
750 s = (U8*)SvPVX(PL_formtarget);
751 /* the bytes we initially allocated to append the
752 * whole line may have been gobbled up during the
753 * upgrade, so allocate a whole new line's worth
758 linemark = s - (U8*)SvPVX(PL_formtarget);
760 /* Easy. They agree. */
761 assert (item_is_utf8 == targ_is_utf8);
764 /* @* and ^* are the only things that can exceed
765 * the linemax, so grow by the output size, plus
766 * a whole new form's worth in case of any further
768 grow = linemax + to_copy;
770 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
771 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
773 Copy(source, t, to_copy, char);
775 /* blank out ~ or control chars, depending on trans.
776 * works on bytes not chars, so relies on not
777 * matching utf8 continuation bytes */
779 U8 *send = s + to_copy;
782 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
789 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
795 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
798 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
801 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
804 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
806 /* If the field is marked with ^ and the value is undefined,
808 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
816 /* overflow evidence */
817 if (num_overflow(value, fieldsize, arg)) {
823 /* Formats aren't yet marked for locales, so assume "yes". */
825 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
827 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
828 STORE_LC_NUMERIC_SET_TO_NEEDED();
829 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
832 const char* qfmt = quadmath_format_single(fmt);
835 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
836 len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
838 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
843 /* we generate fmt ourselves so it is safe */
844 GCC_DIAG_IGNORE(-Wformat-nonliteral);
845 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
848 PERL_MY_SNPRINTF_POST_GUARD(len, max);
849 RESTORE_LC_NUMERIC();
854 case FF_NEWLINE: /* delete trailing spaces, then append \n */
856 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
861 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
864 if (arg) { /* repeat until fields exhausted? */
870 t = SvPVX(PL_formtarget) + linemark;
875 case FF_MORE: /* replace long end of string with '...' */
877 const char *s = chophere;
878 const char *send = item + len;
880 while (isSPACE(*s) && (s < send))
885 arg = fieldsize - itemsize;
892 if (strnEQ(s1," ",3)) {
893 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
903 case FF_END: /* tidy up, then return */
905 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
907 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
909 SvUTF8_on(PL_formtarget);
910 FmLINES(PL_formtarget) += lines;
912 if (fpc[-1] == FF_BLANK)
913 RETURNOP(cLISTOP->op_first);
925 if (PL_stack_base + *PL_markstack_ptr == SP) {
927 if (GIMME_V == G_SCALAR)
929 RETURNOP(PL_op->op_next->op_next);
931 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
932 Perl_pp_pushmark(aTHX); /* push dst */
933 Perl_pp_pushmark(aTHX); /* push src */
934 ENTER_with_name("grep"); /* enter outer scope */
937 if (PL_op->op_private & OPpGREP_LEX)
938 SAVESPTR(PAD_SVl(PL_op->op_targ));
941 ENTER_with_name("grep_item"); /* enter inner scope */
944 src = PL_stack_base[*PL_markstack_ptr];
946 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
950 if (PL_op->op_private & OPpGREP_LEX)
951 PAD_SVl(PL_op->op_targ) = src;
956 if (PL_op->op_type == OP_MAPSTART)
957 Perl_pp_pushmark(aTHX); /* push top */
958 return ((LOGOP*)PL_op->op_next)->op_other;
964 const I32 gimme = GIMME_V;
965 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
971 /* first, move source pointer to the next item in the source list */
972 ++PL_markstack_ptr[-1];
974 /* if there are new items, push them into the destination list */
975 if (items && gimme != G_VOID) {
976 /* might need to make room back there first */
977 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
978 /* XXX this implementation is very pessimal because the stack
979 * is repeatedly extended for every set of items. Is possible
980 * to do this without any stack extension or copying at all
981 * by maintaining a separate list over which the map iterates
982 * (like foreach does). --gsar */
984 /* everything in the stack after the destination list moves
985 * towards the end the stack by the amount of room needed */
986 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
988 /* items to shift up (accounting for the moved source pointer) */
989 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
991 /* This optimization is by Ben Tilly and it does
992 * things differently from what Sarathy (gsar)
993 * is describing. The downside of this optimization is
994 * that leaves "holes" (uninitialized and hopefully unused areas)
995 * to the Perl stack, but on the other hand this
996 * shouldn't be a problem. If Sarathy's idea gets
997 * implemented, this optimization should become
998 * irrelevant. --jhi */
1000 shift = count; /* Avoid shifting too often --Ben Tilly */
1004 dst = (SP += shift);
1005 PL_markstack_ptr[-1] += shift;
1006 *PL_markstack_ptr += shift;
1010 /* copy the new items down to the destination list */
1011 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1012 if (gimme == G_ARRAY) {
1013 /* add returned items to the collection (making mortal copies
1014 * if necessary), then clear the current temps stack frame
1015 * *except* for those items. We do this splicing the items
1016 * into the start of the tmps frame (so some items may be on
1017 * the tmps stack twice), then moving PL_tmps_floor above
1018 * them, then freeing the frame. That way, the only tmps that
1019 * accumulate over iterations are the return values for map.
1020 * We have to do to this way so that everything gets correctly
1021 * freed if we die during the map.
1025 /* make space for the slice */
1026 EXTEND_MORTAL(items);
1027 tmpsbase = PL_tmps_floor + 1;
1028 Move(PL_tmps_stack + tmpsbase,
1029 PL_tmps_stack + tmpsbase + items,
1030 PL_tmps_ix - PL_tmps_floor,
1032 PL_tmps_ix += items;
1037 sv = sv_mortalcopy(sv);
1039 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1041 /* clear the stack frame except for the items */
1042 PL_tmps_floor += items;
1044 /* FREETMPS may have cleared the TEMP flag on some of the items */
1047 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1050 /* scalar context: we don't care about which values map returns
1051 * (we use undef here). And so we certainly don't want to do mortal
1052 * copies of meaningless values. */
1053 while (items-- > 0) {
1055 *dst-- = &PL_sv_undef;
1063 LEAVE_with_name("grep_item"); /* exit inner scope */
1066 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1068 (void)POPMARK; /* pop top */
1069 LEAVE_with_name("grep"); /* exit outer scope */
1070 (void)POPMARK; /* pop src */
1071 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1072 (void)POPMARK; /* pop dst */
1073 SP = PL_stack_base + POPMARK; /* pop original mark */
1074 if (gimme == G_SCALAR) {
1075 if (PL_op->op_private & OPpGREP_LEX) {
1076 SV* sv = sv_newmortal();
1077 sv_setiv(sv, items);
1085 else if (gimme == G_ARRAY)
1092 ENTER_with_name("grep_item"); /* enter inner scope */
1095 /* set $_ to the new source item */
1096 src = PL_stack_base[PL_markstack_ptr[-1]];
1097 if (SvPADTMP(src)) {
1098 src = sv_mortalcopy(src);
1101 if (PL_op->op_private & OPpGREP_LEX)
1102 PAD_SVl(PL_op->op_targ) = src;
1106 RETURNOP(cLOGOP->op_other);
1114 if (GIMME_V == G_ARRAY)
1116 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1117 return cLOGOP->op_other;
1126 if (GIMME_V == G_ARRAY) {
1127 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1131 SV * const targ = PAD_SV(PL_op->op_targ);
1134 if (PL_op->op_private & OPpFLIP_LINENUM) {
1135 if (GvIO(PL_last_in_gv)) {
1136 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1139 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1141 flip = SvIV(sv) == SvIV(GvSV(gv));
1147 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1148 if (PL_op->op_flags & OPf_SPECIAL) {
1156 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1159 sv_setpvs(TARG, "");
1165 /* This code tries to decide if "$left .. $right" should use the
1166 magical string increment, or if the range is numeric (we make
1167 an exception for .."0" [#18165]). AMS 20021031. */
1169 #define RANGE_IS_NUMERIC(left,right) ( \
1170 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1171 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1172 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1173 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1174 && (!SvOK(right) || looks_like_number(right))))
1180 if (GIMME_V == G_ARRAY) {
1186 if (RANGE_IS_NUMERIC(left,right)) {
1188 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1189 (SvOK(right) && (SvIOK(right)
1190 ? SvIsUV(right) && SvUV(right) > IV_MAX
1191 : SvNV_nomg(right) > IV_MAX)))
1192 DIE(aTHX_ "Range iterator outside integer range");
1193 i = SvIV_nomg(left);
1194 j = SvIV_nomg(right);
1196 /* Dance carefully around signed max. */
1197 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1200 /* The wraparound of signed integers is undefined
1201 * behavior, but here we aim for count >=1, and
1202 * negative count is just wrong. */
1207 Perl_croak(aTHX_ "Out of memory during list extend");
1214 SV * const sv = sv_2mortal(newSViv(i));
1216 if (n) /* avoid incrementing above IV_MAX */
1222 const char * const lpv = SvPV_nomg_const(left, llen);
1223 const char * const tmps = SvPV_nomg_const(right, len);
1225 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1226 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1228 if (strEQ(SvPVX_const(sv),tmps))
1230 sv = sv_2mortal(newSVsv(sv));
1237 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1241 if (PL_op->op_private & OPpFLIP_LINENUM) {
1242 if (GvIO(PL_last_in_gv)) {
1243 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1246 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1247 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1255 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1256 sv_catpvs(targ, "E0");
1266 static const char * const context_name[] = {
1268 NULL, /* CXt_WHEN never actually needs "block" */
1269 NULL, /* CXt_BLOCK never actually needs "block" */
1270 NULL, /* CXt_GIVEN never actually needs "block" */
1271 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1272 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1273 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1274 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1282 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1286 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1288 for (i = cxstack_ix; i >= 0; i--) {
1289 const PERL_CONTEXT * const cx = &cxstack[i];
1290 switch (CxTYPE(cx)) {
1296 /* diag_listed_as: Exiting subroutine via %s */
1297 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1298 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1299 if (CxTYPE(cx) == CXt_NULL)
1302 case CXt_LOOP_LAZYIV:
1303 case CXt_LOOP_LAZYSV:
1305 case CXt_LOOP_PLAIN:
1307 STRLEN cx_label_len = 0;
1308 U32 cx_label_flags = 0;
1309 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1311 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1314 (const U8*)cx_label, cx_label_len,
1315 (const U8*)label, len) == 0)
1317 (const U8*)label, len,
1318 (const U8*)cx_label, cx_label_len) == 0)
1319 : (len == cx_label_len && ((cx_label == label)
1320 || memEQ(cx_label, label, len))) )) {
1321 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1322 (long)i, cx_label));
1325 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1336 Perl_dowantarray(pTHX)
1338 const I32 gimme = block_gimme();
1339 return (gimme == G_VOID) ? G_SCALAR : gimme;
1343 Perl_block_gimme(pTHX)
1345 const I32 cxix = dopoptosub(cxstack_ix);
1349 switch (cxstack[cxix].blk_gimme) {
1357 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1359 NOT_REACHED; /* NOTREACHED */
1363 Perl_is_lvalue_sub(pTHX)
1365 const I32 cxix = dopoptosub(cxstack_ix);
1366 assert(cxix >= 0); /* We should only be called from inside subs */
1368 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1369 return CxLVAL(cxstack + cxix);
1374 /* only used by PUSHSUB */
1376 Perl_was_lvalue_sub(pTHX)
1378 const I32 cxix = dopoptosub(cxstack_ix-1);
1379 assert(cxix >= 0); /* We should only be called from inside subs */
1381 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1382 return CxLVAL(cxstack + cxix);
1388 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1392 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1394 PERL_UNUSED_CONTEXT;
1397 for (i = startingblock; i >= 0; i--) {
1398 const PERL_CONTEXT * const cx = &cxstk[i];
1399 switch (CxTYPE(cx)) {
1403 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1404 * twice; the first for the normal foo() call, and the second
1405 * for a faked up re-entry into the sub to execute the
1406 * code block. Hide this faked entry from the world. */
1407 if (cx->cx_type & CXp_SUB_RE_FAKE)
1412 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1420 S_dopoptoeval(pTHX_ I32 startingblock)
1423 for (i = startingblock; i >= 0; i--) {
1424 const PERL_CONTEXT *cx = &cxstack[i];
1425 switch (CxTYPE(cx)) {
1429 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1437 S_dopoptoloop(pTHX_ I32 startingblock)
1440 for (i = startingblock; i >= 0; i--) {
1441 const PERL_CONTEXT * const cx = &cxstack[i];
1442 switch (CxTYPE(cx)) {
1448 /* diag_listed_as: Exiting subroutine via %s */
1449 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1450 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1451 if ((CxTYPE(cx)) == CXt_NULL)
1454 case CXt_LOOP_LAZYIV:
1455 case CXt_LOOP_LAZYSV:
1457 case CXt_LOOP_PLAIN:
1458 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1466 S_dopoptogiven(pTHX_ I32 startingblock)
1469 for (i = startingblock; i >= 0; i--) {
1470 const PERL_CONTEXT *cx = &cxstack[i];
1471 switch (CxTYPE(cx)) {
1475 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1477 case CXt_LOOP_PLAIN:
1478 assert(!CxFOREACHDEF(cx));
1480 case CXt_LOOP_LAZYIV:
1481 case CXt_LOOP_LAZYSV:
1483 if (CxFOREACHDEF(cx)) {
1484 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1493 S_dopoptowhen(pTHX_ I32 startingblock)
1496 for (i = startingblock; i >= 0; i--) {
1497 const PERL_CONTEXT *cx = &cxstack[i];
1498 switch (CxTYPE(cx)) {
1502 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1510 Perl_dounwind(pTHX_ I32 cxix)
1514 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1517 while (cxstack_ix > cxix) {
1519 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1520 DEBUG_CX("UNWIND"); \
1521 /* Note: we don't need to restore the base context info till the end. */
1522 switch (CxTYPE(cx)) {
1525 continue; /* not break */
1533 case CXt_LOOP_LAZYIV:
1534 case CXt_LOOP_LAZYSV:
1536 case CXt_LOOP_PLAIN:
1547 PERL_UNUSED_VAR(optype);
1551 Perl_qerror(pTHX_ SV *err)
1553 PERL_ARGS_ASSERT_QERROR;
1556 if (PL_in_eval & EVAL_KEEPERR) {
1557 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1561 sv_catsv(ERRSV, err);
1564 sv_catsv(PL_errors, err);
1566 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1568 ++PL_parser->error_count;
1572 Perl_die_unwind(pTHX_ SV *msv)
1574 SV *exceptsv = sv_mortalcopy(msv);
1575 U8 in_eval = PL_in_eval;
1576 PERL_ARGS_ASSERT_DIE_UNWIND;
1583 * Historically, perl used to set ERRSV ($@) early in the die
1584 * process and rely on it not getting clobbered during unwinding.
1585 * That sucked, because it was liable to get clobbered, so the
1586 * setting of ERRSV used to emit the exception from eval{} has
1587 * been moved to much later, after unwinding (see just before
1588 * JMPENV_JUMP below). However, some modules were relying on the
1589 * early setting, by examining $@ during unwinding to use it as
1590 * a flag indicating whether the current unwinding was caused by
1591 * an exception. It was never a reliable flag for that purpose,
1592 * being totally open to false positives even without actual
1593 * clobberage, but was useful enough for production code to
1594 * semantically rely on it.
1596 * We'd like to have a proper introspective interface that
1597 * explicitly describes the reason for whatever unwinding
1598 * operations are currently in progress, so that those modules
1599 * work reliably and $@ isn't further overloaded. But we don't
1600 * have one yet. In its absence, as a stopgap measure, ERRSV is
1601 * now *additionally* set here, before unwinding, to serve as the
1602 * (unreliable) flag that it used to.
1604 * This behaviour is temporary, and should be removed when a
1605 * proper way to detect exceptional unwinding has been developed.
1606 * As of 2010-12, the authors of modules relying on the hack
1607 * are aware of the issue, because the modules failed on
1608 * perls 5.13.{1..7} which had late setting of $@ without this
1609 * early-setting hack.
1611 if (!(in_eval & EVAL_KEEPERR)) {
1612 SvTEMP_off(exceptsv);
1613 sv_setsv(ERRSV, exceptsv);
1616 if (in_eval & EVAL_KEEPERR) {
1617 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1621 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1622 && PL_curstackinfo->si_prev)
1636 JMPENV *restartjmpenv;
1639 if (cxix < cxstack_ix)
1642 POPBLOCK(cx,PL_curpm);
1643 if (CxTYPE(cx) != CXt_EVAL) {
1645 const char* message = SvPVx_const(exceptsv, msglen);
1646 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1647 PerlIO_write(Perl_error_log, message, msglen);
1651 namesv = cx->blk_eval.old_namesv;
1653 oldcop = cx->blk_oldcop;
1655 restartjmpenv = cx->blk_eval.cur_top_env;
1656 restartop = cx->blk_eval.retop;
1658 if (gimme == G_SCALAR)
1659 *++newsp = &PL_sv_undef;
1660 PL_stack_sp = newsp;
1664 if (optype == OP_REQUIRE) {
1665 assert (PL_curcop == oldcop);
1666 (void)hv_store(GvHVn(PL_incgv),
1667 SvPVX_const(namesv),
1668 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1670 /* note that unlike pp_entereval, pp_require isn't
1671 * supposed to trap errors. So now that we've popped the
1672 * EVAL that pp_require pushed, and processed the error
1673 * message, rethrow the error */
1674 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1675 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1678 if (!(in_eval & EVAL_KEEPERR))
1679 sv_setsv(ERRSV, exceptsv);
1680 PL_restartjmpenv = restartjmpenv;
1681 PL_restartop = restartop;
1683 NOT_REACHED; /* NOTREACHED */
1687 write_to_stderr(exceptsv);
1689 NOT_REACHED; /* NOTREACHED */
1695 if (SvTRUE(left) != SvTRUE(right))
1703 =head1 CV Manipulation Functions
1705 =for apidoc caller_cx
1707 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1708 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1709 information returned to Perl by C<caller>. Note that XSUBs don't get a
1710 stack frame, so C<caller_cx(0, NULL)> will return information for the
1711 immediately-surrounding Perl code.
1713 This function skips over the automatic calls to C<&DB::sub> made on the
1714 behalf of the debugger. If the stack frame requested was a sub called by
1715 C<DB::sub>, the return value will be the frame for the call to
1716 C<DB::sub>, since that has the correct line number/etc. for the call
1717 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1718 frame for the sub call itself.
1723 const PERL_CONTEXT *
1724 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1726 I32 cxix = dopoptosub(cxstack_ix);
1727 const PERL_CONTEXT *cx;
1728 const PERL_CONTEXT *ccstack = cxstack;
1729 const PERL_SI *top_si = PL_curstackinfo;
1732 /* we may be in a higher stacklevel, so dig down deeper */
1733 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1734 top_si = top_si->si_prev;
1735 ccstack = top_si->si_cxstack;
1736 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1740 /* caller() should not report the automatic calls to &DB::sub */
1741 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1742 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1746 cxix = dopoptosub_at(ccstack, cxix - 1);
1749 cx = &ccstack[cxix];
1750 if (dbcxp) *dbcxp = cx;
1752 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1753 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1754 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1755 field below is defined for any cx. */
1756 /* caller() should not report the automatic calls to &DB::sub */
1757 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1758 cx = &ccstack[dbcxix];
1767 const PERL_CONTEXT *cx;
1768 const PERL_CONTEXT *dbcx;
1769 I32 gimme = GIMME_V;
1770 const HEK *stash_hek;
1772 bool has_arg = MAXARG && TOPs;
1781 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1783 if (gimme != G_ARRAY) {
1791 assert(CopSTASH(cx->blk_oldcop));
1792 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1793 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1795 if (gimme != G_ARRAY) {
1798 PUSHs(&PL_sv_undef);
1801 sv_sethek(TARG, stash_hek);
1810 PUSHs(&PL_sv_undef);
1813 sv_sethek(TARG, stash_hek);
1816 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1817 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1818 cx->blk_sub.retop, TRUE);
1820 lcop = cx->blk_oldcop;
1821 mPUSHi((I32)CopLINE(lcop));
1824 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1825 /* So is ccstack[dbcxix]. */
1826 if (CvHASGV(dbcx->blk_sub.cv)) {
1827 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1828 PUSHs(boolSV(CxHASARGS(cx)));
1831 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1832 PUSHs(boolSV(CxHASARGS(cx)));
1836 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1839 gimme = (I32)cx->blk_gimme;
1840 if (gimme == G_VOID)
1841 PUSHs(&PL_sv_undef);
1843 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1844 if (CxTYPE(cx) == CXt_EVAL) {
1846 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1847 SV *cur_text = cx->blk_eval.cur_text;
1848 if (SvCUR(cur_text) >= 2) {
1849 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1850 SvUTF8(cur_text)|SVs_TEMP));
1853 /* I think this is will always be "", but be sure */
1854 PUSHs(sv_2mortal(newSVsv(cur_text)));
1860 else if (cx->blk_eval.old_namesv) {
1861 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1864 /* eval BLOCK (try blocks have old_namesv == 0) */
1866 PUSHs(&PL_sv_undef);
1867 PUSHs(&PL_sv_undef);
1871 PUSHs(&PL_sv_undef);
1872 PUSHs(&PL_sv_undef);
1874 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1875 && CopSTASH_eq(PL_curcop, PL_debstash))
1877 AV * const ary = cx->blk_sub.argarray;
1878 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1880 Perl_init_dbargs(aTHX);
1882 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1883 av_extend(PL_dbargs, AvFILLp(ary) + off);
1884 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1885 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1887 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1890 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1892 if (old_warnings == pWARN_NONE)
1893 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1894 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1895 mask = &PL_sv_undef ;
1896 else if (old_warnings == pWARN_ALL ||
1897 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1898 /* Get the bit mask for $warnings::Bits{all}, because
1899 * it could have been extended by warnings::register */
1901 HV * const bits = get_hv("warnings::Bits", 0);
1902 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1903 mask = newSVsv(*bits_all);
1906 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1910 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1914 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1915 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1925 if (MAXARG < 1 || (!TOPs && !POPs))
1926 tmps = NULL, len = 0;
1928 tmps = SvPVx_const(POPs, len);
1929 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1934 /* like pp_nextstate, but used instead when the debugger is active */
1938 PL_curcop = (COP*)PL_op;
1939 TAINT_NOT; /* Each statement is presumed innocent */
1940 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1945 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1946 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
1950 const I32 gimme = G_ARRAY;
1952 GV * const gv = PL_DBgv;
1955 if (gv && isGV_with_GP(gv))
1958 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1959 DIE(aTHX_ "No DB::DB routine defined");
1961 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1962 /* don't do recursive DB::DB call */
1976 (void)(*CvXSUB(cv))(aTHX_ cv);
1982 PUSHBLOCK(cx, CXt_SUB, SP);
1984 cx->blk_sub.retop = PL_op->op_next;
1986 if (CvDEPTH(cv) >= 2) {
1987 PERL_STACK_OVERFLOW_CHECK();
1988 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1991 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1992 RETURNOP(CvSTART(cv));
1999 /* S_leave_common: Common code that many functions in this file use on
2002 /* SVs on the stack that have any of the flags passed in are left as is.
2003 Other SVs are protected via the mortals stack if lvalue is true, and
2006 Also, taintedness is cleared.
2010 S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
2011 U32 flags, bool lvalue)
2014 PERL_ARGS_ASSERT_LEAVE_COMMON;
2017 if (flags & SVs_PADTMP) {
2018 flags &= ~SVs_PADTMP;
2021 if (gimme == G_SCALAR) {
2023 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2026 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2027 : sv_mortalcopy(*SP);
2029 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2032 *++MARK = &PL_sv_undef;
2036 else if (gimme == G_ARRAY) {
2037 /* in case LEAVE wipes old return values */
2038 while (++MARK <= SP) {
2039 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2043 ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
2044 : sv_mortalcopy(*MARK);
2045 TAINT_NOT; /* Each item is independent */
2048 /* When this function was called with MARK == newsp, we reach this
2049 * point with SP == newsp. */
2059 I32 gimme = GIMME_V;
2061 ENTER_with_name("block");
2064 PUSHBLOCK(cx, CXt_BLOCK, SP);
2077 if (PL_op->op_flags & OPf_SPECIAL) {
2078 cx = &cxstack[cxstack_ix];
2079 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2084 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2086 SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
2087 PL_op->op_private & OPpLVALUE);
2088 PL_curpm = newpm; /* Don't pop $1 et al till now */
2090 LEAVE_with_name("block");
2096 S_outside_integer(pTHX_ SV *sv)
2099 const NV nv = SvNV_nomg(sv);
2100 if (Perl_isinfnan(nv))
2102 #ifdef NV_PRESERVES_UV
2103 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2106 if (nv <= (NV)IV_MIN)
2109 ((nv > (NV)UV_MAX ||
2110 SvUV_nomg(sv) > (UV)IV_MAX)))
2121 const I32 gimme = GIMME_V;
2122 void *itervar; /* location of the iteration variable */
2123 U8 cxtype = CXt_LOOP_FOR;
2125 ENTER_with_name("loop1");
2128 if (PL_op->op_targ) { /* "my" variable */
2129 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2130 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2131 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2132 SVs_PADSTALE, SVs_PADSTALE);
2134 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2136 itervar = PL_comppad;
2138 itervar = &PAD_SVl(PL_op->op_targ);
2141 else if (LIKELY(isGV(TOPs))) { /* symbol table variable */
2142 GV * const gv = MUTABLE_GV(POPs);
2143 SV** svp = &GvSV(gv);
2144 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2146 itervar = (void *)gv;
2147 save_aliased_sv(gv);
2150 SV * const sv = POPs;
2151 assert(SvTYPE(sv) == SVt_PVMG);
2152 assert(SvMAGIC(sv));
2153 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2154 itervar = (void *)sv;
2155 cxtype |= CXp_FOR_LVREF;
2158 if (PL_op->op_private & OPpITER_DEF)
2159 cxtype |= CXp_FOR_DEF;
2161 ENTER_with_name("loop2");
2163 PUSHBLOCK(cx, cxtype, SP);
2164 PUSHLOOP_FOR(cx, itervar, MARK);
2165 if (PL_op->op_flags & OPf_STACKED) {
2166 SV *maybe_ary = POPs;
2167 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2169 SV * const right = maybe_ary;
2170 if (UNLIKELY(cxtype & CXp_FOR_LVREF))
2171 DIE(aTHX_ "Assigned value is not a reference");
2174 if (RANGE_IS_NUMERIC(sv,right)) {
2175 cx->cx_type &= ~CXTYPEMASK;
2176 cx->cx_type |= CXt_LOOP_LAZYIV;
2177 /* Make sure that no-one re-orders cop.h and breaks our
2179 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2180 if (S_outside_integer(aTHX_ sv) ||
2181 S_outside_integer(aTHX_ right))
2182 DIE(aTHX_ "Range iterator outside integer range");
2183 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2184 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2186 /* for correct -Dstv display */
2187 cx->blk_oldsp = sp - PL_stack_base;
2191 cx->cx_type &= ~CXTYPEMASK;
2192 cx->cx_type |= CXt_LOOP_LAZYSV;
2193 /* Make sure that no-one re-orders cop.h and breaks our
2195 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2196 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2197 cx->blk_loop.state_u.lazysv.end = right;
2198 SvREFCNT_inc(right);
2199 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2200 /* This will do the upgrade to SVt_PV, and warn if the value
2201 is uninitialised. */
2202 (void) SvPV_nolen_const(right);
2203 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2204 to replace !SvOK() with a pointer to "". */
2206 SvREFCNT_dec(right);
2207 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2211 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2212 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2213 SvREFCNT_inc(maybe_ary);
2214 cx->blk_loop.state_u.ary.ix =
2215 (PL_op->op_private & OPpITER_REVERSED) ?
2216 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2220 else { /* iterating over items on the stack */
2221 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2222 if (PL_op->op_private & OPpITER_REVERSED) {
2223 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2226 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2237 const I32 gimme = GIMME_V;
2239 ENTER_with_name("loop1");
2241 ENTER_with_name("loop2");
2243 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2244 PUSHLOOP_PLAIN(cx, SP);
2259 assert(CxTYPE_is_LOOP(cx));
2261 newsp = PL_stack_base + cx->blk_loop.resetsp;
2263 SP = leave_common(newsp, SP, MARK, gimme, 0,
2264 PL_op->op_private & OPpLVALUE);
2267 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2268 PL_curpm = newpm; /* ... and pop $1 et al */
2270 LEAVE_with_name("loop2");
2271 LEAVE_with_name("loop1");
2277 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2278 PERL_CONTEXT *cx, PMOP *newpm)
2280 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2281 if (gimme == G_SCALAR) {
2282 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2284 const char *what = NULL;
2286 assert(MARK+1 == SP);
2287 if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
2288 !SvSMAGICAL(TOPs)) {
2290 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2291 : "a readonly value" : "a temporary";
2296 /* sub:lvalue{} will take us here. */
2305 "Can't return %s from lvalue subroutine", what
2310 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2311 if (!SvPADTMP(*SP)) {
2312 *++newsp = SvREFCNT_inc(*SP);
2317 /* FREETMPS could clobber it */
2318 SV *sv = SvREFCNT_inc(*SP);
2320 *++newsp = sv_mortalcopy(sv);
2327 ? sv_mortalcopy(*SP)
2329 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2334 *++newsp = &PL_sv_undef;
2336 if (CxLVAL(cx) & OPpDEREF) {
2339 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2343 else if (gimme == G_ARRAY) {
2344 assert (!(CxLVAL(cx) & OPpDEREF));
2345 if (ref || !CxLVAL(cx))
2346 while (++MARK <= SP)
2348 SvFLAGS(*MARK) & SVs_PADTMP
2349 ? sv_mortalcopy(*MARK)
2352 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2353 else while (++MARK <= SP) {
2354 if (*MARK != &PL_sv_undef
2355 && (SvPADTMP(*MARK) || SvREADONLY(*MARK))
2357 const bool ro = cBOOL( SvREADONLY(*MARK) );
2359 /* Might be flattened array after $#array = */
2366 /* diag_listed_as: Can't return %s from lvalue subroutine */
2368 "Can't return a %s from lvalue subroutine",
2369 ro ? "readonly value" : "temporary");
2375 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2378 PL_stack_sp = newsp;
2385 bool popsub2 = FALSE;
2386 bool clear_errsv = FALSE;
2396 const I32 cxix = dopoptosub(cxstack_ix);
2399 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2400 * sort block, which is a CXt_NULL
2403 PL_stack_base[1] = *PL_stack_sp;
2404 PL_stack_sp = PL_stack_base + 1;
2408 DIE(aTHX_ "Can't return outside a subroutine");
2410 if (cxix < cxstack_ix)
2413 if (CxMULTICALL(&cxstack[cxix])) {
2414 gimme = cxstack[cxix].blk_gimme;
2415 if (gimme == G_VOID)
2416 PL_stack_sp = PL_stack_base;
2417 else if (gimme == G_SCALAR) {
2418 PL_stack_base[1] = *PL_stack_sp;
2419 PL_stack_sp = PL_stack_base + 1;
2425 switch (CxTYPE(cx)) {
2428 lval = !!CvLVALUE(cx->blk_sub.cv);
2429 retop = cx->blk_sub.retop;
2430 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2433 if (!(PL_in_eval & EVAL_KEEPERR))
2436 namesv = cx->blk_eval.old_namesv;
2437 retop = cx->blk_eval.retop;
2440 if (optype == OP_REQUIRE &&
2441 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2443 /* Unassume the success we assumed earlier. */
2444 (void)hv_delete(GvHVn(PL_incgv),
2445 SvPVX_const(namesv),
2446 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2448 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2452 retop = cx->blk_sub.retop;
2456 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2460 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2462 if (gimme == G_SCALAR) {
2465 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2466 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2467 && !SvMAGICAL(TOPs)) {
2468 *++newsp = SvREFCNT_inc(*SP);
2473 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2475 *++newsp = sv_mortalcopy(sv);
2479 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2480 && !SvMAGICAL(*SP)) {
2484 *++newsp = sv_mortalcopy(*SP);
2487 *++newsp = sv_mortalcopy(*SP);
2490 *++newsp = &PL_sv_undef;
2492 else if (gimme == G_ARRAY) {
2493 while (++MARK <= SP) {
2494 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2495 && !SvGMAGICAL(*MARK)
2496 ? *MARK : sv_mortalcopy(*MARK);
2497 TAINT_NOT; /* Each item is independent */
2500 PL_stack_sp = newsp;
2504 /* Stack values are safe: */
2507 POPSUB(cx,sv); /* release CV and @_ ... */
2511 PL_curpm = newpm; /* ... and pop $1 et al */
2520 /* This duplicates parts of pp_leavesub, so that it can share code with
2531 if (CxMULTICALL(&cxstack[cxstack_ix]))
2535 cxstack_ix++; /* temporarily protect top context */
2539 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2542 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2544 PL_curpm = newpm; /* ... and pop $1 et al */
2547 return cx->blk_sub.retop;
2551 S_unwind_loop(pTHX_ const char * const opname)
2554 if (PL_op->op_flags & OPf_SPECIAL) {
2555 cxix = dopoptoloop(cxstack_ix);
2557 /* diag_listed_as: Can't "last" outside a loop block */
2558 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2563 const char * const label =
2564 PL_op->op_flags & OPf_STACKED
2565 ? SvPV(TOPs,label_len)
2566 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2567 const U32 label_flags =
2568 PL_op->op_flags & OPf_STACKED
2570 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2572 cxix = dopoptolabel(label, label_len, label_flags);
2574 /* diag_listed_as: Label not found for "last %s" */
2575 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2577 SVfARG(PL_op->op_flags & OPf_STACKED
2578 && !SvGMAGICAL(TOPp1s)
2580 : newSVpvn_flags(label,
2582 label_flags | SVs_TEMP)));
2584 if (cxix < cxstack_ix)
2600 S_unwind_loop(aTHX_ "last");
2603 cxstack_ix++; /* temporarily protect top context */
2604 switch (CxTYPE(cx)) {
2605 case CXt_LOOP_LAZYIV:
2606 case CXt_LOOP_LAZYSV:
2608 case CXt_LOOP_PLAIN:
2610 newsp = PL_stack_base + cx->blk_loop.resetsp;
2611 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2615 nextop = cx->blk_sub.retop;
2619 nextop = cx->blk_eval.retop;
2623 nextop = cx->blk_sub.retop;
2626 DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2630 PL_stack_sp = newsp;
2634 /* Stack values are safe: */
2636 case CXt_LOOP_LAZYIV:
2637 case CXt_LOOP_PLAIN:
2638 case CXt_LOOP_LAZYSV:
2640 POPLOOP(cx); /* release loop vars ... */
2644 POPSUB(cx,sv); /* release CV and @_ ... */
2647 PL_curpm = newpm; /* ... and pop $1 et al */
2650 PERL_UNUSED_VAR(optype);
2651 PERL_UNUSED_VAR(gimme);
2658 const I32 inner = PL_scopestack_ix;
2660 S_unwind_loop(aTHX_ "next");
2662 /* clear off anything above the scope we're re-entering, but
2663 * save the rest until after a possible continue block */
2665 if (PL_scopestack_ix < inner)
2666 leave_scope(PL_scopestack[PL_scopestack_ix]);
2667 PL_curcop = cx->blk_oldcop;
2669 return (cx)->blk_loop.my_op->op_nextop;
2674 const I32 cxix = S_unwind_loop(aTHX_ "redo");
2677 OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2679 if (redo_op->op_type == OP_ENTER) {
2680 /* pop one less context to avoid $x being freed in while (my $x..) */
2682 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2683 redo_op = redo_op->op_next;
2687 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2688 LEAVE_SCOPE(oldsave);
2690 PL_curcop = cx->blk_oldcop;
2696 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2699 static const char* const too_deep = "Target of goto is too deeply nested";
2701 PERL_ARGS_ASSERT_DOFINDLABEL;
2704 Perl_croak(aTHX_ "%s", too_deep);
2705 if (o->op_type == OP_LEAVE ||
2706 o->op_type == OP_SCOPE ||
2707 o->op_type == OP_LEAVELOOP ||
2708 o->op_type == OP_LEAVESUB ||
2709 o->op_type == OP_LEAVETRY)
2711 *ops++ = cUNOPo->op_first;
2713 Perl_croak(aTHX_ "%s", too_deep);
2716 if (o->op_flags & OPf_KIDS) {
2718 /* First try all the kids at this level, since that's likeliest. */
2719 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2720 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2721 STRLEN kid_label_len;
2722 U32 kid_label_flags;
2723 const char *kid_label = CopLABEL_len_flags(kCOP,
2724 &kid_label_len, &kid_label_flags);
2726 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2729 (const U8*)kid_label, kid_label_len,
2730 (const U8*)label, len) == 0)
2732 (const U8*)label, len,
2733 (const U8*)kid_label, kid_label_len) == 0)
2734 : ( len == kid_label_len && ((kid_label == label)
2735 || memEQ(kid_label, label, len)))))
2739 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2740 if (kid == PL_lastgotoprobe)
2742 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2745 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2746 ops[-1]->op_type == OP_DBSTATE)
2751 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2760 /* also used for: pp_dump() */
2768 #define GOTO_DEPTH 64
2769 OP *enterops[GOTO_DEPTH];
2770 const char *label = NULL;
2771 STRLEN label_len = 0;
2772 U32 label_flags = 0;
2773 const bool do_dump = (PL_op->op_type == OP_DUMP);
2774 static const char* const must_have_label = "goto must have label";
2776 if (PL_op->op_flags & OPf_STACKED) {
2777 /* goto EXPR or goto &foo */
2779 SV * const sv = POPs;
2782 /* This egregious kludge implements goto &subroutine */
2783 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2786 CV *cv = MUTABLE_CV(SvRV(sv));
2787 AV *arg = GvAV(PL_defgv);
2791 if (!CvROOT(cv) && !CvXSUB(cv)) {
2792 const GV * const gv = CvGV(cv);
2796 /* autoloaded stub? */
2797 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2799 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2801 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2802 if (autogv && (cv = GvCV(autogv)))
2804 tmpstr = sv_newmortal();
2805 gv_efullname3(tmpstr, gv, NULL);
2806 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2808 DIE(aTHX_ "Goto undefined subroutine");
2811 /* First do some returnish stuff. */
2812 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2814 cxix = dopoptosub(cxstack_ix);
2815 if (cxix < cxstack_ix) {
2818 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2824 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2825 if (CxTYPE(cx) == CXt_EVAL) {
2828 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2829 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2831 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2832 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2834 else if (CxMULTICALL(cx))
2837 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2839 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2840 AV* av = cx->blk_sub.argarray;
2842 /* abandon the original @_ if it got reified or if it is
2843 the same as the current @_ */
2844 if (AvREAL(av) || av == arg) {
2848 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2850 else CLEAR_ARGARRAY(av);
2852 /* We donate this refcount later to the callee’s pad. */
2853 SvREFCNT_inc_simple_void(arg);
2854 if (CxTYPE(cx) == CXt_SUB &&
2855 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2856 SvREFCNT_dec(cx->blk_sub.cv);
2857 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2858 LEAVE_SCOPE(oldsave);
2860 /* A destructor called during LEAVE_SCOPE could have undefined
2861 * our precious cv. See bug #99850. */
2862 if (!CvROOT(cv) && !CvXSUB(cv)) {
2863 const GV * const gv = CvGV(cv);
2866 SV * const tmpstr = sv_newmortal();
2867 gv_efullname3(tmpstr, gv, NULL);
2868 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2871 DIE(aTHX_ "Goto undefined subroutine");
2874 /* Now do some callish stuff. */
2876 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2880 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2881 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2884 PERL_UNUSED_VAR(newsp);
2885 PERL_UNUSED_VAR(gimme);
2887 /* put GvAV(defgv) back onto stack */
2889 EXTEND(SP, items+1); /* @_ could have been extended. */
2894 bool r = cBOOL(AvREAL(arg));
2895 for (index=0; index<items; index++)
2899 SV ** const svp = av_fetch(arg, index, 0);
2900 sv = svp ? *svp : NULL;
2902 else sv = AvARRAY(arg)[index];
2904 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2905 : sv_2mortal(newSVavdefelem(arg, index, 1));
2910 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2911 /* Restore old @_ */
2912 arg = GvAV(PL_defgv);
2913 GvAV(PL_defgv) = cx->blk_sub.savearray;
2917 retop = cx->blk_sub.retop;
2918 /* XS subs don't have a CxSUB, so pop it */
2919 POPBLOCK(cx, PL_curpm);
2920 /* Push a mark for the start of arglist */
2923 (void)(*CvXSUB(cv))(aTHX_ cv);
2928 PADLIST * const padlist = CvPADLIST(cv);
2929 cx->blk_sub.cv = cv;
2930 cx->blk_sub.olddepth = CvDEPTH(cv);
2933 if (CvDEPTH(cv) < 2)
2934 SvREFCNT_inc_simple_void_NN(cv);
2936 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2937 sub_crush_depth(cv);
2938 pad_push(padlist, CvDEPTH(cv));
2940 PL_curcop = cx->blk_oldcop;
2942 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2945 CX_CURPAD_SAVE(cx->blk_sub);
2947 /* cx->blk_sub.argarray has no reference count, so we
2948 need something to hang on to our argument array so
2949 that cx->blk_sub.argarray does not end up pointing
2950 to freed memory as the result of undef *_. So put
2951 it in the callee’s pad, donating our refer-
2954 SvREFCNT_dec(PAD_SVl(0));
2955 PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2958 /* GvAV(PL_defgv) might have been modified on scope
2959 exit, so restore it. */
2960 if (arg != GvAV(PL_defgv)) {
2961 AV * const av = GvAV(PL_defgv);
2962 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2966 else SvREFCNT_dec(arg);
2967 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2968 Perl_get_db_sub(aTHX_ NULL, cv);
2970 CV * const gotocv = get_cvs("DB::goto", 0);
2972 PUSHMARK( PL_stack_sp );
2973 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2978 retop = CvSTART(cv);
2979 goto putback_return;
2984 label = SvPV_nomg_const(sv, label_len);
2985 label_flags = SvUTF8(sv);
2988 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2989 /* goto LABEL or dump LABEL */
2990 label = cPVOP->op_pv;
2991 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2992 label_len = strlen(label);
2994 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2999 OP *gotoprobe = NULL;
3000 bool leaving_eval = FALSE;
3001 bool in_block = FALSE;
3002 PERL_CONTEXT *last_eval_cx = NULL;
3006 PL_lastgotoprobe = NULL;
3008 for (ix = cxstack_ix; ix >= 0; ix--) {
3010 switch (CxTYPE(cx)) {
3012 leaving_eval = TRUE;
3013 if (!CxTRYBLOCK(cx)) {
3014 gotoprobe = (last_eval_cx ?
3015 last_eval_cx->blk_eval.old_eval_root :
3020 /* else fall through */
3021 case CXt_LOOP_LAZYIV:
3022 case CXt_LOOP_LAZYSV:
3024 case CXt_LOOP_PLAIN:
3027 gotoprobe = OpSIBLING(cx->blk_oldcop);
3033 gotoprobe = OpSIBLING(cx->blk_oldcop);
3036 gotoprobe = PL_main_root;
3039 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3040 gotoprobe = CvROOT(cx->blk_sub.cv);
3046 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3049 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3050 CxTYPE(cx), (long) ix);
3051 gotoprobe = PL_main_root;
3057 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3058 enterops, enterops + GOTO_DEPTH);
3061 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3062 sibl1->op_type == OP_UNSTACK &&
3063 (sibl2 = OpSIBLING(sibl1)))
3065 retop = dofindlabel(sibl2,
3066 label, label_len, label_flags, enterops,
3067 enterops + GOTO_DEPTH);
3072 PL_lastgotoprobe = gotoprobe;
3075 DIE(aTHX_ "Can't find label %"UTF8f,
3076 UTF8fARG(label_flags, label_len, label));
3078 /* if we're leaving an eval, check before we pop any frames
3079 that we're not going to punt, otherwise the error
3082 if (leaving_eval && *enterops && enterops[1]) {
3084 for (i = 1; enterops[i]; i++)
3085 if (enterops[i]->op_type == OP_ENTERITER)
3086 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3089 if (*enterops && enterops[1]) {
3090 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3092 deprecate("\"goto\" to jump into a construct");
3095 /* pop unwanted frames */
3097 if (ix < cxstack_ix) {
3101 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3104 oldsave = PL_scopestack[PL_scopestack_ix];
3105 LEAVE_SCOPE(oldsave);
3108 /* push wanted frames */
3110 if (*enterops && enterops[1]) {
3111 OP * const oldop = PL_op;
3112 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3113 for (; enterops[ix]; ix++) {
3114 PL_op = enterops[ix];
3115 /* Eventually we may want to stack the needed arguments
3116 * for each op. For now, we punt on the hard ones. */
3117 if (PL_op->op_type == OP_ENTERITER)
3118 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3119 PL_op->op_ppaddr(aTHX);
3127 if (!retop) retop = PL_main_start;
3129 PL_restartop = retop;
3130 PL_do_undump = TRUE;
3134 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3135 PL_do_undump = FALSE;
3153 anum = 0; (void)POPs;
3159 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3162 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3165 PL_exit_flags |= PERL_EXIT_EXPECTED;
3167 PUSHs(&PL_sv_undef);
3174 S_save_lines(pTHX_ AV *array, SV *sv)
3176 const char *s = SvPVX_const(sv);
3177 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3180 PERL_ARGS_ASSERT_SAVE_LINES;
3182 while (s && s < send) {
3184 SV * const tmpstr = newSV_type(SVt_PVMG);
3186 t = (const char *)memchr(s, '\n', send - s);
3192 sv_setpvn(tmpstr, s, t - s);
3193 av_store(array, line++, tmpstr);
3201 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3203 0 is used as continue inside eval,
3205 3 is used for a die caught by an inner eval - continue inner loop
3207 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3208 establish a local jmpenv to handle exception traps.
3213 S_docatch(pTHX_ OP *o)
3216 OP * const oldop = PL_op;
3220 assert(CATCH_GET == TRUE);
3227 assert(cxstack_ix >= 0);
3228 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3229 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3234 /* die caught by an inner eval - continue inner loop */
3235 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3236 PL_restartjmpenv = NULL;
3237 PL_op = PL_restartop;
3246 NOT_REACHED; /* NOTREACHED */
3255 =for apidoc find_runcv
3257 Locate the CV corresponding to the currently executing sub or eval.
3258 If db_seqp is non_null, skip CVs that are in the DB package and populate
3259 *db_seqp with the cop sequence number at the point that the DB:: code was
3260 entered. (This allows debuggers to eval in the scope of the breakpoint
3261 rather than in the scope of the debugger itself.)
3267 Perl_find_runcv(pTHX_ U32 *db_seqp)
3269 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3272 /* If this becomes part of the API, it might need a better name. */
3274 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3281 PL_curcop == &PL_compiling
3283 : PL_curcop->cop_seq;
3285 for (si = PL_curstackinfo; si; si = si->si_prev) {
3287 for (ix = si->si_cxix; ix >= 0; ix--) {
3288 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3290 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3291 cv = cx->blk_sub.cv;
3292 /* skip DB:: code */
3293 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3294 *db_seqp = cx->blk_oldcop->cop_seq;
3297 if (cx->cx_type & CXp_SUB_RE)
3300 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3301 cv = cx->blk_eval.cv;
3304 case FIND_RUNCV_padid_eq:
3306 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3309 case FIND_RUNCV_level_eq:
3310 if (level++ != arg) continue;
3318 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3322 /* Run yyparse() in a setjmp wrapper. Returns:
3323 * 0: yyparse() successful
3324 * 1: yyparse() failed
3328 S_try_yyparse(pTHX_ int gramtype)
3333 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3337 ret = yyparse(gramtype) ? 1 : 0;
3344 NOT_REACHED; /* NOTREACHED */
3351 /* Compile a require/do or an eval ''.
3353 * outside is the lexically enclosing CV (if any) that invoked us.
3354 * seq is the current COP scope value.
3355 * hh is the saved hints hash, if any.
3357 * Returns a bool indicating whether the compile was successful; if so,
3358 * PL_eval_start contains the first op of the compiled code; otherwise,
3361 * This function is called from two places: pp_require and pp_entereval.
3362 * These can be distinguished by whether PL_op is entereval.
3366 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3369 OP * const saveop = PL_op;
3370 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3371 COP * const oldcurcop = PL_curcop;
3372 bool in_require = (saveop->op_type == OP_REQUIRE);
3376 PL_in_eval = (in_require
3377 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3379 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3380 ? EVAL_RE_REPARSING : 0)));
3384 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3386 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3387 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3388 cxstack[cxstack_ix].blk_gimme = gimme;
3390 CvOUTSIDE_SEQ(evalcv) = seq;
3391 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3393 /* set up a scratch pad */
3395 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3396 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3399 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3401 /* make sure we compile in the right package */
3403 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3404 SAVEGENERICSV(PL_curstash);
3405 PL_curstash = (HV *)CopSTASH(PL_curcop);
3406 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3407 else SvREFCNT_inc_simple_void(PL_curstash);
3409 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3410 SAVESPTR(PL_beginav);
3411 PL_beginav = newAV();
3412 SAVEFREESV(PL_beginav);
3413 SAVESPTR(PL_unitcheckav);
3414 PL_unitcheckav = newAV();
3415 SAVEFREESV(PL_unitcheckav);
3418 ENTER_with_name("evalcomp");
3419 SAVESPTR(PL_compcv);
3422 /* try to compile it */
3424 PL_eval_root = NULL;
3425 PL_curcop = &PL_compiling;
3426 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3427 PL_in_eval |= EVAL_KEEPERR;
3434 hv_clear(GvHV(PL_hintgv));
3437 PL_hints = saveop->op_private & OPpEVAL_COPHH
3438 ? oldcurcop->cop_hints : saveop->op_targ;
3440 /* making 'use re eval' not be in scope when compiling the
3441 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3442 * infinite recursion when S_has_runtime_code() gives a false
3443 * positive: the second time round, HINT_RE_EVAL isn't set so we
3444 * don't bother calling S_has_runtime_code() */
3445 if (PL_in_eval & EVAL_RE_REPARSING)
3446 PL_hints &= ~HINT_RE_EVAL;
3449 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3450 SvREFCNT_dec(GvHV(PL_hintgv));
3451 GvHV(PL_hintgv) = hh;
3454 SAVECOMPILEWARNINGS();
3456 if (PL_dowarn & G_WARN_ALL_ON)
3457 PL_compiling.cop_warnings = pWARN_ALL ;
3458 else if (PL_dowarn & G_WARN_ALL_OFF)
3459 PL_compiling.cop_warnings = pWARN_NONE ;
3461 PL_compiling.cop_warnings = pWARN_STD ;
3464 PL_compiling.cop_warnings =
3465 DUP_WARNINGS(oldcurcop->cop_warnings);
3466 cophh_free(CopHINTHASH_get(&PL_compiling));
3467 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3468 /* The label, if present, is the first entry on the chain. So rather
3469 than writing a blank label in front of it (which involves an
3470 allocation), just use the next entry in the chain. */
3471 PL_compiling.cop_hints_hash
3472 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3473 /* Check the assumption that this removed the label. */
3474 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3477 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3480 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3482 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3483 * so honour CATCH_GET and trap it here if necessary */
3485 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3487 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3488 SV **newsp; /* Used by POPBLOCK. */
3490 I32 optype; /* Used by POPEVAL. */
3496 PERL_UNUSED_VAR(newsp);
3497 PERL_UNUSED_VAR(optype);
3499 /* note that if yystatus == 3, then the EVAL CX block has already
3500 * been popped, and various vars restored */
3502 if (yystatus != 3) {
3504 op_free(PL_eval_root);
3505 PL_eval_root = NULL;
3507 SP = PL_stack_base + POPMARK; /* pop original mark */
3508 POPBLOCK(cx,PL_curpm);
3510 namesv = cx->blk_eval.old_namesv;
3511 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3512 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3518 /* If cx is still NULL, it means that we didn't go in the
3519 * POPEVAL branch. */
3520 cx = &cxstack[cxstack_ix];
3521 assert(CxTYPE(cx) == CXt_EVAL);
3522 namesv = cx->blk_eval.old_namesv;
3524 (void)hv_store(GvHVn(PL_incgv),
3525 SvPVX_const(namesv),
3526 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3528 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3531 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3534 if (!*(SvPV_nolen_const(errsv))) {
3535 sv_setpvs(errsv, "Compilation error");
3538 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3543 LEAVE_with_name("evalcomp");
3545 CopLINE_set(&PL_compiling, 0);
3546 SAVEFREEOP(PL_eval_root);
3547 cv_forget_slab(evalcv);
3549 DEBUG_x(dump_eval());
3551 /* Register with debugger: */
3552 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3553 CV * const cv = get_cvs("DB::postponed", 0);
3557 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3559 call_sv(MUTABLE_SV(cv), G_DISCARD);
3563 if (PL_unitcheckav) {
3564 OP *es = PL_eval_start;
3565 call_list(PL_scopestack_ix, PL_unitcheckav);
3569 /* compiled okay, so do it */
3571 CvDEPTH(evalcv) = 1;
3572 SP = PL_stack_base + POPMARK; /* pop original mark */
3573 PL_op = saveop; /* The caller may need it. */
3574 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3581 S_check_type_and_open(pTHX_ SV *name)
3586 const char *p = SvPV_const(name, len);
3589 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3591 /* checking here captures a reasonable error message when
3592 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3593 * user gets a confusing message about looking for the .pmc file
3594 * rather than for the .pm file.
3595 * This check prevents a \0 in @INC causing problems.
3597 if (!IS_SAFE_PATHNAME(p, len, "require"))
3600 /* on Win32 stat is expensive (it does an open() and close() twice and
3601 a couple other IO calls), the open will fail with a dir on its own with
3602 errno EACCES, so only do a stat to separate a dir from a real EACCES
3603 caused by user perms */
3605 /* we use the value of errno later to see how stat() or open() failed.
3606 * We don't want it set if the stat succeeded but we still failed,
3607 * such as if the name exists, but is a directory */
3610 st_rc = PerlLIO_stat(p, &st);
3612 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3617 #if !defined(PERLIO_IS_STDIO)
3618 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3620 retio = PerlIO_open(p, PERL_SCRIPT_MODE);
3623 /* EACCES stops the INC search early in pp_require to implement
3624 feature RT #113422 */
3625 if(!retio && errno == EACCES) { /* exists but probably a directory */
3627 st_rc = PerlLIO_stat(p, &st);
3629 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3640 #ifndef PERL_DISABLE_PMC
3642 S_doopen_pm(pTHX_ SV *name)
3645 const char *p = SvPV_const(name, namelen);
3647 PERL_ARGS_ASSERT_DOOPEN_PM;
3649 /* check the name before trying for the .pmc name to avoid the
3650 * warning referring to the .pmc which the user probably doesn't
3651 * know or care about
3653 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3656 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3657 SV *const pmcsv = sv_newmortal();
3660 SvSetSV_nosteal(pmcsv,name);
3661 sv_catpvs(pmcsv, "c");
3663 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3664 return check_type_and_open(pmcsv);
3666 return check_type_and_open(name);
3669 # define doopen_pm(name) check_type_and_open(name)
3670 #endif /* !PERL_DISABLE_PMC */
3672 /* require doesn't search for absolute names, or when the name is
3673 explicitly relative the current directory */
3674 PERL_STATIC_INLINE bool
3675 S_path_is_searchable(const char *name)
3677 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3679 if (PERL_FILE_IS_ABSOLUTE(name)
3681 || (*name == '.' && ((name[1] == '/' ||
3682 (name[1] == '.' && name[2] == '/'))
3683 || (name[1] == '\\' ||
3684 ( name[1] == '.' && name[2] == '\\')))
3687 || (*name == '.' && (name[1] == '/' ||
3688 (name[1] == '.' && name[2] == '/')))
3699 /* also used for: pp_dofile() */
3711 int vms_unixname = 0;
3714 const char *tryname = NULL;
3716 const I32 gimme = GIMME_V;
3717 int filter_has_file = 0;
3718 PerlIO *tryrsfp = NULL;
3719 SV *filter_cache = NULL;
3720 SV *filter_state = NULL;
3721 SV *filter_sub = NULL;
3725 bool path_searchable;
3729 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3730 sv = sv_2mortal(new_version(sv));
3731 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3732 upg_version(PL_patchlevel, TRUE);
3733 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3734 if ( vcmp(sv,PL_patchlevel) <= 0 )
3735 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3736 SVfARG(sv_2mortal(vnormal(sv))),
3737 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3741 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3744 SV * const req = SvRV(sv);
3745 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3747 /* get the left hand term */
3748 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3750 first = SvIV(*av_fetch(lav,0,0));
3751 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3752 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3753 || av_tindex(lav) > 1 /* FP with > 3 digits */
3754 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3756 DIE(aTHX_ "Perl %"SVf" required--this is only "
3758 SVfARG(sv_2mortal(vnormal(req))),
3759 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3762 else { /* probably 'use 5.10' or 'use 5.8' */
3766 if (av_tindex(lav)>=1)
3767 second = SvIV(*av_fetch(lav,1,0));
3769 second /= second >= 600 ? 100 : 10;
3770 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3771 (int)first, (int)second);
3772 upg_version(hintsv, TRUE);
3774 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3775 "--this is only %"SVf", stopped",
3776 SVfARG(sv_2mortal(vnormal(req))),
3777 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3778 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3787 DIE(aTHX_ "Missing or undefined argument to require");
3788 name = SvPV_nomg_const(sv, len);
3789 if (!(name && len > 0 && *name))
3790 DIE(aTHX_ "Missing or undefined argument to require");
3792 if (!IS_SAFE_PATHNAME(name, len, "require")) {
3793 DIE(aTHX_ "Can't locate %s: %s",
3794 pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3795 SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3798 TAINT_PROPER("require");
3800 path_searchable = path_is_searchable(name);
3803 /* The key in the %ENV hash is in the syntax of file passed as the argument
3804 * usually this is in UNIX format, but sometimes in VMS format, which
3805 * can result in a module being pulled in more than once.
3806 * To prevent this, the key must be stored in UNIX format if the VMS
3807 * name can be translated to UNIX.
3811 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3813 unixlen = strlen(unixname);
3819 /* if not VMS or VMS name can not be translated to UNIX, pass it
3822 unixname = (char *) name;
3825 if (PL_op->op_type == OP_REQUIRE) {
3826 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3827 unixname, unixlen, 0);
3829 if (*svp != &PL_sv_undef)
3832 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3833 "Compilation failed in require", unixname);
3837 LOADING_FILE_PROBE(unixname);
3839 /* prepare to compile file */
3841 if (!path_searchable) {
3842 /* At this point, name is SvPVX(sv) */
3844 tryrsfp = doopen_pm(sv);
3846 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3847 AV * const ar = GvAVn(PL_incgv);
3854 namesv = newSV_type(SVt_PV);
3855 for (i = 0; i <= AvFILL(ar); i++) {
3856 SV * const dirsv = *av_fetch(ar, i, TRUE);
3864 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3865 && !SvOBJECT(SvRV(loader)))
3867 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3871 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3872 PTR2UV(SvRV(dirsv)), name);
3873 tryname = SvPVX_const(namesv);
3876 if (SvPADTMP(nsv)) {
3877 nsv = sv_newmortal();
3878 SvSetSV_nosteal(nsv,sv);
3881 ENTER_with_name("call_INC");
3889 if (SvGMAGICAL(loader)) {
3890 SV *l = sv_newmortal();
3891 sv_setsv_nomg(l, loader);
3894 if (sv_isobject(loader))
3895 count = call_method("INC", G_ARRAY);
3897 count = call_sv(loader, G_ARRAY);
3907 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3908 && !isGV_with_GP(SvRV(arg))) {
3909 filter_cache = SvRV(arg);
3916 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3920 if (isGV_with_GP(arg)) {
3921 IO * const io = GvIO((const GV *)arg);
3926 tryrsfp = IoIFP(io);
3927 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3928 PerlIO_close(IoOFP(io));
3939 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3941 SvREFCNT_inc_simple_void_NN(filter_sub);
3944 filter_state = SP[i];
3945 SvREFCNT_inc_simple_void(filter_state);
3949 if (!tryrsfp && (filter_cache || filter_sub)) {
3950 tryrsfp = PerlIO_open(BIT_BUCKET,
3956 /* FREETMPS may free our filter_cache */
3957 SvREFCNT_inc_simple_void(filter_cache);
3961 LEAVE_with_name("call_INC");
3963 /* Now re-mortalize it. */
3964 sv_2mortal(filter_cache);
3966 /* Adjust file name if the hook has set an %INC entry.
3967 This needs to happen after the FREETMPS above. */
3968 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3970 tryname = SvPV_nolen_const(*svp);
3977 filter_has_file = 0;
3978 filter_cache = NULL;
3980 SvREFCNT_dec_NN(filter_state);
3981 filter_state = NULL;
3984 SvREFCNT_dec_NN(filter_sub);
3989 if (path_searchable) {
3994 dir = SvPV_nomg_const(dirsv, dirlen);
4000 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
4004 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4007 sv_setpv(namesv, unixdir);
4008 sv_catpv(namesv, unixname);
4010 # ifdef __SYMBIAN32__
4011 if (PL_origfilename[0] &&
4012 PL_origfilename[1] == ':' &&
4013 !(dir[0] && dir[1] == ':'))
4014 Perl_sv_setpvf(aTHX_ namesv,
4019 Perl_sv_setpvf(aTHX_ namesv,
4023 /* The equivalent of
4024 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4025 but without the need to parse the format string, or
4026 call strlen on either pointer, and with the correct
4027 allocation up front. */
4029 char *tmp = SvGROW(namesv, dirlen + len + 2);
4031 memcpy(tmp, dir, dirlen);
4034 /* Avoid '<dir>//<file>' */
4035 if (!dirlen || *(tmp-1) != '/') {
4038 /* So SvCUR_set reports the correct length below */
4042 /* name came from an SV, so it will have a '\0' at the
4043 end that we can copy as part of this memcpy(). */
4044 memcpy(tmp, name, len + 1);
4046 SvCUR_set(namesv, dirlen + len + 1);
4051 TAINT_PROPER("require");
4052 tryname = SvPVX_const(namesv);
4053 tryrsfp = doopen_pm(namesv);
4055 if (tryname[0] == '.' && tryname[1] == '/') {
4057 while (*++tryname == '/') {}
4061 else if (errno == EMFILE || errno == EACCES) {
4062 /* no point in trying other paths if out of handles;
4063 * on the other hand, if we couldn't open one of the
4064 * files, then going on with the search could lead to
4065 * unexpected results; see perl #113422
4074 saved_errno = errno; /* sv_2mortal can realloc things */
4077 if (PL_op->op_type == OP_REQUIRE) {
4078 if(saved_errno == EMFILE || saved_errno == EACCES) {
4079 /* diag_listed_as: Can't locate %s */
4080 DIE(aTHX_ "Can't locate %s: %s: %s",
4081 name, tryname, Strerror(saved_errno));
4083 if (namesv) { /* did we lookup @INC? */
4084 AV * const ar = GvAVn(PL_incgv);
4086 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4087 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4088 for (i = 0; i <= AvFILL(ar); i++) {
4089 sv_catpvs(inc, " ");
4090 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4092 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4093 const char *c, *e = name + len - 3;
4094 sv_catpv(msg, " (you may need to install the ");
4095 for (c = name; c < e; c++) {
4097 sv_catpvs(msg, "::");
4100 sv_catpvn(msg, c, 1);
4103 sv_catpv(msg, " module)");
4105 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4106 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4108 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4109 sv_catpv(msg, " (did you run h2ph?)");
4112 /* diag_listed_as: Can't locate %s */
4114 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4118 DIE(aTHX_ "Can't locate %s", name);
4125 SETERRNO(0, SS_NORMAL);
4127 /* Assume success here to prevent recursive requirement. */
4128 /* name is never assigned to again, so len is still strlen(name) */
4129 /* Check whether a hook in @INC has already filled %INC */
4131 (void)hv_store(GvHVn(PL_incgv),
4132 unixname, unixlen, newSVpv(tryname,0),0);
4134 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4136 (void)hv_store(GvHVn(PL_incgv),
4137 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4140 ENTER_with_name("eval");
4142 SAVECOPFILE_FREE(&PL_compiling);
4143 CopFILE_set(&PL_compiling, tryname);
4144 lex_start(NULL, tryrsfp, 0);
4146 if (filter_sub || filter_cache) {
4147 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4148 than hanging another SV from it. In turn, filter_add() optionally
4149 takes the SV to use as the filter (or creates a new SV if passed
4150 NULL), so simply pass in whatever value filter_cache has. */
4151 SV * const fc = filter_cache ? newSV(0) : NULL;
4153 if (fc) sv_copypv(fc, filter_cache);
4154 datasv = filter_add(S_run_user_filter, fc);
4155 IoLINES(datasv) = filter_has_file;
4156 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4157 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4160 /* switch to eval mode */
4161 PUSHBLOCK(cx, CXt_EVAL, SP);
4163 cx->blk_eval.retop = PL_op->op_next;
4165 SAVECOPLINE(&PL_compiling);
4166 CopLINE_set(&PL_compiling, 0);
4170 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4171 op = DOCATCH(PL_eval_start);
4173 op = PL_op->op_next;
4175 LOADED_FILE_PROBE(unixname);
4180 /* This is a op added to hold the hints hash for
4181 pp_entereval. The hash can be modified by the code
4182 being eval'ed, so we return a copy instead. */
4187 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4197 const I32 gimme = GIMME_V;
4198 const U32 was = PL_breakable_sub_gen;
4199 char tbuf[TYPE_DIGITS(long) + 12];
4200 bool saved_delete = FALSE;
4201 char *tmpbuf = tbuf;
4204 U32 seq, lex_flags = 0;
4205 HV *saved_hh = NULL;
4206 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4208 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4209 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4211 else if (PL_hints & HINT_LOCALIZE_HH || (
4212 PL_op->op_private & OPpEVAL_COPHH
4213 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4215 saved_hh = cop_hints_2hv(PL_curcop, 0);
4216 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4220 /* make sure we've got a plain PV (no overload etc) before testing
4221 * for taint. Making a copy here is probably overkill, but better
4222 * safe than sorry */
4224 const char * const p = SvPV_const(sv, len);
4226 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4227 lex_flags |= LEX_START_COPIED;
4229 if (bytes && SvUTF8(sv))
4230 SvPVbyte_force(sv, len);
4232 else if (bytes && SvUTF8(sv)) {
4233 /* Don't modify someone else's scalar */
4236 (void)sv_2mortal(sv);
4237 SvPVbyte_force(sv,len);
4238 lex_flags |= LEX_START_COPIED;
4241 TAINT_IF(SvTAINTED(sv));
4242 TAINT_PROPER("eval");
4244 ENTER_with_name("eval");
4245 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4246 ? LEX_IGNORE_UTF8_HINTS
4247 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4252 /* switch to eval mode */
4254 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4255 SV * const temp_sv = sv_newmortal();
4256 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4257 (unsigned long)++PL_evalseq,
4258 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4259 tmpbuf = SvPVX(temp_sv);
4260 len = SvCUR(temp_sv);
4263 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4264 SAVECOPFILE_FREE(&PL_compiling);
4265 CopFILE_set(&PL_compiling, tmpbuf+2);
4266 SAVECOPLINE(&PL_compiling);
4267 CopLINE_set(&PL_compiling, 1);
4268 /* special case: an eval '' executed within the DB package gets lexically
4269 * placed in the first non-DB CV rather than the current CV - this
4270 * allows the debugger to execute code, find lexicals etc, in the
4271 * scope of the code being debugged. Passing &seq gets find_runcv
4272 * to do the dirty work for us */
4273 runcv = find_runcv(&seq);
4275 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4277 cx->blk_eval.retop = PL_op->op_next;
4279 /* prepare to compile string */
4281 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4282 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4284 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4285 deleting the eval's FILEGV from the stash before gv_check() runs
4286 (i.e. before run-time proper). To work around the coredump that
4287 ensues, we always turn GvMULTI_on for any globals that were
4288 introduced within evals. See force_ident(). GSAR 96-10-12 */
4289 char *const safestr = savepvn(tmpbuf, len);
4290 SAVEDELETE(PL_defstash, safestr, len);
4291 saved_delete = TRUE;
4296 if (doeval(gimme, runcv, seq, saved_hh)) {
4297 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4298 ? (PERLDB_LINE || PERLDB_SAVESRC)
4299 : PERLDB_SAVESRC_NOSUBS) {
4300 /* Retain the filegv we created. */
4301 } else if (!saved_delete) {
4302 char *const safestr = savepvn(tmpbuf, len);
4303 SAVEDELETE(PL_defstash, safestr, len);
4305 return DOCATCH(PL_eval_start);
4307 /* We have already left the scope set up earlier thanks to the LEAVE
4309 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4310 ? (PERLDB_LINE || PERLDB_SAVESRC)
4311 : PERLDB_SAVESRC_INVALID) {
4312 /* Retain the filegv we created. */
4313 } else if (!saved_delete) {
4314 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4316 return PL_op->op_next;
4328 const U8 save_flags = PL_op -> op_flags;
4336 namesv = cx->blk_eval.old_namesv;
4337 retop = cx->blk_eval.retop;
4338 evalcv = cx->blk_eval.cv;
4340 SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
4341 gimme, SVs_TEMP, FALSE);
4342 PL_curpm = newpm; /* Don't pop $1 et al till now */
4345 assert(CvDEPTH(evalcv) == 1);
4347 CvDEPTH(evalcv) = 0;
4349 if (optype == OP_REQUIRE &&
4350 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4352 /* Unassume the success we assumed earlier. */
4353 (void)hv_delete(GvHVn(PL_incgv),
4354 SvPVX_const(namesv),
4355 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4357 Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4358 NOT_REACHED; /* NOTREACHED */
4359 /* die_unwind() did LEAVE, or we won't be here */
4362 LEAVE_with_name("eval");
4363 if (!(save_flags & OPf_SPECIAL)) {
4371 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4372 close to the related Perl_create_eval_scope. */
4374 Perl_delete_eval_scope(pTHX)
4385 LEAVE_with_name("eval_scope");
4386 PERL_UNUSED_VAR(newsp);
4387 PERL_UNUSED_VAR(gimme);
4388 PERL_UNUSED_VAR(optype);
4391 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4392 also needed by Perl_fold_constants. */
4394 Perl_create_eval_scope(pTHX_ U32 flags)
4397 const I32 gimme = GIMME_V;
4399 ENTER_with_name("eval_scope");
4402 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4405 PL_in_eval = EVAL_INEVAL;
4406 if (flags & G_KEEPERR)
4407 PL_in_eval |= EVAL_KEEPERR;
4410 if (flags & G_FAKINGEVAL) {
4411 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4418 PERL_CONTEXT * const cx = create_eval_scope(0);
4419 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4420 return DOCATCH(PL_op->op_next);
4435 PERL_UNUSED_VAR(optype);
4437 SP = leave_common(newsp, SP, newsp, gimme,
4438 SVs_PADTMP|SVs_TEMP, FALSE);
4439 PL_curpm = newpm; /* Don't pop $1 et al till now */
4441 LEAVE_with_name("eval_scope");
4450 const I32 gimme = GIMME_V;
4452 ENTER_with_name("given");
4455 if (PL_op->op_targ) {
4456 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4457 SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4458 PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4465 PUSHBLOCK(cx, CXt_GIVEN, SP);
4478 PERL_UNUSED_CONTEXT;
4481 assert(CxTYPE(cx) == CXt_GIVEN);
4483 SP = leave_common(newsp, SP, newsp, gimme,
4484 SVs_PADTMP|SVs_TEMP, FALSE);
4485 PL_curpm = newpm; /* Don't pop $1 et al till now */
4487 LEAVE_with_name("given");
4491 /* Helper routines used by pp_smartmatch */
4493 S_make_matcher(pTHX_ REGEXP *re)
4495 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4497 PERL_ARGS_ASSERT_MAKE_MATCHER;
4499 PM_SETRE(matcher, ReREFCNT_inc(re));
4501 SAVEFREEOP((OP *) matcher);
4502 ENTER_with_name("matcher"); SAVETMPS;
4508 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4513 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4515 PL_op = (OP *) matcher;
4518 (void) Perl_pp_match(aTHX);
4520 result = SvTRUEx(POPs);
4527 S_destroy_matcher(pTHX_ PMOP *matcher)
4529 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4530 PERL_UNUSED_ARG(matcher);
4533 LEAVE_with_name("matcher");
4536 /* Do a smart match */
4539 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4540 return do_smartmatch(NULL, NULL, 0);
4543 /* This version of do_smartmatch() implements the
4544 * table of smart matches that is found in perlsyn.
4547 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4551 bool object_on_left = FALSE;
4552 SV *e = TOPs; /* e is for 'expression' */
4553 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4555 /* Take care only to invoke mg_get() once for each argument.
4556 * Currently we do this by copying the SV if it's magical. */
4558 if (!copied && SvGMAGICAL(d))
4559 d = sv_mortalcopy(d);
4566 e = sv_mortalcopy(e);
4568 /* First of all, handle overload magic of the rightmost argument */
4571 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4572 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4574 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4581 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4584 SP -= 2; /* Pop the values */
4589 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4596 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4597 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4598 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4600 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4601 object_on_left = TRUE;
4604 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4606 if (object_on_left) {
4607 goto sm_any_sub; /* Treat objects like scalars */
4609 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4610 /* Test sub truth for each key */
4612 bool andedresults = TRUE;
4613 HV *hv = (HV*) SvRV(d);
4614 I32 numkeys = hv_iterinit(hv);
4615 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4618 while ( (he = hv_iternext(hv)) ) {
4619 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4620 ENTER_with_name("smartmatch_hash_key_test");
4623 PUSHs(hv_iterkeysv(he));
4625 c = call_sv(e, G_SCALAR);
4628 andedresults = FALSE;
4630 andedresults = SvTRUEx(POPs) && andedresults;
4632 LEAVE_with_name("smartmatch_hash_key_test");
4639 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4640 /* Test sub truth for each element */
4642 bool andedresults = TRUE;
4643 AV *av = (AV*) SvRV(d);
4644 const I32 len = av_tindex(av);
4645 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4648 for (i = 0; i <= len; ++i) {
4649 SV * const * const svp = av_fetch(av, i, FALSE);
4650 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4651 ENTER_with_name("smartmatch_array_elem_test");
4657 c = call_sv(e, G_SCALAR);
4660 andedresults = FALSE;
4662 andedresults = SvTRUEx(POPs) && andedresults;
4664 LEAVE_with_name("smartmatch_array_elem_test");
4673 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4674 ENTER_with_name("smartmatch_coderef");
4679 c = call_sv(e, G_SCALAR);
4683 else if (SvTEMP(TOPs))
4684 SvREFCNT_inc_void(TOPs);
4686 LEAVE_with_name("smartmatch_coderef");
4691 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4692 if (object_on_left) {
4693 goto sm_any_hash; /* Treat objects like scalars */
4695 else if (!SvOK(d)) {
4696 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4699 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4700 /* Check that the key-sets are identical */
4702 HV *other_hv = MUTABLE_HV(SvRV(d));
4705 U32 this_key_count = 0,
4706 other_key_count = 0;
4707 HV *hv = MUTABLE_HV(SvRV(e));
4709 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4710 /* Tied hashes don't know how many keys they have. */
4711 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4712 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4716 HV * const temp = other_hv;
4722 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4726 /* The hashes have the same number of keys, so it suffices
4727 to check that one is a subset of the other. */
4728 (void) hv_iterinit(hv);
4729 while ( (he = hv_iternext(hv)) ) {
4730 SV *key = hv_iterkeysv(he);
4732 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4735 if(!hv_exists_ent(other_hv, key, 0)) {
4736 (void) hv_iterinit(hv); /* reset iterator */
4742 (void) hv_iterinit(other_hv);
4743 while ( hv_iternext(other_hv) )
4747 other_key_count = HvUSEDKEYS(other_hv);
4749 if (this_key_count != other_key_count)
4754 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4755 AV * const other_av = MUTABLE_AV(SvRV(d));
4756 const SSize_t other_len = av_tindex(other_av) + 1;
4758 HV *hv = MUTABLE_HV(SvRV(e));
4760 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4761 for (i = 0; i < other_len; ++i) {
4762 SV ** const svp = av_fetch(other_av, i, FALSE);
4763 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4764 if (svp) { /* ??? When can this not happen? */
4765 if (hv_exists_ent(hv, *svp, 0))
4771 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4772 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4775 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4777 HV *hv = MUTABLE_HV(SvRV(e));
4779 (void) hv_iterinit(hv);
4780 while ( (he = hv_iternext(hv)) ) {
4781 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4783 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4785 (void) hv_iterinit(hv);
4786 destroy_matcher(matcher);
4791 destroy_matcher(matcher);
4797 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4798 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4805 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4806 if (object_on_left) {
4807 goto sm_any_array; /* Treat objects like scalars */
4809 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4810 AV * const other_av = MUTABLE_AV(SvRV(e));
4811 const SSize_t other_len = av_tindex(other_av) + 1;
4814 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4815 for (i = 0; i < other_len; ++i) {
4816 SV ** const svp = av_fetch(other_av, i, FALSE);
4818 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4819 if (svp) { /* ??? When can this not happen? */
4820 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4826 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4827 AV *other_av = MUTABLE_AV(SvRV(d));
4828 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4829 if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4833 const SSize_t other_len = av_tindex(other_av);
4835 if (NULL == seen_this) {
4836 seen_this = newHV();
4837 (void) sv_2mortal(MUTABLE_SV(seen_this));
4839 if (NULL == seen_other) {
4840 seen_other = newHV();
4841 (void) sv_2mortal(MUTABLE_SV(seen_other));
4843 for(i = 0; i <= other_len; ++i) {
4844 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4845 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4847 if (!this_elem || !other_elem) {
4848 if ((this_elem && SvOK(*this_elem))
4849 || (other_elem && SvOK(*other_elem)))
4852 else if (hv_exists_ent(seen_this,
4853 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4854 hv_exists_ent(seen_other,
4855 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4857 if (*this_elem != *other_elem)
4861 (void)hv_store_ent(seen_this,
4862 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4864 (void)hv_store_ent(seen_other,
4865 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4871 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4872 (void) do_smartmatch(seen_this, seen_other, 0);
4874 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4883 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4884 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4887 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4888 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4891 for(i = 0; i <= this_len; ++i) {
4892 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4893 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4895 if (svp && matcher_matches_sv(matcher, *svp)) {
4897 destroy_matcher(matcher);
4902 destroy_matcher(matcher);
4906 else if (!SvOK(d)) {
4907 /* undef ~~ array */
4908 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4911 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4912 for (i = 0; i <= this_len; ++i) {
4913 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4914 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4915 if (!svp || !SvOK(*svp))
4924 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4926 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4927 for (i = 0; i <= this_len; ++i) {
4928 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4935 /* infinite recursion isn't supposed to happen here */
4936 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4937 (void) do_smartmatch(NULL, NULL, 1);
4939 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4948 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4949 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4950 SV *t = d; d = e; e = t;
4951 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4954 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4955 SV *t = d; d = e; e = t;
4956 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4957 goto sm_regex_array;
4960 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4963 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4965 result = matcher_matches_sv(matcher, d);
4967 PUSHs(result ? &PL_sv_yes : &PL_sv_no);
4968 destroy_matcher(matcher);
4973 /* See if there is overload magic on left */
4974 else if (object_on_left && SvAMAGIC(d)) {
4976 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4977 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4980 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4988 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4991 else if (!SvOK(d)) {
4992 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4993 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4998 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4999 DEBUG_M(if (SvNIOK(e))
5000 Perl_deb(aTHX_ " applying rule Any-Num\n");
5002 Perl_deb(aTHX_ " applying rule Num-numish\n");
5004 /* numeric comparison */
5007 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
5008 (void) Perl_pp_i_eq(aTHX);
5010 (void) Perl_pp_eq(aTHX);
5018 /* As a last resort, use string comparison */
5019 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
5022 return Perl_pp_seq(aTHX);
5029 const I32 gimme = GIMME_V;
5031 /* This is essentially an optimization: if the match
5032 fails, we don't want to push a context and then
5033 pop it again right away, so we skip straight
5034 to the op that follows the leavewhen.
5035 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5037 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
5038 RETURNOP(cLOGOP->op_other->op_next);
5040 ENTER_with_name("when");
5043 PUSHBLOCK(cx, CXt_WHEN, SP);
5058 cxix = dopoptogiven(cxstack_ix);
5060 /* diag_listed_as: Can't "when" outside a topicalizer */
5061 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5062 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5065 assert(CxTYPE(cx) == CXt_WHEN);
5067 SP = leave_common(newsp, SP, newsp, gimme,
5068 SVs_PADTMP|SVs_TEMP, FALSE);
5069 PL_curpm = newpm; /* pop $1 et al */
5071 LEAVE_with_name("when");
5073 if (cxix < cxstack_ix)
5076 cx = &cxstack[cxix];
5078 if (CxFOREACH(cx)) {
5079 /* clear off anything above the scope we're re-entering */
5080 I32 inner = PL_scopestack_ix;
5083 if (PL_scopestack_ix < inner)
5084 leave_scope(PL_scopestack[PL_scopestack_ix]);
5085 PL_curcop = cx->blk_oldcop;
5088 return cx->blk_loop.my_op->op_nextop;
5092 RETURNOP(cx->blk_givwhen.leave_op);
5105 PERL_UNUSED_VAR(gimme);
5107 cxix = dopoptowhen(cxstack_ix);
5109 DIE(aTHX_ "Can't \"continue\" outside a when block");
5111 if (cxix < cxstack_ix)
5115 assert(CxTYPE(cx) == CXt_WHEN);
5118 PL_curpm = newpm; /* pop $1 et al */
5120 LEAVE_with_name("when");
5121 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5129 cxix = dopoptogiven(cxstack_ix);
5131 DIE(aTHX_ "Can't \"break\" outside a given block");
5133 cx = &cxstack[cxix];
5135 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5137 if (cxix < cxstack_ix)
5140 /* Restore the sp at the time we entered the given block */
5143 return cx->blk_givwhen.leave_op;
5147 S_doparseform(pTHX_ SV *sv)
5150 char *s = SvPV(sv, len);
5152 char *base = NULL; /* start of current field */
5153 I32 skipspaces = 0; /* number of contiguous spaces seen */
5154 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5155 bool repeat = FALSE; /* ~~ seen on this line */
5156 bool postspace = FALSE; /* a text field may need right padding */
5159 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5161 bool ischop; /* it's a ^ rather than a @ */
5162 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5163 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5167 PERL_ARGS_ASSERT_DOPARSEFORM;
5170 Perl_croak(aTHX_ "Null picture in formline");
5172 if (SvTYPE(sv) >= SVt_PVMG) {
5173 /* This might, of course, still return NULL. */
5174 mg = mg_find(sv, PERL_MAGIC_fm);
5176 sv_upgrade(sv, SVt_PVMG);
5180 /* still the same as previously-compiled string? */
5181 SV *old = mg->mg_obj;
5182 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5183 && len == SvCUR(old)
5184 && strnEQ(SvPVX(old), SvPVX(sv), len)
5186 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5190 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5191 Safefree(mg->mg_ptr);
5197 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5198 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5201 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5202 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5206 /* estimate the buffer size needed */
5207 for (base = s; s <= send; s++) {
5208 if (*s == '\n' || *s == '@' || *s == '^')
5214 Newx(fops, maxops, U32);
5219 *fpc++ = FF_LINEMARK;
5220 noblank = repeat = FALSE;
5238 case ' ': case '\t':
5245 } /* else FALL THROUGH */
5253 *fpc++ = FF_LITERAL;
5261 *fpc++ = (U32)skipspaces;
5265 *fpc++ = FF_NEWLINE;
5269 arg = fpc - linepc + 1;
5276 *fpc++ = FF_LINEMARK;
5277 noblank = repeat = FALSE;
5286 ischop = s[-1] == '^';
5292 arg = (s - base) - 1;
5294 *fpc++ = FF_LITERAL;
5300 if (*s == '*') { /* @* or ^* */
5302 *fpc++ = 2; /* skip the @* or ^* */
5304 *fpc++ = FF_LINESNGL;
5307 *fpc++ = FF_LINEGLOB;
5309 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5310 arg = ischop ? FORM_NUM_BLANK : 0;
5315 const char * const f = ++s;
5318 arg |= FORM_NUM_POINT + (s - f);
5320 *fpc++ = s - base; /* fieldsize for FETCH */
5321 *fpc++ = FF_DECIMAL;
5323 unchopnum |= ! ischop;
5325 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5326 arg = ischop ? FORM_NUM_BLANK : 0;
5328 s++; /* skip the '0' first */
5332 const char * const f = ++s;
5335 arg |= FORM_NUM_POINT + (s - f);
5337 *fpc++ = s - base; /* fieldsize for FETCH */
5338 *fpc++ = FF_0DECIMAL;
5340 unchopnum |= ! ischop;
5342 else { /* text field */
5344 bool ismore = FALSE;
5347 while (*++s == '>') ;
5348 prespace = FF_SPACE;
5350 else if (*s == '|') {
5351 while (*++s == '|') ;
5352 prespace = FF_HALFSPACE;
5357 while (*++s == '<') ;
5360 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5364 *fpc++ = s - base; /* fieldsize for FETCH */
5366 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5369 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5383 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5386 mg->mg_ptr = (char *) fops;
5387 mg->mg_len = arg * sizeof(U32);
5388 mg->mg_obj = sv_copy;
5389 mg->mg_flags |= MGf_REFCOUNTED;
5391 if (unchopnum && repeat)
5392 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5399 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5401 /* Can value be printed in fldsize chars, using %*.*f ? */
5405 int intsize = fldsize - (value < 0 ? 1 : 0);
5407 if (frcsize & FORM_NUM_POINT)
5409 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5412 while (intsize--) pwr *= 10.0;
5413 while (frcsize--) eps /= 10.0;
5416 if (value + eps >= pwr)
5419 if (value - eps <= -pwr)
5426 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5428 SV * const datasv = FILTER_DATA(idx);
5429 const int filter_has_file = IoLINES(datasv);
5430 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5431 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5436 char *prune_from = NULL;
5437 bool read_from_cache = FALSE;
5441 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5443 assert(maxlen >= 0);
5446 /* I was having segfault trouble under Linux 2.2.5 after a
5447 parse error occurred. (Had to hack around it with a test
5448 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5449 not sure where the trouble is yet. XXX */
5452 SV *const cache = datasv;
5455 const char *cache_p = SvPV(cache, cache_len);
5459 /* Running in block mode and we have some cached data already.
5461 if (cache_len >= umaxlen) {
5462 /* In fact, so much data we don't even need to call
5467 const char *const first_nl =
5468 (const char *)memchr(cache_p, '\n', cache_len);
5470 take = first_nl + 1 - cache_p;
5474 sv_catpvn(buf_sv, cache_p, take);
5475 sv_chop(cache, cache_p + take);
5476 /* Definitely not EOF */
5480 sv_catsv(buf_sv, cache);
5482 umaxlen -= cache_len;
5485 read_from_cache = TRUE;
5489 /* Filter API says that the filter appends to the contents of the buffer.
5490 Usually the buffer is "", so the details don't matter. But if it's not,
5491 then clearly what it contains is already filtered by this filter, so we
5492 don't want to pass it in a second time.
5493 I'm going to use a mortal in case the upstream filter croaks. */
5494 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5495 ? sv_newmortal() : buf_sv;
5496 SvUPGRADE(upstream, SVt_PV);
5498 if (filter_has_file) {
5499 status = FILTER_READ(idx+1, upstream, 0);
5502 if (filter_sub && status >= 0) {
5506 ENTER_with_name("call_filter_sub");
5511 DEFSV_set(upstream);
5515 PUSHs(filter_state);
5518 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5528 SV * const errsv = ERRSV;
5529 if (SvTRUE_NN(errsv))
5530 err = newSVsv(errsv);
5536 LEAVE_with_name("call_filter_sub");
5539 if (SvGMAGICAL(upstream)) {
5541 if (upstream == buf_sv) mg_free(buf_sv);
5543 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5544 if(!err && SvOK(upstream)) {
5545 got_p = SvPV_nomg(upstream, got_len);
5547 if (got_len > umaxlen) {
5548 prune_from = got_p + umaxlen;
5551 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5552 if (first_nl && first_nl + 1 < got_p + got_len) {
5553 /* There's a second line here... */
5554 prune_from = first_nl + 1;
5558 if (!err && prune_from) {
5559 /* Oh. Too long. Stuff some in our cache. */
5560 STRLEN cached_len = got_p + got_len - prune_from;
5561 SV *const cache = datasv;
5564 /* Cache should be empty. */
5565 assert(!SvCUR(cache));
5568 sv_setpvn(cache, prune_from, cached_len);
5569 /* If you ask for block mode, you may well split UTF-8 characters.
5570 "If it breaks, you get to keep both parts"
5571 (Your code is broken if you don't put them back together again
5572 before something notices.) */
5573 if (SvUTF8(upstream)) {
5576 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5578 /* Cannot just use sv_setpvn, as that could free the buffer
5579 before we have a chance to assign it. */
5580 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5581 got_len - cached_len);
5583 /* Can't yet be EOF */
5588 /* If they are at EOF but buf_sv has something in it, then they may never
5589 have touched the SV upstream, so it may be undefined. If we naively
5590 concatenate it then we get a warning about use of uninitialised value.
5592 if (!err && upstream != buf_sv &&
5594 sv_catsv_nomg(buf_sv, upstream);
5596 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5599 IoLINES(datasv) = 0;
5601 SvREFCNT_dec(filter_state);
5602 IoTOP_GV(datasv) = NULL;
5605 SvREFCNT_dec(filter_sub);
5606 IoBOTTOM_GV(datasv) = NULL;
5608 filter_del(S_run_user_filter);
5614 if (status == 0 && read_from_cache) {
5615 /* If we read some data from the cache (and by getting here it implies
5616 that we emptied the cache) then we aren't yet at EOF, and mustn't
5617 report that to our caller. */
5624 * ex: set ts=8 sts=4 sw=4 et: