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 DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
828 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
831 const char* qfmt = quadmath_format_single(fmt);
834 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
835 len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
837 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
842 /* we generate fmt ourselves so it is safe */
843 GCC_DIAG_IGNORE(-Wformat-nonliteral);
844 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
847 PERL_MY_SNPRINTF_POST_GUARD(len, max);
848 RESTORE_LC_NUMERIC();
853 case FF_NEWLINE: /* delete trailing spaces, then append \n */
855 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
860 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
863 if (arg) { /* repeat until fields exhausted? */
869 t = SvPVX(PL_formtarget) + linemark;
874 case FF_MORE: /* replace long end of string with '...' */
876 const char *s = chophere;
877 const char *send = item + len;
879 while (isSPACE(*s) && (s < send))
884 arg = fieldsize - itemsize;
891 if (strnEQ(s1," ",3)) {
892 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
902 case FF_END: /* tidy up, then return */
904 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
906 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
908 SvUTF8_on(PL_formtarget);
909 FmLINES(PL_formtarget) += lines;
911 if (fpc[-1] == FF_BLANK)
912 RETURNOP(cLISTOP->op_first);
924 if (PL_stack_base + *PL_markstack_ptr == SP) {
926 if (GIMME_V == G_SCALAR)
928 RETURNOP(PL_op->op_next->op_next);
930 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
931 Perl_pp_pushmark(aTHX); /* push dst */
932 Perl_pp_pushmark(aTHX); /* push src */
933 ENTER_with_name("grep"); /* enter outer scope */
936 if (PL_op->op_private & OPpGREP_LEX)
937 SAVESPTR(PAD_SVl(PL_op->op_targ));
940 ENTER_with_name("grep_item"); /* enter inner scope */
943 src = PL_stack_base[*PL_markstack_ptr];
945 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
949 if (PL_op->op_private & OPpGREP_LEX)
950 PAD_SVl(PL_op->op_targ) = src;
955 if (PL_op->op_type == OP_MAPSTART)
956 Perl_pp_pushmark(aTHX); /* push top */
957 return ((LOGOP*)PL_op->op_next)->op_other;
963 const I32 gimme = GIMME_V;
964 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
970 /* first, move source pointer to the next item in the source list */
971 ++PL_markstack_ptr[-1];
973 /* if there are new items, push them into the destination list */
974 if (items && gimme != G_VOID) {
975 /* might need to make room back there first */
976 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
977 /* XXX this implementation is very pessimal because the stack
978 * is repeatedly extended for every set of items. Is possible
979 * to do this without any stack extension or copying at all
980 * by maintaining a separate list over which the map iterates
981 * (like foreach does). --gsar */
983 /* everything in the stack after the destination list moves
984 * towards the end the stack by the amount of room needed */
985 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
987 /* items to shift up (accounting for the moved source pointer) */
988 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
990 /* This optimization is by Ben Tilly and it does
991 * things differently from what Sarathy (gsar)
992 * is describing. The downside of this optimization is
993 * that leaves "holes" (uninitialized and hopefully unused areas)
994 * to the Perl stack, but on the other hand this
995 * shouldn't be a problem. If Sarathy's idea gets
996 * implemented, this optimization should become
997 * irrelevant. --jhi */
999 shift = count; /* Avoid shifting too often --Ben Tilly */
1003 dst = (SP += shift);
1004 PL_markstack_ptr[-1] += shift;
1005 *PL_markstack_ptr += shift;
1009 /* copy the new items down to the destination list */
1010 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1011 if (gimme == G_ARRAY) {
1012 /* add returned items to the collection (making mortal copies
1013 * if necessary), then clear the current temps stack frame
1014 * *except* for those items. We do this splicing the items
1015 * into the start of the tmps frame (so some items may be on
1016 * the tmps stack twice), then moving PL_tmps_floor above
1017 * them, then freeing the frame. That way, the only tmps that
1018 * accumulate over iterations are the return values for map.
1019 * We have to do to this way so that everything gets correctly
1020 * freed if we die during the map.
1024 /* make space for the slice */
1025 EXTEND_MORTAL(items);
1026 tmpsbase = PL_tmps_floor + 1;
1027 Move(PL_tmps_stack + tmpsbase,
1028 PL_tmps_stack + tmpsbase + items,
1029 PL_tmps_ix - PL_tmps_floor,
1031 PL_tmps_ix += items;
1036 sv = sv_mortalcopy(sv);
1038 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1040 /* clear the stack frame except for the items */
1041 PL_tmps_floor += items;
1043 /* FREETMPS may have cleared the TEMP flag on some of the items */
1046 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1049 /* scalar context: we don't care about which values map returns
1050 * (we use undef here). And so we certainly don't want to do mortal
1051 * copies of meaningless values. */
1052 while (items-- > 0) {
1054 *dst-- = &PL_sv_undef;
1062 LEAVE_with_name("grep_item"); /* exit inner scope */
1065 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1067 (void)POPMARK; /* pop top */
1068 LEAVE_with_name("grep"); /* exit outer scope */
1069 (void)POPMARK; /* pop src */
1070 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1071 (void)POPMARK; /* pop dst */
1072 SP = PL_stack_base + POPMARK; /* pop original mark */
1073 if (gimme == G_SCALAR) {
1074 if (PL_op->op_private & OPpGREP_LEX) {
1075 SV* sv = sv_newmortal();
1076 sv_setiv(sv, items);
1084 else if (gimme == G_ARRAY)
1091 ENTER_with_name("grep_item"); /* enter inner scope */
1094 /* set $_ to the new source item */
1095 src = PL_stack_base[PL_markstack_ptr[-1]];
1096 if (SvPADTMP(src)) {
1097 src = sv_mortalcopy(src);
1100 if (PL_op->op_private & OPpGREP_LEX)
1101 PAD_SVl(PL_op->op_targ) = src;
1105 RETURNOP(cLOGOP->op_other);
1113 if (GIMME_V == G_ARRAY)
1115 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1116 return cLOGOP->op_other;
1125 if (GIMME_V == G_ARRAY) {
1126 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1130 SV * const targ = PAD_SV(PL_op->op_targ);
1133 if (PL_op->op_private & OPpFLIP_LINENUM) {
1134 if (GvIO(PL_last_in_gv)) {
1135 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1138 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1140 flip = SvIV(sv) == SvIV(GvSV(gv));
1146 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1147 if (PL_op->op_flags & OPf_SPECIAL) {
1155 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1158 sv_setpvs(TARG, "");
1164 /* This code tries to decide if "$left .. $right" should use the
1165 magical string increment, or if the range is numeric (we make
1166 an exception for .."0" [#18165]). AMS 20021031. */
1168 #define RANGE_IS_NUMERIC(left,right) ( \
1169 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1170 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1171 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1172 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1173 && (!SvOK(right) || looks_like_number(right))))
1179 if (GIMME_V == G_ARRAY) {
1185 if (RANGE_IS_NUMERIC(left,right)) {
1187 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1188 (SvOK(right) && (SvIOK(right)
1189 ? SvIsUV(right) && SvUV(right) > IV_MAX
1190 : SvNV_nomg(right) > IV_MAX)))
1191 DIE(aTHX_ "Range iterator outside integer range");
1192 i = SvIV_nomg(left);
1193 j = SvIV_nomg(right);
1195 /* Dance carefully around signed max. */
1196 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1199 /* The wraparound of signed integers is undefined
1200 * behavior, but here we aim for count >=1, and
1201 * negative count is just wrong. */
1206 Perl_croak(aTHX_ "Out of memory during list extend");
1213 SV * const sv = sv_2mortal(newSViv(i));
1215 if (n) /* avoid incrementing above IV_MAX */
1221 const char * const lpv = SvPV_nomg_const(left, llen);
1222 const char * const tmps = SvPV_nomg_const(right, len);
1224 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1225 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1227 if (strEQ(SvPVX_const(sv),tmps))
1229 sv = sv_2mortal(newSVsv(sv));
1236 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1240 if (PL_op->op_private & OPpFLIP_LINENUM) {
1241 if (GvIO(PL_last_in_gv)) {
1242 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1245 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1246 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1254 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1255 sv_catpvs(targ, "E0");
1265 static const char * const context_name[] = {
1267 NULL, /* CXt_WHEN never actually needs "block" */
1268 NULL, /* CXt_BLOCK never actually needs "block" */
1269 NULL, /* CXt_GIVEN never actually needs "block" */
1270 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1271 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1272 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1273 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1281 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1285 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1287 for (i = cxstack_ix; i >= 0; i--) {
1288 const PERL_CONTEXT * const cx = &cxstack[i];
1289 switch (CxTYPE(cx)) {
1295 /* diag_listed_as: Exiting subroutine via %s */
1296 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1297 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1298 if (CxTYPE(cx) == CXt_NULL)
1301 case CXt_LOOP_LAZYIV:
1302 case CXt_LOOP_LAZYSV:
1304 case CXt_LOOP_PLAIN:
1306 STRLEN cx_label_len = 0;
1307 U32 cx_label_flags = 0;
1308 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1310 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1313 (const U8*)cx_label, cx_label_len,
1314 (const U8*)label, len) == 0)
1316 (const U8*)label, len,
1317 (const U8*)cx_label, cx_label_len) == 0)
1318 : (len == cx_label_len && ((cx_label == label)
1319 || memEQ(cx_label, label, len))) )) {
1320 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1321 (long)i, cx_label));
1324 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1335 Perl_dowantarray(pTHX)
1337 const I32 gimme = block_gimme();
1338 return (gimme == G_VOID) ? G_SCALAR : gimme;
1342 Perl_block_gimme(pTHX)
1344 const I32 cxix = dopoptosub(cxstack_ix);
1348 switch (cxstack[cxix].blk_gimme) {
1356 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1358 NOT_REACHED; /* NOTREACHED */
1362 Perl_is_lvalue_sub(pTHX)
1364 const I32 cxix = dopoptosub(cxstack_ix);
1365 assert(cxix >= 0); /* We should only be called from inside subs */
1367 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1368 return CxLVAL(cxstack + cxix);
1373 /* only used by PUSHSUB */
1375 Perl_was_lvalue_sub(pTHX)
1377 const I32 cxix = dopoptosub(cxstack_ix-1);
1378 assert(cxix >= 0); /* We should only be called from inside subs */
1380 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1381 return CxLVAL(cxstack + cxix);
1387 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1391 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1393 PERL_UNUSED_CONTEXT;
1396 for (i = startingblock; i >= 0; i--) {
1397 const PERL_CONTEXT * const cx = &cxstk[i];
1398 switch (CxTYPE(cx)) {
1402 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1403 * twice; the first for the normal foo() call, and the second
1404 * for a faked up re-entry into the sub to execute the
1405 * code block. Hide this faked entry from the world. */
1406 if (cx->cx_type & CXp_SUB_RE_FAKE)
1411 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1419 S_dopoptoeval(pTHX_ I32 startingblock)
1422 for (i = startingblock; i >= 0; i--) {
1423 const PERL_CONTEXT *cx = &cxstack[i];
1424 switch (CxTYPE(cx)) {
1428 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1436 S_dopoptoloop(pTHX_ I32 startingblock)
1439 for (i = startingblock; i >= 0; i--) {
1440 const PERL_CONTEXT * const cx = &cxstack[i];
1441 switch (CxTYPE(cx)) {
1447 /* diag_listed_as: Exiting subroutine via %s */
1448 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1449 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1450 if ((CxTYPE(cx)) == CXt_NULL)
1453 case CXt_LOOP_LAZYIV:
1454 case CXt_LOOP_LAZYSV:
1456 case CXt_LOOP_PLAIN:
1457 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1465 S_dopoptogiven(pTHX_ I32 startingblock)
1468 for (i = startingblock; i >= 0; i--) {
1469 const PERL_CONTEXT *cx = &cxstack[i];
1470 switch (CxTYPE(cx)) {
1474 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1476 case CXt_LOOP_PLAIN:
1477 assert(!CxFOREACHDEF(cx));
1479 case CXt_LOOP_LAZYIV:
1480 case CXt_LOOP_LAZYSV:
1482 if (CxFOREACHDEF(cx)) {
1483 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1492 S_dopoptowhen(pTHX_ I32 startingblock)
1495 for (i = startingblock; i >= 0; i--) {
1496 const PERL_CONTEXT *cx = &cxstack[i];
1497 switch (CxTYPE(cx)) {
1501 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1509 Perl_dounwind(pTHX_ I32 cxix)
1513 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1516 while (cxstack_ix > cxix) {
1518 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1519 DEBUG_CX("UNWIND"); \
1520 /* Note: we don't need to restore the base context info till the end. */
1521 switch (CxTYPE(cx)) {
1524 continue; /* not break */
1532 case CXt_LOOP_LAZYIV:
1533 case CXt_LOOP_LAZYSV:
1535 case CXt_LOOP_PLAIN:
1546 PERL_UNUSED_VAR(optype);
1550 Perl_qerror(pTHX_ SV *err)
1552 PERL_ARGS_ASSERT_QERROR;
1555 if (PL_in_eval & EVAL_KEEPERR) {
1556 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1560 sv_catsv(ERRSV, err);
1563 sv_catsv(PL_errors, err);
1565 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1567 ++PL_parser->error_count;
1571 Perl_die_unwind(pTHX_ SV *msv)
1573 SV *exceptsv = sv_mortalcopy(msv);
1574 U8 in_eval = PL_in_eval;
1575 PERL_ARGS_ASSERT_DIE_UNWIND;
1582 * Historically, perl used to set ERRSV ($@) early in the die
1583 * process and rely on it not getting clobbered during unwinding.
1584 * That sucked, because it was liable to get clobbered, so the
1585 * setting of ERRSV used to emit the exception from eval{} has
1586 * been moved to much later, after unwinding (see just before
1587 * JMPENV_JUMP below). However, some modules were relying on the
1588 * early setting, by examining $@ during unwinding to use it as
1589 * a flag indicating whether the current unwinding was caused by
1590 * an exception. It was never a reliable flag for that purpose,
1591 * being totally open to false positives even without actual
1592 * clobberage, but was useful enough for production code to
1593 * semantically rely on it.
1595 * We'd like to have a proper introspective interface that
1596 * explicitly describes the reason for whatever unwinding
1597 * operations are currently in progress, so that those modules
1598 * work reliably and $@ isn't further overloaded. But we don't
1599 * have one yet. In its absence, as a stopgap measure, ERRSV is
1600 * now *additionally* set here, before unwinding, to serve as the
1601 * (unreliable) flag that it used to.
1603 * This behaviour is temporary, and should be removed when a
1604 * proper way to detect exceptional unwinding has been developed.
1605 * As of 2010-12, the authors of modules relying on the hack
1606 * are aware of the issue, because the modules failed on
1607 * perls 5.13.{1..7} which had late setting of $@ without this
1608 * early-setting hack.
1610 if (!(in_eval & EVAL_KEEPERR)) {
1611 SvTEMP_off(exceptsv);
1612 sv_setsv(ERRSV, exceptsv);
1615 if (in_eval & EVAL_KEEPERR) {
1616 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1620 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1621 && PL_curstackinfo->si_prev)
1635 JMPENV *restartjmpenv;
1638 if (cxix < cxstack_ix)
1641 POPBLOCK(cx,PL_curpm);
1642 if (CxTYPE(cx) != CXt_EVAL) {
1644 const char* message = SvPVx_const(exceptsv, msglen);
1645 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1646 PerlIO_write(Perl_error_log, message, msglen);
1650 namesv = cx->blk_eval.old_namesv;
1652 oldcop = cx->blk_oldcop;
1654 restartjmpenv = cx->blk_eval.cur_top_env;
1655 restartop = cx->blk_eval.retop;
1657 if (gimme == G_SCALAR)
1658 *++newsp = &PL_sv_undef;
1659 PL_stack_sp = newsp;
1663 if (optype == OP_REQUIRE) {
1664 assert (PL_curcop == oldcop);
1665 (void)hv_store(GvHVn(PL_incgv),
1666 SvPVX_const(namesv),
1667 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1669 /* note that unlike pp_entereval, pp_require isn't
1670 * supposed to trap errors. So now that we've popped the
1671 * EVAL that pp_require pushed, and processed the error
1672 * message, rethrow the error */
1673 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1674 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1677 if (!(in_eval & EVAL_KEEPERR))
1678 sv_setsv(ERRSV, exceptsv);
1679 PL_restartjmpenv = restartjmpenv;
1680 PL_restartop = restartop;
1682 NOT_REACHED; /* NOTREACHED */
1686 write_to_stderr(exceptsv);
1688 NOT_REACHED; /* NOTREACHED */
1694 if (SvTRUE(left) != SvTRUE(right))
1702 =head1 CV Manipulation Functions
1704 =for apidoc caller_cx
1706 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1707 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1708 information returned to Perl by C<caller>. Note that XSUBs don't get a
1709 stack frame, so C<caller_cx(0, NULL)> will return information for the
1710 immediately-surrounding Perl code.
1712 This function skips over the automatic calls to C<&DB::sub> made on the
1713 behalf of the debugger. If the stack frame requested was a sub called by
1714 C<DB::sub>, the return value will be the frame for the call to
1715 C<DB::sub>, since that has the correct line number/etc. for the call
1716 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1717 frame for the sub call itself.
1722 const PERL_CONTEXT *
1723 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1725 I32 cxix = dopoptosub(cxstack_ix);
1726 const PERL_CONTEXT *cx;
1727 const PERL_CONTEXT *ccstack = cxstack;
1728 const PERL_SI *top_si = PL_curstackinfo;
1731 /* we may be in a higher stacklevel, so dig down deeper */
1732 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1733 top_si = top_si->si_prev;
1734 ccstack = top_si->si_cxstack;
1735 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1739 /* caller() should not report the automatic calls to &DB::sub */
1740 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1741 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1745 cxix = dopoptosub_at(ccstack, cxix - 1);
1748 cx = &ccstack[cxix];
1749 if (dbcxp) *dbcxp = cx;
1751 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1752 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1753 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1754 field below is defined for any cx. */
1755 /* caller() should not report the automatic calls to &DB::sub */
1756 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1757 cx = &ccstack[dbcxix];
1766 const PERL_CONTEXT *cx;
1767 const PERL_CONTEXT *dbcx;
1768 I32 gimme = GIMME_V;
1769 const HEK *stash_hek;
1771 bool has_arg = MAXARG && TOPs;
1780 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1782 if (gimme != G_ARRAY) {
1790 assert(CopSTASH(cx->blk_oldcop));
1791 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1792 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1794 if (gimme != G_ARRAY) {
1797 PUSHs(&PL_sv_undef);
1800 sv_sethek(TARG, stash_hek);
1809 PUSHs(&PL_sv_undef);
1812 sv_sethek(TARG, stash_hek);
1815 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1816 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1817 cx->blk_sub.retop, TRUE);
1819 lcop = cx->blk_oldcop;
1820 mPUSHi((I32)CopLINE(lcop));
1823 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1824 /* So is ccstack[dbcxix]. */
1825 if (CvHASGV(dbcx->blk_sub.cv)) {
1826 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1827 PUSHs(boolSV(CxHASARGS(cx)));
1830 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1831 PUSHs(boolSV(CxHASARGS(cx)));
1835 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1838 gimme = (I32)cx->blk_gimme;
1839 if (gimme == G_VOID)
1840 PUSHs(&PL_sv_undef);
1842 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1843 if (CxTYPE(cx) == CXt_EVAL) {
1845 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1846 SV *cur_text = cx->blk_eval.cur_text;
1847 if (SvCUR(cur_text) >= 2) {
1848 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1849 SvUTF8(cur_text)|SVs_TEMP));
1852 /* I think this is will always be "", but be sure */
1853 PUSHs(sv_2mortal(newSVsv(cur_text)));
1859 else if (cx->blk_eval.old_namesv) {
1860 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1863 /* eval BLOCK (try blocks have old_namesv == 0) */
1865 PUSHs(&PL_sv_undef);
1866 PUSHs(&PL_sv_undef);
1870 PUSHs(&PL_sv_undef);
1871 PUSHs(&PL_sv_undef);
1873 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1874 && CopSTASH_eq(PL_curcop, PL_debstash))
1876 AV * const ary = cx->blk_sub.argarray;
1877 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1879 Perl_init_dbargs(aTHX);
1881 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1882 av_extend(PL_dbargs, AvFILLp(ary) + off);
1883 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1884 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1886 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1889 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1891 if (old_warnings == pWARN_NONE)
1892 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1893 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1894 mask = &PL_sv_undef ;
1895 else if (old_warnings == pWARN_ALL ||
1896 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1897 /* Get the bit mask for $warnings::Bits{all}, because
1898 * it could have been extended by warnings::register */
1900 HV * const bits = get_hv("warnings::Bits", 0);
1901 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1902 mask = newSVsv(*bits_all);
1905 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1909 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1913 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1914 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1924 if (MAXARG < 1 || (!TOPs && !POPs))
1925 tmps = NULL, len = 0;
1927 tmps = SvPVx_const(POPs, len);
1928 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1933 /* like pp_nextstate, but used instead when the debugger is active */
1937 PL_curcop = (COP*)PL_op;
1938 TAINT_NOT; /* Each statement is presumed innocent */
1939 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1944 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1945 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
1949 const I32 gimme = G_ARRAY;
1951 GV * const gv = PL_DBgv;
1954 if (gv && isGV_with_GP(gv))
1957 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1958 DIE(aTHX_ "No DB::DB routine defined");
1960 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1961 /* don't do recursive DB::DB call */
1975 (void)(*CvXSUB(cv))(aTHX_ cv);
1981 PUSHBLOCK(cx, CXt_SUB, SP);
1983 cx->blk_sub.retop = PL_op->op_next;
1985 if (CvDEPTH(cv) >= 2) {
1986 PERL_STACK_OVERFLOW_CHECK();
1987 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1990 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1991 RETURNOP(CvSTART(cv));
1998 /* S_leave_common: Common code that many functions in this file use on
2001 /* SVs on the stack that have any of the flags passed in are left as is.
2002 Other SVs are protected via the mortals stack if lvalue is true, and
2005 Also, taintedness is cleared.
2009 S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
2010 U32 flags, bool lvalue)
2013 PERL_ARGS_ASSERT_LEAVE_COMMON;
2016 if (flags & SVs_PADTMP) {
2017 flags &= ~SVs_PADTMP;
2020 if (gimme == G_SCALAR) {
2022 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2025 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2026 : sv_mortalcopy(*SP);
2028 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2031 *++MARK = &PL_sv_undef;
2035 else if (gimme == G_ARRAY) {
2036 /* in case LEAVE wipes old return values */
2037 while (++MARK <= SP) {
2038 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2042 ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
2043 : sv_mortalcopy(*MARK);
2044 TAINT_NOT; /* Each item is independent */
2047 /* When this function was called with MARK == newsp, we reach this
2048 * point with SP == newsp. */
2058 I32 gimme = GIMME_V;
2060 ENTER_with_name("block");
2063 PUSHBLOCK(cx, CXt_BLOCK, SP);
2076 if (PL_op->op_flags & OPf_SPECIAL) {
2077 cx = &cxstack[cxstack_ix];
2078 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2083 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2085 SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
2086 PL_op->op_private & OPpLVALUE);
2087 PL_curpm = newpm; /* Don't pop $1 et al till now */
2089 LEAVE_with_name("block");
2095 S_outside_integer(pTHX_ SV *sv)
2098 const NV nv = SvNV_nomg(sv);
2099 if (Perl_isinfnan(nv))
2101 #ifdef NV_PRESERVES_UV
2102 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2105 if (nv <= (NV)IV_MIN)
2108 ((nv > (NV)UV_MAX ||
2109 SvUV_nomg(sv) > (UV)IV_MAX)))
2120 const I32 gimme = GIMME_V;
2121 void *itervar; /* location of the iteration variable */
2122 U8 cxtype = CXt_LOOP_FOR;
2124 ENTER_with_name("loop1");
2127 if (PL_op->op_targ) { /* "my" variable */
2128 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2129 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2130 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2131 SVs_PADSTALE, SVs_PADSTALE);
2133 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2135 itervar = PL_comppad;
2137 itervar = &PAD_SVl(PL_op->op_targ);
2140 else if (LIKELY(isGV(TOPs))) { /* symbol table variable */
2141 GV * const gv = MUTABLE_GV(POPs);
2142 SV** svp = &GvSV(gv);
2143 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2145 itervar = (void *)gv;
2146 save_aliased_sv(gv);
2149 SV * const sv = POPs;
2150 assert(SvTYPE(sv) == SVt_PVMG);
2151 assert(SvMAGIC(sv));
2152 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2153 itervar = (void *)sv;
2154 cxtype |= CXp_FOR_LVREF;
2157 if (PL_op->op_private & OPpITER_DEF)
2158 cxtype |= CXp_FOR_DEF;
2160 ENTER_with_name("loop2");
2162 PUSHBLOCK(cx, cxtype, SP);
2163 PUSHLOOP_FOR(cx, itervar, MARK);
2164 if (PL_op->op_flags & OPf_STACKED) {
2165 SV *maybe_ary = POPs;
2166 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2168 SV * const right = maybe_ary;
2169 if (UNLIKELY(cxtype & CXp_FOR_LVREF))
2170 DIE(aTHX_ "Assigned value is not a reference");
2173 if (RANGE_IS_NUMERIC(sv,right)) {
2174 cx->cx_type &= ~CXTYPEMASK;
2175 cx->cx_type |= CXt_LOOP_LAZYIV;
2176 /* Make sure that no-one re-orders cop.h and breaks our
2178 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2179 if (S_outside_integer(aTHX_ sv) ||
2180 S_outside_integer(aTHX_ right))
2181 DIE(aTHX_ "Range iterator outside integer range");
2182 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2183 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2185 /* for correct -Dstv display */
2186 cx->blk_oldsp = sp - PL_stack_base;
2190 cx->cx_type &= ~CXTYPEMASK;
2191 cx->cx_type |= CXt_LOOP_LAZYSV;
2192 /* Make sure that no-one re-orders cop.h and breaks our
2194 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2195 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2196 cx->blk_loop.state_u.lazysv.end = right;
2197 SvREFCNT_inc(right);
2198 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2199 /* This will do the upgrade to SVt_PV, and warn if the value
2200 is uninitialised. */
2201 (void) SvPV_nolen_const(right);
2202 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2203 to replace !SvOK() with a pointer to "". */
2205 SvREFCNT_dec(right);
2206 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2210 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2211 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2212 SvREFCNT_inc(maybe_ary);
2213 cx->blk_loop.state_u.ary.ix =
2214 (PL_op->op_private & OPpITER_REVERSED) ?
2215 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2219 else { /* iterating over items on the stack */
2220 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2221 if (PL_op->op_private & OPpITER_REVERSED) {
2222 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2225 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2236 const I32 gimme = GIMME_V;
2238 ENTER_with_name("loop1");
2240 ENTER_with_name("loop2");
2242 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2243 PUSHLOOP_PLAIN(cx, SP);
2258 assert(CxTYPE_is_LOOP(cx));
2260 newsp = PL_stack_base + cx->blk_loop.resetsp;
2262 SP = leave_common(newsp, SP, MARK, gimme, 0,
2263 PL_op->op_private & OPpLVALUE);
2266 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2267 PL_curpm = newpm; /* ... and pop $1 et al */
2269 LEAVE_with_name("loop2");
2270 LEAVE_with_name("loop1");
2276 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2277 PERL_CONTEXT *cx, PMOP *newpm)
2279 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2280 if (gimme == G_SCALAR) {
2281 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2283 const char *what = NULL;
2285 assert(MARK+1 == SP);
2286 if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
2287 !SvSMAGICAL(TOPs)) {
2289 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2290 : "a readonly value" : "a temporary";
2295 /* sub:lvalue{} will take us here. */
2304 "Can't return %s from lvalue subroutine", what
2309 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2310 if (!SvPADTMP(*SP)) {
2311 *++newsp = SvREFCNT_inc(*SP);
2316 /* FREETMPS could clobber it */
2317 SV *sv = SvREFCNT_inc(*SP);
2319 *++newsp = sv_mortalcopy(sv);
2326 ? sv_mortalcopy(*SP)
2328 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2333 *++newsp = &PL_sv_undef;
2335 if (CxLVAL(cx) & OPpDEREF) {
2338 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2342 else if (gimme == G_ARRAY) {
2343 assert (!(CxLVAL(cx) & OPpDEREF));
2344 if (ref || !CxLVAL(cx))
2345 while (++MARK <= SP)
2347 SvFLAGS(*MARK) & SVs_PADTMP
2348 ? sv_mortalcopy(*MARK)
2351 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2352 else while (++MARK <= SP) {
2353 if (*MARK != &PL_sv_undef
2354 && (SvPADTMP(*MARK) || SvREADONLY(*MARK))
2356 const bool ro = cBOOL( SvREADONLY(*MARK) );
2358 /* Might be flattened array after $#array = */
2365 /* diag_listed_as: Can't return %s from lvalue subroutine */
2367 "Can't return a %s from lvalue subroutine",
2368 ro ? "readonly value" : "temporary");
2374 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2377 PL_stack_sp = newsp;
2384 bool popsub2 = FALSE;
2385 bool clear_errsv = FALSE;
2395 const I32 cxix = dopoptosub(cxstack_ix);
2398 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2399 * sort block, which is a CXt_NULL
2402 PL_stack_base[1] = *PL_stack_sp;
2403 PL_stack_sp = PL_stack_base + 1;
2407 DIE(aTHX_ "Can't return outside a subroutine");
2409 if (cxix < cxstack_ix)
2412 if (CxMULTICALL(&cxstack[cxix])) {
2413 gimme = cxstack[cxix].blk_gimme;
2414 if (gimme == G_VOID)
2415 PL_stack_sp = PL_stack_base;
2416 else if (gimme == G_SCALAR) {
2417 PL_stack_base[1] = *PL_stack_sp;
2418 PL_stack_sp = PL_stack_base + 1;
2424 switch (CxTYPE(cx)) {
2427 lval = !!CvLVALUE(cx->blk_sub.cv);
2428 retop = cx->blk_sub.retop;
2429 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2432 if (!(PL_in_eval & EVAL_KEEPERR))
2435 namesv = cx->blk_eval.old_namesv;
2436 retop = cx->blk_eval.retop;
2439 if (optype == OP_REQUIRE &&
2440 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2442 /* Unassume the success we assumed earlier. */
2443 (void)hv_delete(GvHVn(PL_incgv),
2444 SvPVX_const(namesv),
2445 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2447 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2451 retop = cx->blk_sub.retop;
2455 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2459 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2461 if (gimme == G_SCALAR) {
2464 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2465 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2466 && !SvMAGICAL(TOPs)) {
2467 *++newsp = SvREFCNT_inc(*SP);
2472 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2474 *++newsp = sv_mortalcopy(sv);
2478 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2479 && !SvMAGICAL(*SP)) {
2483 *++newsp = sv_mortalcopy(*SP);
2486 *++newsp = sv_mortalcopy(*SP);
2489 *++newsp = &PL_sv_undef;
2491 else if (gimme == G_ARRAY) {
2492 while (++MARK <= SP) {
2493 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2494 && !SvGMAGICAL(*MARK)
2495 ? *MARK : sv_mortalcopy(*MARK);
2496 TAINT_NOT; /* Each item is independent */
2499 PL_stack_sp = newsp;
2503 /* Stack values are safe: */
2506 POPSUB(cx,sv); /* release CV and @_ ... */
2510 PL_curpm = newpm; /* ... and pop $1 et al */
2519 /* This duplicates parts of pp_leavesub, so that it can share code with
2530 if (CxMULTICALL(&cxstack[cxstack_ix]))
2534 cxstack_ix++; /* temporarily protect top context */
2538 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2541 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2543 PL_curpm = newpm; /* ... and pop $1 et al */
2546 return cx->blk_sub.retop;
2550 S_unwind_loop(pTHX_ const char * const opname)
2553 if (PL_op->op_flags & OPf_SPECIAL) {
2554 cxix = dopoptoloop(cxstack_ix);
2556 /* diag_listed_as: Can't "last" outside a loop block */
2557 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2562 const char * const label =
2563 PL_op->op_flags & OPf_STACKED
2564 ? SvPV(TOPs,label_len)
2565 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2566 const U32 label_flags =
2567 PL_op->op_flags & OPf_STACKED
2569 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2571 cxix = dopoptolabel(label, label_len, label_flags);
2573 /* diag_listed_as: Label not found for "last %s" */
2574 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2576 SVfARG(PL_op->op_flags & OPf_STACKED
2577 && !SvGMAGICAL(TOPp1s)
2579 : newSVpvn_flags(label,
2581 label_flags | SVs_TEMP)));
2583 if (cxix < cxstack_ix)
2599 S_unwind_loop(aTHX_ "last");
2602 cxstack_ix++; /* temporarily protect top context */
2603 switch (CxTYPE(cx)) {
2604 case CXt_LOOP_LAZYIV:
2605 case CXt_LOOP_LAZYSV:
2607 case CXt_LOOP_PLAIN:
2609 newsp = PL_stack_base + cx->blk_loop.resetsp;
2610 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2614 nextop = cx->blk_sub.retop;
2618 nextop = cx->blk_eval.retop;
2622 nextop = cx->blk_sub.retop;
2625 DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2629 PL_stack_sp = newsp;
2633 /* Stack values are safe: */
2635 case CXt_LOOP_LAZYIV:
2636 case CXt_LOOP_PLAIN:
2637 case CXt_LOOP_LAZYSV:
2639 POPLOOP(cx); /* release loop vars ... */
2643 POPSUB(cx,sv); /* release CV and @_ ... */
2646 PL_curpm = newpm; /* ... and pop $1 et al */
2649 PERL_UNUSED_VAR(optype);
2650 PERL_UNUSED_VAR(gimme);
2657 const I32 inner = PL_scopestack_ix;
2659 S_unwind_loop(aTHX_ "next");
2661 /* clear off anything above the scope we're re-entering, but
2662 * save the rest until after a possible continue block */
2664 if (PL_scopestack_ix < inner)
2665 leave_scope(PL_scopestack[PL_scopestack_ix]);
2666 PL_curcop = cx->blk_oldcop;
2668 return (cx)->blk_loop.my_op->op_nextop;
2673 const I32 cxix = S_unwind_loop(aTHX_ "redo");
2676 OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2678 if (redo_op->op_type == OP_ENTER) {
2679 /* pop one less context to avoid $x being freed in while (my $x..) */
2681 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2682 redo_op = redo_op->op_next;
2686 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2687 LEAVE_SCOPE(oldsave);
2689 PL_curcop = cx->blk_oldcop;
2695 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2698 static const char* const too_deep = "Target of goto is too deeply nested";
2700 PERL_ARGS_ASSERT_DOFINDLABEL;
2703 Perl_croak(aTHX_ "%s", too_deep);
2704 if (o->op_type == OP_LEAVE ||
2705 o->op_type == OP_SCOPE ||
2706 o->op_type == OP_LEAVELOOP ||
2707 o->op_type == OP_LEAVESUB ||
2708 o->op_type == OP_LEAVETRY)
2710 *ops++ = cUNOPo->op_first;
2712 Perl_croak(aTHX_ "%s", too_deep);
2715 if (o->op_flags & OPf_KIDS) {
2717 /* First try all the kids at this level, since that's likeliest. */
2718 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2719 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2720 STRLEN kid_label_len;
2721 U32 kid_label_flags;
2722 const char *kid_label = CopLABEL_len_flags(kCOP,
2723 &kid_label_len, &kid_label_flags);
2725 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2728 (const U8*)kid_label, kid_label_len,
2729 (const U8*)label, len) == 0)
2731 (const U8*)label, len,
2732 (const U8*)kid_label, kid_label_len) == 0)
2733 : ( len == kid_label_len && ((kid_label == label)
2734 || memEQ(kid_label, label, len)))))
2738 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2739 if (kid == PL_lastgotoprobe)
2741 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2744 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2745 ops[-1]->op_type == OP_DBSTATE)
2750 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2759 /* also used for: pp_dump() */
2767 #define GOTO_DEPTH 64
2768 OP *enterops[GOTO_DEPTH];
2769 const char *label = NULL;
2770 STRLEN label_len = 0;
2771 U32 label_flags = 0;
2772 const bool do_dump = (PL_op->op_type == OP_DUMP);
2773 static const char* const must_have_label = "goto must have label";
2775 if (PL_op->op_flags & OPf_STACKED) {
2776 /* goto EXPR or goto &foo */
2778 SV * const sv = POPs;
2781 /* This egregious kludge implements goto &subroutine */
2782 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2785 CV *cv = MUTABLE_CV(SvRV(sv));
2786 AV *arg = GvAV(PL_defgv);
2790 if (!CvROOT(cv) && !CvXSUB(cv)) {
2791 const GV * const gv = CvGV(cv);
2795 /* autoloaded stub? */
2796 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2798 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2800 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2801 if (autogv && (cv = GvCV(autogv)))
2803 tmpstr = sv_newmortal();
2804 gv_efullname3(tmpstr, gv, NULL);
2805 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2807 DIE(aTHX_ "Goto undefined subroutine");
2810 /* First do some returnish stuff. */
2811 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2813 cxix = dopoptosub(cxstack_ix);
2814 if (cxix < cxstack_ix) {
2817 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2823 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2824 if (CxTYPE(cx) == CXt_EVAL) {
2827 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2828 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2830 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2831 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2833 else if (CxMULTICALL(cx))
2836 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2838 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2839 AV* av = cx->blk_sub.argarray;
2841 /* abandon the original @_ if it got reified or if it is
2842 the same as the current @_ */
2843 if (AvREAL(av) || av == arg) {
2847 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2849 else CLEAR_ARGARRAY(av);
2851 /* We donate this refcount later to the callee’s pad. */
2852 SvREFCNT_inc_simple_void(arg);
2853 if (CxTYPE(cx) == CXt_SUB &&
2854 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2855 SvREFCNT_dec(cx->blk_sub.cv);
2856 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2857 LEAVE_SCOPE(oldsave);
2859 /* A destructor called during LEAVE_SCOPE could have undefined
2860 * our precious cv. See bug #99850. */
2861 if (!CvROOT(cv) && !CvXSUB(cv)) {
2862 const GV * const gv = CvGV(cv);
2865 SV * const tmpstr = sv_newmortal();
2866 gv_efullname3(tmpstr, gv, NULL);
2867 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2870 DIE(aTHX_ "Goto undefined subroutine");
2873 /* Now do some callish stuff. */
2875 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2879 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2880 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2883 PERL_UNUSED_VAR(newsp);
2884 PERL_UNUSED_VAR(gimme);
2886 /* put GvAV(defgv) back onto stack */
2888 EXTEND(SP, items+1); /* @_ could have been extended. */
2893 bool r = cBOOL(AvREAL(arg));
2894 for (index=0; index<items; index++)
2898 SV ** const svp = av_fetch(arg, index, 0);
2899 sv = svp ? *svp : NULL;
2901 else sv = AvARRAY(arg)[index];
2903 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2904 : sv_2mortal(newSVavdefelem(arg, index, 1));
2909 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2910 /* Restore old @_ */
2911 arg = GvAV(PL_defgv);
2912 GvAV(PL_defgv) = cx->blk_sub.savearray;
2916 retop = cx->blk_sub.retop;
2917 /* XS subs don't have a CxSUB, so pop it */
2918 POPBLOCK(cx, PL_curpm);
2919 /* Push a mark for the start of arglist */
2922 (void)(*CvXSUB(cv))(aTHX_ cv);
2927 PADLIST * const padlist = CvPADLIST(cv);
2928 cx->blk_sub.cv = cv;
2929 cx->blk_sub.olddepth = CvDEPTH(cv);
2932 if (CvDEPTH(cv) < 2)
2933 SvREFCNT_inc_simple_void_NN(cv);
2935 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2936 sub_crush_depth(cv);
2937 pad_push(padlist, CvDEPTH(cv));
2939 PL_curcop = cx->blk_oldcop;
2941 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2944 CX_CURPAD_SAVE(cx->blk_sub);
2946 /* cx->blk_sub.argarray has no reference count, so we
2947 need something to hang on to our argument array so
2948 that cx->blk_sub.argarray does not end up pointing
2949 to freed memory as the result of undef *_. So put
2950 it in the callee’s pad, donating our refer-
2953 SvREFCNT_dec(PAD_SVl(0));
2954 PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2957 /* GvAV(PL_defgv) might have been modified on scope
2958 exit, so restore it. */
2959 if (arg != GvAV(PL_defgv)) {
2960 AV * const av = GvAV(PL_defgv);
2961 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2965 else SvREFCNT_dec(arg);
2966 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2967 Perl_get_db_sub(aTHX_ NULL, cv);
2969 CV * const gotocv = get_cvs("DB::goto", 0);
2971 PUSHMARK( PL_stack_sp );
2972 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2977 retop = CvSTART(cv);
2978 goto putback_return;
2983 label = SvPV_nomg_const(sv, label_len);
2984 label_flags = SvUTF8(sv);
2987 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2988 /* goto LABEL or dump LABEL */
2989 label = cPVOP->op_pv;
2990 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2991 label_len = strlen(label);
2993 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2998 OP *gotoprobe = NULL;
2999 bool leaving_eval = FALSE;
3000 bool in_block = FALSE;
3001 PERL_CONTEXT *last_eval_cx = NULL;
3005 PL_lastgotoprobe = NULL;
3007 for (ix = cxstack_ix; ix >= 0; ix--) {
3009 switch (CxTYPE(cx)) {
3011 leaving_eval = TRUE;
3012 if (!CxTRYBLOCK(cx)) {
3013 gotoprobe = (last_eval_cx ?
3014 last_eval_cx->blk_eval.old_eval_root :
3019 /* else fall through */
3020 case CXt_LOOP_LAZYIV:
3021 case CXt_LOOP_LAZYSV:
3023 case CXt_LOOP_PLAIN:
3026 gotoprobe = OpSIBLING(cx->blk_oldcop);
3032 gotoprobe = OpSIBLING(cx->blk_oldcop);
3035 gotoprobe = PL_main_root;
3038 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3039 gotoprobe = CvROOT(cx->blk_sub.cv);
3045 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3048 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3049 CxTYPE(cx), (long) ix);
3050 gotoprobe = PL_main_root;
3056 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3057 enterops, enterops + GOTO_DEPTH);
3060 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3061 sibl1->op_type == OP_UNSTACK &&
3062 (sibl2 = OpSIBLING(sibl1)))
3064 retop = dofindlabel(sibl2,
3065 label, label_len, label_flags, enterops,
3066 enterops + GOTO_DEPTH);
3071 PL_lastgotoprobe = gotoprobe;
3074 DIE(aTHX_ "Can't find label %"UTF8f,
3075 UTF8fARG(label_flags, label_len, label));
3077 /* if we're leaving an eval, check before we pop any frames
3078 that we're not going to punt, otherwise the error
3081 if (leaving_eval && *enterops && enterops[1]) {
3083 for (i = 1; enterops[i]; i++)
3084 if (enterops[i]->op_type == OP_ENTERITER)
3085 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3088 if (*enterops && enterops[1]) {
3089 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3091 deprecate("\"goto\" to jump into a construct");
3094 /* pop unwanted frames */
3096 if (ix < cxstack_ix) {
3100 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3103 oldsave = PL_scopestack[PL_scopestack_ix];
3104 LEAVE_SCOPE(oldsave);
3107 /* push wanted frames */
3109 if (*enterops && enterops[1]) {
3110 OP * const oldop = PL_op;
3111 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3112 for (; enterops[ix]; ix++) {
3113 PL_op = enterops[ix];
3114 /* Eventually we may want to stack the needed arguments
3115 * for each op. For now, we punt on the hard ones. */
3116 if (PL_op->op_type == OP_ENTERITER)
3117 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3118 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)
4512 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4514 PL_op = (OP *) matcher;
4517 (void) Perl_pp_match(aTHX);
4519 return (SvTRUEx(POPs));
4523 S_destroy_matcher(pTHX_ PMOP *matcher)
4525 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4526 PERL_UNUSED_ARG(matcher);
4529 LEAVE_with_name("matcher");
4532 /* Do a smart match */
4535 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4536 return do_smartmatch(NULL, NULL, 0);
4539 /* This version of do_smartmatch() implements the
4540 * table of smart matches that is found in perlsyn.
4543 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4547 bool object_on_left = FALSE;
4548 SV *e = TOPs; /* e is for 'expression' */
4549 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4551 /* Take care only to invoke mg_get() once for each argument.
4552 * Currently we do this by copying the SV if it's magical. */
4554 if (!copied && SvGMAGICAL(d))
4555 d = sv_mortalcopy(d);
4562 e = sv_mortalcopy(e);
4564 /* First of all, handle overload magic of the rightmost argument */
4567 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4568 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4570 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4577 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4580 SP -= 2; /* Pop the values */
4585 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4592 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4593 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4594 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4596 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4597 object_on_left = TRUE;
4600 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4602 if (object_on_left) {
4603 goto sm_any_sub; /* Treat objects like scalars */
4605 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4606 /* Test sub truth for each key */
4608 bool andedresults = TRUE;
4609 HV *hv = (HV*) SvRV(d);
4610 I32 numkeys = hv_iterinit(hv);
4611 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4614 while ( (he = hv_iternext(hv)) ) {
4615 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4616 ENTER_with_name("smartmatch_hash_key_test");
4619 PUSHs(hv_iterkeysv(he));
4621 c = call_sv(e, G_SCALAR);
4624 andedresults = FALSE;
4626 andedresults = SvTRUEx(POPs) && andedresults;
4628 LEAVE_with_name("smartmatch_hash_key_test");
4635 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4636 /* Test sub truth for each element */
4638 bool andedresults = TRUE;
4639 AV *av = (AV*) SvRV(d);
4640 const I32 len = av_tindex(av);
4641 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4644 for (i = 0; i <= len; ++i) {
4645 SV * const * const svp = av_fetch(av, i, FALSE);
4646 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4647 ENTER_with_name("smartmatch_array_elem_test");
4653 c = call_sv(e, G_SCALAR);
4656 andedresults = FALSE;
4658 andedresults = SvTRUEx(POPs) && andedresults;
4660 LEAVE_with_name("smartmatch_array_elem_test");
4669 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4670 ENTER_with_name("smartmatch_coderef");
4675 c = call_sv(e, G_SCALAR);
4679 else if (SvTEMP(TOPs))
4680 SvREFCNT_inc_void(TOPs);
4682 LEAVE_with_name("smartmatch_coderef");
4687 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4688 if (object_on_left) {
4689 goto sm_any_hash; /* Treat objects like scalars */
4691 else if (!SvOK(d)) {
4692 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4695 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4696 /* Check that the key-sets are identical */
4698 HV *other_hv = MUTABLE_HV(SvRV(d));
4701 U32 this_key_count = 0,
4702 other_key_count = 0;
4703 HV *hv = MUTABLE_HV(SvRV(e));
4705 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4706 /* Tied hashes don't know how many keys they have. */
4707 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4708 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4712 HV * const temp = other_hv;
4718 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4722 /* The hashes have the same number of keys, so it suffices
4723 to check that one is a subset of the other. */
4724 (void) hv_iterinit(hv);
4725 while ( (he = hv_iternext(hv)) ) {
4726 SV *key = hv_iterkeysv(he);
4728 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4731 if(!hv_exists_ent(other_hv, key, 0)) {
4732 (void) hv_iterinit(hv); /* reset iterator */
4738 (void) hv_iterinit(other_hv);
4739 while ( hv_iternext(other_hv) )
4743 other_key_count = HvUSEDKEYS(other_hv);
4745 if (this_key_count != other_key_count)
4750 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4751 AV * const other_av = MUTABLE_AV(SvRV(d));
4752 const SSize_t other_len = av_tindex(other_av) + 1;
4754 HV *hv = MUTABLE_HV(SvRV(e));
4756 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4757 for (i = 0; i < other_len; ++i) {
4758 SV ** const svp = av_fetch(other_av, i, FALSE);
4759 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4760 if (svp) { /* ??? When can this not happen? */
4761 if (hv_exists_ent(hv, *svp, 0))
4767 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4768 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4771 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4773 HV *hv = MUTABLE_HV(SvRV(e));
4775 (void) hv_iterinit(hv);
4776 while ( (he = hv_iternext(hv)) ) {
4777 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4778 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4779 (void) hv_iterinit(hv);
4780 destroy_matcher(matcher);
4784 destroy_matcher(matcher);
4790 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4791 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4798 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4799 if (object_on_left) {
4800 goto sm_any_array; /* Treat objects like scalars */
4802 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4803 AV * const other_av = MUTABLE_AV(SvRV(e));
4804 const SSize_t other_len = av_tindex(other_av) + 1;
4807 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4808 for (i = 0; i < other_len; ++i) {
4809 SV ** const svp = av_fetch(other_av, i, FALSE);
4811 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4812 if (svp) { /* ??? When can this not happen? */
4813 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4819 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4820 AV *other_av = MUTABLE_AV(SvRV(d));
4821 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4822 if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4826 const SSize_t other_len = av_tindex(other_av);
4828 if (NULL == seen_this) {
4829 seen_this = newHV();
4830 (void) sv_2mortal(MUTABLE_SV(seen_this));
4832 if (NULL == seen_other) {
4833 seen_other = newHV();
4834 (void) sv_2mortal(MUTABLE_SV(seen_other));
4836 for(i = 0; i <= other_len; ++i) {
4837 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4838 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4840 if (!this_elem || !other_elem) {
4841 if ((this_elem && SvOK(*this_elem))
4842 || (other_elem && SvOK(*other_elem)))
4845 else if (hv_exists_ent(seen_this,
4846 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4847 hv_exists_ent(seen_other,
4848 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4850 if (*this_elem != *other_elem)
4854 (void)hv_store_ent(seen_this,
4855 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4857 (void)hv_store_ent(seen_other,
4858 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4864 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4865 (void) do_smartmatch(seen_this, seen_other, 0);
4867 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4876 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4877 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4880 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4881 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4884 for(i = 0; i <= this_len; ++i) {
4885 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4886 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4887 if (svp && matcher_matches_sv(matcher, *svp)) {
4888 destroy_matcher(matcher);
4892 destroy_matcher(matcher);
4896 else if (!SvOK(d)) {
4897 /* undef ~~ array */
4898 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4901 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4902 for (i = 0; i <= this_len; ++i) {
4903 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4904 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4905 if (!svp || !SvOK(*svp))
4914 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4916 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4917 for (i = 0; i <= this_len; ++i) {
4918 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4925 /* infinite recursion isn't supposed to happen here */
4926 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4927 (void) do_smartmatch(NULL, NULL, 1);
4929 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4938 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4939 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4940 SV *t = d; d = e; e = t;
4941 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4944 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4945 SV *t = d; d = e; e = t;
4946 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4947 goto sm_regex_array;
4950 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4952 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4954 PUSHs(matcher_matches_sv(matcher, d)
4957 destroy_matcher(matcher);
4962 /* See if there is overload magic on left */
4963 else if (object_on_left && SvAMAGIC(d)) {
4965 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4966 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4969 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4977 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4980 else if (!SvOK(d)) {
4981 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4982 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4987 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4988 DEBUG_M(if (SvNIOK(e))
4989 Perl_deb(aTHX_ " applying rule Any-Num\n");
4991 Perl_deb(aTHX_ " applying rule Num-numish\n");
4993 /* numeric comparison */
4996 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4997 (void) Perl_pp_i_eq(aTHX);
4999 (void) Perl_pp_eq(aTHX);
5007 /* As a last resort, use string comparison */
5008 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
5011 return Perl_pp_seq(aTHX);
5018 const I32 gimme = GIMME_V;
5020 /* This is essentially an optimization: if the match
5021 fails, we don't want to push a context and then
5022 pop it again right away, so we skip straight
5023 to the op that follows the leavewhen.
5024 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5026 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
5027 RETURNOP(cLOGOP->op_other->op_next);
5029 ENTER_with_name("when");
5032 PUSHBLOCK(cx, CXt_WHEN, SP);
5047 cxix = dopoptogiven(cxstack_ix);
5049 /* diag_listed_as: Can't "when" outside a topicalizer */
5050 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5051 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5054 assert(CxTYPE(cx) == CXt_WHEN);
5056 SP = leave_common(newsp, SP, newsp, gimme,
5057 SVs_PADTMP|SVs_TEMP, FALSE);
5058 PL_curpm = newpm; /* pop $1 et al */
5060 LEAVE_with_name("when");
5062 if (cxix < cxstack_ix)
5065 cx = &cxstack[cxix];
5067 if (CxFOREACH(cx)) {
5068 /* clear off anything above the scope we're re-entering */
5069 I32 inner = PL_scopestack_ix;
5072 if (PL_scopestack_ix < inner)
5073 leave_scope(PL_scopestack[PL_scopestack_ix]);
5074 PL_curcop = cx->blk_oldcop;
5077 return cx->blk_loop.my_op->op_nextop;
5081 RETURNOP(cx->blk_givwhen.leave_op);
5094 PERL_UNUSED_VAR(gimme);
5096 cxix = dopoptowhen(cxstack_ix);
5098 DIE(aTHX_ "Can't \"continue\" outside a when block");
5100 if (cxix < cxstack_ix)
5104 assert(CxTYPE(cx) == CXt_WHEN);
5107 PL_curpm = newpm; /* pop $1 et al */
5109 LEAVE_with_name("when");
5110 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5118 cxix = dopoptogiven(cxstack_ix);
5120 DIE(aTHX_ "Can't \"break\" outside a given block");
5122 cx = &cxstack[cxix];
5124 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5126 if (cxix < cxstack_ix)
5129 /* Restore the sp at the time we entered the given block */
5132 return cx->blk_givwhen.leave_op;
5136 S_doparseform(pTHX_ SV *sv)
5139 char *s = SvPV(sv, len);
5141 char *base = NULL; /* start of current field */
5142 I32 skipspaces = 0; /* number of contiguous spaces seen */
5143 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5144 bool repeat = FALSE; /* ~~ seen on this line */
5145 bool postspace = FALSE; /* a text field may need right padding */
5148 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5150 bool ischop; /* it's a ^ rather than a @ */
5151 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5152 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5156 PERL_ARGS_ASSERT_DOPARSEFORM;
5159 Perl_croak(aTHX_ "Null picture in formline");
5161 if (SvTYPE(sv) >= SVt_PVMG) {
5162 /* This might, of course, still return NULL. */
5163 mg = mg_find(sv, PERL_MAGIC_fm);
5165 sv_upgrade(sv, SVt_PVMG);
5169 /* still the same as previously-compiled string? */
5170 SV *old = mg->mg_obj;
5171 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5172 && len == SvCUR(old)
5173 && strnEQ(SvPVX(old), SvPVX(sv), len)
5175 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5179 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5180 Safefree(mg->mg_ptr);
5186 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5187 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5190 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5191 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5195 /* estimate the buffer size needed */
5196 for (base = s; s <= send; s++) {
5197 if (*s == '\n' || *s == '@' || *s == '^')
5203 Newx(fops, maxops, U32);
5208 *fpc++ = FF_LINEMARK;
5209 noblank = repeat = FALSE;
5227 case ' ': case '\t':
5234 } /* else FALL THROUGH */
5242 *fpc++ = FF_LITERAL;
5250 *fpc++ = (U32)skipspaces;
5254 *fpc++ = FF_NEWLINE;
5258 arg = fpc - linepc + 1;
5265 *fpc++ = FF_LINEMARK;
5266 noblank = repeat = FALSE;
5275 ischop = s[-1] == '^';
5281 arg = (s - base) - 1;
5283 *fpc++ = FF_LITERAL;
5289 if (*s == '*') { /* @* or ^* */
5291 *fpc++ = 2; /* skip the @* or ^* */
5293 *fpc++ = FF_LINESNGL;
5296 *fpc++ = FF_LINEGLOB;
5298 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5299 arg = ischop ? FORM_NUM_BLANK : 0;
5304 const char * const f = ++s;
5307 arg |= FORM_NUM_POINT + (s - f);
5309 *fpc++ = s - base; /* fieldsize for FETCH */
5310 *fpc++ = FF_DECIMAL;
5312 unchopnum |= ! ischop;
5314 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5315 arg = ischop ? FORM_NUM_BLANK : 0;
5317 s++; /* skip the '0' first */
5321 const char * const f = ++s;
5324 arg |= FORM_NUM_POINT + (s - f);
5326 *fpc++ = s - base; /* fieldsize for FETCH */
5327 *fpc++ = FF_0DECIMAL;
5329 unchopnum |= ! ischop;
5331 else { /* text field */
5333 bool ismore = FALSE;
5336 while (*++s == '>') ;
5337 prespace = FF_SPACE;
5339 else if (*s == '|') {
5340 while (*++s == '|') ;
5341 prespace = FF_HALFSPACE;
5346 while (*++s == '<') ;
5349 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5353 *fpc++ = s - base; /* fieldsize for FETCH */
5355 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5358 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5372 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5375 mg->mg_ptr = (char *) fops;
5376 mg->mg_len = arg * sizeof(U32);
5377 mg->mg_obj = sv_copy;
5378 mg->mg_flags |= MGf_REFCOUNTED;
5380 if (unchopnum && repeat)
5381 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5388 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5390 /* Can value be printed in fldsize chars, using %*.*f ? */
5394 int intsize = fldsize - (value < 0 ? 1 : 0);
5396 if (frcsize & FORM_NUM_POINT)
5398 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5401 while (intsize--) pwr *= 10.0;
5402 while (frcsize--) eps /= 10.0;
5405 if (value + eps >= pwr)
5408 if (value - eps <= -pwr)
5415 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5417 SV * const datasv = FILTER_DATA(idx);
5418 const int filter_has_file = IoLINES(datasv);
5419 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5420 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5425 char *prune_from = NULL;
5426 bool read_from_cache = FALSE;
5430 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5432 assert(maxlen >= 0);
5435 /* I was having segfault trouble under Linux 2.2.5 after a
5436 parse error occurred. (Had to hack around it with a test
5437 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5438 not sure where the trouble is yet. XXX */
5441 SV *const cache = datasv;
5444 const char *cache_p = SvPV(cache, cache_len);
5448 /* Running in block mode and we have some cached data already.
5450 if (cache_len >= umaxlen) {
5451 /* In fact, so much data we don't even need to call
5456 const char *const first_nl =
5457 (const char *)memchr(cache_p, '\n', cache_len);
5459 take = first_nl + 1 - cache_p;
5463 sv_catpvn(buf_sv, cache_p, take);
5464 sv_chop(cache, cache_p + take);
5465 /* Definitely not EOF */
5469 sv_catsv(buf_sv, cache);
5471 umaxlen -= cache_len;
5474 read_from_cache = TRUE;
5478 /* Filter API says that the filter appends to the contents of the buffer.
5479 Usually the buffer is "", so the details don't matter. But if it's not,
5480 then clearly what it contains is already filtered by this filter, so we
5481 don't want to pass it in a second time.
5482 I'm going to use a mortal in case the upstream filter croaks. */
5483 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5484 ? sv_newmortal() : buf_sv;
5485 SvUPGRADE(upstream, SVt_PV);
5487 if (filter_has_file) {
5488 status = FILTER_READ(idx+1, upstream, 0);
5491 if (filter_sub && status >= 0) {
5495 ENTER_with_name("call_filter_sub");
5500 DEFSV_set(upstream);
5504 PUSHs(filter_state);
5507 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5517 SV * const errsv = ERRSV;
5518 if (SvTRUE_NN(errsv))
5519 err = newSVsv(errsv);
5525 LEAVE_with_name("call_filter_sub");
5528 if (SvGMAGICAL(upstream)) {
5530 if (upstream == buf_sv) mg_free(buf_sv);
5532 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5533 if(!err && SvOK(upstream)) {
5534 got_p = SvPV_nomg(upstream, got_len);
5536 if (got_len > umaxlen) {
5537 prune_from = got_p + umaxlen;
5540 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5541 if (first_nl && first_nl + 1 < got_p + got_len) {
5542 /* There's a second line here... */
5543 prune_from = first_nl + 1;
5547 if (!err && prune_from) {
5548 /* Oh. Too long. Stuff some in our cache. */
5549 STRLEN cached_len = got_p + got_len - prune_from;
5550 SV *const cache = datasv;
5553 /* Cache should be empty. */
5554 assert(!SvCUR(cache));
5557 sv_setpvn(cache, prune_from, cached_len);
5558 /* If you ask for block mode, you may well split UTF-8 characters.
5559 "If it breaks, you get to keep both parts"
5560 (Your code is broken if you don't put them back together again
5561 before something notices.) */
5562 if (SvUTF8(upstream)) {
5565 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5567 /* Cannot just use sv_setpvn, as that could free the buffer
5568 before we have a chance to assign it. */
5569 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5570 got_len - cached_len);
5572 /* Can't yet be EOF */
5577 /* If they are at EOF but buf_sv has something in it, then they may never
5578 have touched the SV upstream, so it may be undefined. If we naively
5579 concatenate it then we get a warning about use of uninitialised value.
5581 if (!err && upstream != buf_sv &&
5583 sv_catsv_nomg(buf_sv, upstream);
5585 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5588 IoLINES(datasv) = 0;
5590 SvREFCNT_dec(filter_state);
5591 IoTOP_GV(datasv) = NULL;
5594 SvREFCNT_dec(filter_sub);
5595 IoBOTTOM_GV(datasv) = NULL;
5597 filter_del(S_run_user_filter);
5603 if (status == 0 && read_from_cache) {
5604 /* If we read some data from the cache (and by getting here it implies
5605 that we emptied the cache) then we aren't yet at EOF, and mustn't
5606 report that to our caller. */
5614 * c-indentation-style: bsd
5616 * indent-tabs-mode: nil
5619 * ex: set ts=8 sts=4 sw=4 et: