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 assert(TAINTING_get || !TAINT_get);
170 SvTAINTED_on((SV*)new_re);
174 #if !defined(USE_ITHREADS)
175 /* can't change the optree at runtime either */
176 /* PMf_KEEP is handled differently under threads to avoid these problems */
177 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
179 if (pm->op_pmflags & PMf_KEEP) {
180 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
181 cLOGOP->op_first->op_next = PL_op->op_next;
193 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
194 PMOP * const pm = (PMOP*) cLOGOP->op_other;
195 SV * const dstr = cx->sb_dstr;
198 char *orig = cx->sb_orig;
199 REGEXP * const rx = cx->sb_rx;
201 REGEXP *old = PM_GETRE(pm);
208 PM_SETRE(pm,ReREFCNT_inc(rx));
211 rxres_restore(&cx->sb_rxres, rx);
213 if (cx->sb_iters++) {
214 const SSize_t saviters = cx->sb_iters;
215 if (cx->sb_iters > cx->sb_maxiters)
216 DIE(aTHX_ "Substitution loop");
218 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
220 /* See "how taint works" above pp_subst() */
222 cx->sb_rxtainted |= SUBST_TAINT_REPL;
223 sv_catsv_nomg(dstr, POPs);
224 if (CxONCE(cx) || s < orig ||
225 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
226 (s == m), cx->sb_targ, NULL,
227 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
229 SV *targ = cx->sb_targ;
231 assert(cx->sb_strend >= s);
232 if(cx->sb_strend > s) {
233 if (DO_UTF8(dstr) && !SvUTF8(targ))
234 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
236 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
238 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
239 cx->sb_rxtainted |= SUBST_TAINT_PAT;
241 if (pm->op_pmflags & PMf_NONDESTRUCT) {
243 /* From here on down we're using the copy, and leaving the
244 original untouched. */
248 SV_CHECK_THINKFIRST_COW_DROP(targ);
249 if (isGV(targ)) Perl_croak_no_modify();
251 SvPV_set(targ, SvPVX(dstr));
252 SvCUR_set(targ, SvCUR(dstr));
253 SvLEN_set(targ, SvLEN(dstr));
256 SvPV_set(dstr, NULL);
259 mPUSHi(saviters - 1);
261 (void)SvPOK_only_UTF8(targ);
264 /* update the taint state of various various variables in
265 * preparation for final exit.
266 * See "how taint works" above pp_subst() */
268 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
269 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
270 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
272 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
274 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
275 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
277 SvTAINTED_on(TOPs); /* taint return value */
278 /* needed for mg_set below */
280 cBOOL(cx->sb_rxtainted &
281 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
285 /* PL_tainted must be correctly set for this mg_set */
288 LEAVE_SCOPE(cx->sb_oldsave);
291 RETURNOP(pm->op_next);
292 NOT_REACHED; /* NOTREACHED */
294 cx->sb_iters = saviters;
296 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
299 assert(!RX_SUBOFFSET(rx));
300 cx->sb_orig = orig = RX_SUBBEG(rx);
302 cx->sb_strend = s + (cx->sb_strend - m);
304 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
306 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
307 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
309 sv_catpvn_nomg(dstr, s, m-s);
311 cx->sb_s = RX_OFFS(rx)[0].end + orig;
312 { /* Update the pos() information. */
314 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
317 /* the string being matched against may no longer be a string,
318 * e.g. $_=0; s/.../$_++/ge */
321 SvPV_force_nomg_nolen(sv);
323 if (!(mg = mg_find_mglob(sv))) {
324 mg = sv_magicext_mglob(sv);
326 MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
329 (void)ReREFCNT_inc(rx);
330 /* update the taint state of various various variables in preparation
331 * for calling the code block.
332 * See "how taint works" above pp_subst() */
334 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
335 cx->sb_rxtainted |= SUBST_TAINT_PAT;
337 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
338 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
339 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
341 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
343 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
344 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
345 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
346 ? cx->sb_dstr : cx->sb_targ);
349 rxres_save(&cx->sb_rxres, rx);
351 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
355 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
360 PERL_ARGS_ASSERT_RXRES_SAVE;
363 if (!p || p[1] < RX_NPARENS(rx)) {
365 i = 7 + (RX_NPARENS(rx)+1) * 2;
367 i = 6 + (RX_NPARENS(rx)+1) * 2;
376 /* what (if anything) to free on croak */
377 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
378 RX_MATCH_COPIED_off(rx);
379 *p++ = RX_NPARENS(rx);
382 *p++ = PTR2UV(RX_SAVED_COPY(rx));
383 RX_SAVED_COPY(rx) = NULL;
386 *p++ = PTR2UV(RX_SUBBEG(rx));
387 *p++ = (UV)RX_SUBLEN(rx);
388 *p++ = (UV)RX_SUBOFFSET(rx);
389 *p++ = (UV)RX_SUBCOFFSET(rx);
390 for (i = 0; i <= RX_NPARENS(rx); ++i) {
391 *p++ = (UV)RX_OFFS(rx)[i].start;
392 *p++ = (UV)RX_OFFS(rx)[i].end;
397 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
402 PERL_ARGS_ASSERT_RXRES_RESTORE;
405 RX_MATCH_COPY_FREE(rx);
406 RX_MATCH_COPIED_set(rx, *p);
408 RX_NPARENS(rx) = *p++;
411 if (RX_SAVED_COPY(rx))
412 SvREFCNT_dec (RX_SAVED_COPY(rx));
413 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
417 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
418 RX_SUBLEN(rx) = (I32)(*p++);
419 RX_SUBOFFSET(rx) = (I32)*p++;
420 RX_SUBCOFFSET(rx) = (I32)*p++;
421 for (i = 0; i <= RX_NPARENS(rx); ++i) {
422 RX_OFFS(rx)[i].start = (I32)(*p++);
423 RX_OFFS(rx)[i].end = (I32)(*p++);
428 S_rxres_free(pTHX_ void **rsp)
430 UV * const p = (UV*)*rsp;
432 PERL_ARGS_ASSERT_RXRES_FREE;
436 void *tmp = INT2PTR(char*,*p);
439 U32 i = 9 + p[1] * 2;
441 U32 i = 8 + p[1] * 2;
446 SvREFCNT_dec (INT2PTR(SV*,p[2]));
449 PoisonFree(p, i, sizeof(UV));
458 #define FORM_NUM_BLANK (1<<30)
459 #define FORM_NUM_POINT (1<<29)
463 dSP; dMARK; dORIGMARK;
464 SV * const tmpForm = *++MARK;
465 SV *formsv; /* contains text of original format */
466 U32 *fpc; /* format ops program counter */
467 char *t; /* current append position in target string */
468 const char *f; /* current position in format string */
470 SV *sv = NULL; /* current item */
471 const char *item = NULL;/* string value of current item */
472 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
473 I32 itembytes = 0; /* as itemsize, but length in bytes */
474 I32 fieldsize = 0; /* width of current field */
475 I32 lines = 0; /* number of lines that have been output */
476 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
477 const char *chophere = NULL; /* where to chop current item */
478 STRLEN linemark = 0; /* pos of start of line in output */
480 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
481 STRLEN len; /* length of current sv */
482 STRLEN linemax; /* estimate of output size in bytes */
483 bool item_is_utf8 = FALSE;
484 bool targ_is_utf8 = FALSE;
487 U8 *source; /* source of bytes to append */
488 STRLEN to_copy; /* how may bytes to append */
489 char trans; /* what chars to translate */
491 mg = doparseform(tmpForm);
493 fpc = (U32*)mg->mg_ptr;
494 /* the actual string the format was compiled from.
495 * with overload etc, this may not match tmpForm */
499 SvPV_force(PL_formtarget, len);
500 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
501 SvTAINTED_on(PL_formtarget);
502 if (DO_UTF8(PL_formtarget))
504 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
505 t = SvGROW(PL_formtarget, len + linemax + 1);
506 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
508 f = SvPV_const(formsv, len);
512 const char *name = "???";
515 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
516 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
517 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
518 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
519 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
521 case FF_CHECKNL: name = "CHECKNL"; break;
522 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
523 case FF_SPACE: name = "SPACE"; break;
524 case FF_HALFSPACE: name = "HALFSPACE"; break;
525 case FF_ITEM: name = "ITEM"; break;
526 case FF_CHOP: name = "CHOP"; break;
527 case FF_LINEGLOB: name = "LINEGLOB"; break;
528 case FF_NEWLINE: name = "NEWLINE"; break;
529 case FF_MORE: name = "MORE"; break;
530 case FF_LINEMARK: name = "LINEMARK"; break;
531 case FF_END: name = "END"; break;
532 case FF_0DECIMAL: name = "0DECIMAL"; break;
533 case FF_LINESNGL: name = "LINESNGL"; break;
536 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
538 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
541 case FF_LINEMARK: /* start (or end) of a line */
542 linemark = t - SvPVX(PL_formtarget);
547 case FF_LITERAL: /* append <arg> literal chars */
552 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
555 case FF_SKIP: /* skip <arg> chars in format */
559 case FF_FETCH: /* get next item and set field size to <arg> */
568 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
571 SvTAINTED_on(PL_formtarget);
574 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
576 const char *s = item = SvPV_const(sv, len);
577 const char *send = s + len;
580 item_is_utf8 = DO_UTF8(sv);
592 if (itemsize == fieldsize)
595 itembytes = s - item;
600 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
602 const char *s = item = SvPV_const(sv, len);
603 const char *send = s + len;
607 item_is_utf8 = DO_UTF8(sv);
609 /* look for a legal split position */
617 /* provisional split point */
621 /* we delay testing fieldsize until after we've
622 * processed the possible split char directly
623 * following the last field char; so if fieldsize=3
624 * and item="a b cdef", we consume "a b", not "a".
625 * Ditto further down.
627 if (size == fieldsize)
631 if (strchr(PL_chopset, *s)) {
632 /* provisional split point */
633 /* for a non-space split char, we include
634 * the split char; hence the '+1' */
638 if (size == fieldsize)
650 if (!chophere || s == send) {
654 itembytes = chophere - item;
659 case FF_SPACE: /* append padding space (diff of field, item size) */
660 arg = fieldsize - itemsize;
668 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
669 arg = fieldsize - itemsize;
678 case FF_ITEM: /* append a text item, while blanking ctrl chars */
684 case FF_CHOP: /* (for ^*) chop the current item */
685 if (sv != &PL_sv_no) {
686 const char *s = chophere;
694 /* tied, overloaded or similar strangeness.
695 * Do it the hard way */
696 sv_setpvn(sv, s, len - (s-item));
701 case FF_LINESNGL: /* process ^* */
705 case FF_LINEGLOB: /* process @* */
707 const bool oneline = fpc[-1] == FF_LINESNGL;
708 const char *s = item = SvPV_const(sv, len);
709 const char *const send = s + len;
711 item_is_utf8 = DO_UTF8(sv);
722 to_copy = s - item - 1;
736 /* append to_copy bytes from source to PL_formstring.
737 * item_is_utf8 implies source is utf8.
738 * if trans, translate certain characters during the copy */
743 SvCUR_set(PL_formtarget,
744 t - SvPVX_const(PL_formtarget));
746 if (targ_is_utf8 && !item_is_utf8) {
747 source = tmp = bytes_to_utf8(source, &to_copy);
749 if (item_is_utf8 && !targ_is_utf8) {
751 /* Upgrade targ to UTF8, and then we reduce it to
752 a problem we have a simple solution for.
753 Don't need get magic. */
754 sv_utf8_upgrade_nomg(PL_formtarget);
756 /* re-calculate linemark */
757 s = (U8*)SvPVX(PL_formtarget);
758 /* the bytes we initially allocated to append the
759 * whole line may have been gobbled up during the
760 * upgrade, so allocate a whole new line's worth
765 linemark = s - (U8*)SvPVX(PL_formtarget);
767 /* Easy. They agree. */
768 assert (item_is_utf8 == targ_is_utf8);
771 /* @* and ^* are the only things that can exceed
772 * the linemax, so grow by the output size, plus
773 * a whole new form's worth in case of any further
775 grow = linemax + to_copy;
777 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
778 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
780 Copy(source, t, to_copy, char);
782 /* blank out ~ or control chars, depending on trans.
783 * works on bytes not chars, so relies on not
784 * matching utf8 continuation bytes */
786 U8 *send = s + to_copy;
789 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
796 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
802 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
805 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
808 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
811 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
813 /* If the field is marked with ^ and the value is undefined,
815 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
823 /* overflow evidence */
824 if (num_overflow(value, fieldsize, arg)) {
830 /* Formats aren't yet marked for locales, so assume "yes". */
832 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
834 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
835 STORE_LC_NUMERIC_SET_TO_NEEDED();
836 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
839 const char* qfmt = quadmath_format_single(fmt);
842 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
843 len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
845 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
850 /* we generate fmt ourselves so it is safe */
851 GCC_DIAG_IGNORE(-Wformat-nonliteral);
852 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
855 PERL_MY_SNPRINTF_POST_GUARD(len, max);
856 RESTORE_LC_NUMERIC();
861 case FF_NEWLINE: /* delete trailing spaces, then append \n */
863 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
868 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
871 if (arg) { /* repeat until fields exhausted? */
877 t = SvPVX(PL_formtarget) + linemark;
882 case FF_MORE: /* replace long end of string with '...' */
884 const char *s = chophere;
885 const char *send = item + len;
887 while (isSPACE(*s) && (s < send))
892 arg = fieldsize - itemsize;
899 if (strnEQ(s1," ",3)) {
900 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
910 case FF_END: /* tidy up, then return */
912 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
914 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
916 SvUTF8_on(PL_formtarget);
917 FmLINES(PL_formtarget) += lines;
919 if (fpc[-1] == FF_BLANK)
920 RETURNOP(cLISTOP->op_first);
932 if (PL_stack_base + TOPMARK == SP) {
934 if (GIMME_V == G_SCALAR)
936 RETURNOP(PL_op->op_next->op_next);
938 PL_stack_sp = PL_stack_base + TOPMARK + 1;
939 Perl_pp_pushmark(aTHX); /* push dst */
940 Perl_pp_pushmark(aTHX); /* push src */
941 ENTER_with_name("grep"); /* enter outer scope */
945 ENTER_with_name("grep_item"); /* enter inner scope */
948 src = PL_stack_base[TOPMARK];
950 src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
957 if (PL_op->op_type == OP_MAPSTART)
958 Perl_pp_pushmark(aTHX); /* push top */
959 return ((LOGOP*)PL_op->op_next)->op_other;
965 const I32 gimme = GIMME_V;
966 I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
972 /* first, move source pointer to the next item in the source list */
973 ++PL_markstack_ptr[-1];
975 /* if there are new items, push them into the destination list */
976 if (items && gimme != G_VOID) {
977 /* might need to make room back there first */
978 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
979 /* XXX this implementation is very pessimal because the stack
980 * is repeatedly extended for every set of items. Is possible
981 * to do this without any stack extension or copying at all
982 * by maintaining a separate list over which the map iterates
983 * (like foreach does). --gsar */
985 /* everything in the stack after the destination list moves
986 * towards the end the stack by the amount of room needed */
987 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
989 /* items to shift up (accounting for the moved source pointer) */
990 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
992 /* This optimization is by Ben Tilly and it does
993 * things differently from what Sarathy (gsar)
994 * is describing. The downside of this optimization is
995 * that leaves "holes" (uninitialized and hopefully unused areas)
996 * to the Perl stack, but on the other hand this
997 * shouldn't be a problem. If Sarathy's idea gets
998 * implemented, this optimization should become
999 * irrelevant. --jhi */
1001 shift = count; /* Avoid shifting too often --Ben Tilly */
1005 dst = (SP += shift);
1006 PL_markstack_ptr[-1] += shift;
1007 *PL_markstack_ptr += shift;
1011 /* copy the new items down to the destination list */
1012 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1013 if (gimme == G_ARRAY) {
1014 /* add returned items to the collection (making mortal copies
1015 * if necessary), then clear the current temps stack frame
1016 * *except* for those items. We do this splicing the items
1017 * into the start of the tmps frame (so some items may be on
1018 * the tmps stack twice), then moving PL_tmps_floor above
1019 * them, then freeing the frame. That way, the only tmps that
1020 * accumulate over iterations are the return values for map.
1021 * We have to do to this way so that everything gets correctly
1022 * freed if we die during the map.
1026 /* make space for the slice */
1027 EXTEND_MORTAL(items);
1028 tmpsbase = PL_tmps_floor + 1;
1029 Move(PL_tmps_stack + tmpsbase,
1030 PL_tmps_stack + tmpsbase + items,
1031 PL_tmps_ix - PL_tmps_floor,
1033 PL_tmps_ix += items;
1038 sv = sv_mortalcopy(sv);
1040 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1042 /* clear the stack frame except for the items */
1043 PL_tmps_floor += items;
1045 /* FREETMPS may have cleared the TEMP flag on some of the items */
1048 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1051 /* scalar context: we don't care about which values map returns
1052 * (we use undef here). And so we certainly don't want to do mortal
1053 * copies of meaningless values. */
1054 while (items-- > 0) {
1056 *dst-- = &PL_sv_undef;
1064 LEAVE_with_name("grep_item"); /* exit inner scope */
1067 if (PL_markstack_ptr[-1] > TOPMARK) {
1069 (void)POPMARK; /* pop top */
1070 LEAVE_with_name("grep"); /* exit outer scope */
1071 (void)POPMARK; /* pop src */
1072 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1073 (void)POPMARK; /* pop dst */
1074 SP = PL_stack_base + POPMARK; /* pop original mark */
1075 if (gimme == G_SCALAR) {
1079 else if (gimme == G_ARRAY)
1086 ENTER_with_name("grep_item"); /* enter inner scope */
1089 /* set $_ to the new source item */
1090 src = PL_stack_base[PL_markstack_ptr[-1]];
1091 if (SvPADTMP(src)) {
1092 src = sv_mortalcopy(src);
1097 RETURNOP(cLOGOP->op_other);
1105 if (GIMME_V == G_ARRAY)
1107 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1108 return cLOGOP->op_other;
1117 if (GIMME_V == G_ARRAY) {
1118 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1122 SV * const targ = PAD_SV(PL_op->op_targ);
1125 if (PL_op->op_private & OPpFLIP_LINENUM) {
1126 if (GvIO(PL_last_in_gv)) {
1127 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1130 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1132 flip = SvIV(sv) == SvIV(GvSV(gv));
1138 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1139 if (PL_op->op_flags & OPf_SPECIAL) {
1147 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1150 sv_setpvs(TARG, "");
1156 /* This code tries to decide if "$left .. $right" should use the
1157 magical string increment, or if the range is numeric (we make
1158 an exception for .."0" [#18165]). AMS 20021031. */
1160 #define RANGE_IS_NUMERIC(left,right) ( \
1161 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1162 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1163 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1164 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1165 && (!SvOK(right) || looks_like_number(right))))
1171 if (GIMME_V == G_ARRAY) {
1177 if (RANGE_IS_NUMERIC(left,right)) {
1179 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1180 (SvOK(right) && (SvIOK(right)
1181 ? SvIsUV(right) && SvUV(right) > IV_MAX
1182 : SvNV_nomg(right) > IV_MAX)))
1183 DIE(aTHX_ "Range iterator outside integer range");
1184 i = SvIV_nomg(left);
1185 j = SvIV_nomg(right);
1187 /* Dance carefully around signed max. */
1188 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1191 /* The wraparound of signed integers is undefined
1192 * behavior, but here we aim for count >=1, and
1193 * negative count is just wrong. */
1195 #if IVSIZE > Size_t_size
1202 Perl_croak(aTHX_ "Out of memory during list extend");
1209 SV * const sv = sv_2mortal(newSViv(i));
1211 if (n) /* avoid incrementing above IV_MAX */
1217 const char * const lpv = SvPV_nomg_const(left, llen);
1218 const char * const tmps = SvPV_nomg_const(right, len);
1220 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1221 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1223 if (strEQ(SvPVX_const(sv),tmps))
1225 sv = sv_2mortal(newSVsv(sv));
1232 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1236 if (PL_op->op_private & OPpFLIP_LINENUM) {
1237 if (GvIO(PL_last_in_gv)) {
1238 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1241 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1242 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1250 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1251 sv_catpvs(targ, "E0");
1261 static const char * const context_name[] = {
1263 NULL, /* CXt_WHEN never actually needs "block" */
1264 NULL, /* CXt_BLOCK never actually needs "block" */
1265 NULL, /* CXt_GIVEN never actually needs "block" */
1266 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1267 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1268 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1269 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1277 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1281 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1283 for (i = cxstack_ix; i >= 0; i--) {
1284 const PERL_CONTEXT * const cx = &cxstack[i];
1285 switch (CxTYPE(cx)) {
1291 /* diag_listed_as: Exiting subroutine via %s */
1292 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1293 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1294 if (CxTYPE(cx) == CXt_NULL)
1297 case CXt_LOOP_LAZYIV:
1298 case CXt_LOOP_LAZYSV:
1300 case CXt_LOOP_PLAIN:
1302 STRLEN cx_label_len = 0;
1303 U32 cx_label_flags = 0;
1304 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1306 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1309 (const U8*)cx_label, cx_label_len,
1310 (const U8*)label, len) == 0)
1312 (const U8*)label, len,
1313 (const U8*)cx_label, cx_label_len) == 0)
1314 : (len == cx_label_len && ((cx_label == label)
1315 || memEQ(cx_label, label, len))) )) {
1316 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1317 (long)i, cx_label));
1320 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1331 Perl_dowantarray(pTHX)
1333 const I32 gimme = block_gimme();
1334 return (gimme == G_VOID) ? G_SCALAR : gimme;
1338 Perl_block_gimme(pTHX)
1340 const I32 cxix = dopoptosub(cxstack_ix);
1345 gimme = (cxstack[cxix].blk_gimme & G_WANT);
1347 Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1353 Perl_is_lvalue_sub(pTHX)
1355 const I32 cxix = dopoptosub(cxstack_ix);
1356 assert(cxix >= 0); /* We should only be called from inside subs */
1358 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1359 return CxLVAL(cxstack + cxix);
1364 /* only used by PUSHSUB */
1366 Perl_was_lvalue_sub(pTHX)
1368 const I32 cxix = dopoptosub(cxstack_ix-1);
1369 assert(cxix >= 0); /* We should only be called from inside subs */
1371 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1372 return CxLVAL(cxstack + cxix);
1378 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1382 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1384 PERL_UNUSED_CONTEXT;
1387 for (i = startingblock; i >= 0; i--) {
1388 const PERL_CONTEXT * const cx = &cxstk[i];
1389 switch (CxTYPE(cx)) {
1393 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1394 * twice; the first for the normal foo() call, and the second
1395 * for a faked up re-entry into the sub to execute the
1396 * code block. Hide this faked entry from the world. */
1397 if (cx->cx_type & CXp_SUB_RE_FAKE)
1402 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1410 S_dopoptoeval(pTHX_ I32 startingblock)
1413 for (i = startingblock; i >= 0; i--) {
1414 const PERL_CONTEXT *cx = &cxstack[i];
1415 switch (CxTYPE(cx)) {
1419 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1427 S_dopoptoloop(pTHX_ I32 startingblock)
1430 for (i = startingblock; i >= 0; i--) {
1431 const PERL_CONTEXT * const cx = &cxstack[i];
1432 switch (CxTYPE(cx)) {
1438 /* diag_listed_as: Exiting subroutine via %s */
1439 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1440 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1441 if ((CxTYPE(cx)) == CXt_NULL)
1444 case CXt_LOOP_LAZYIV:
1445 case CXt_LOOP_LAZYSV:
1447 case CXt_LOOP_PLAIN:
1448 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1456 S_dopoptogiven(pTHX_ I32 startingblock)
1459 for (i = startingblock; i >= 0; i--) {
1460 const PERL_CONTEXT *cx = &cxstack[i];
1461 switch (CxTYPE(cx)) {
1465 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1467 case CXt_LOOP_PLAIN:
1468 assert(!CxFOREACHDEF(cx));
1470 case CXt_LOOP_LAZYIV:
1471 case CXt_LOOP_LAZYSV:
1473 if (CxFOREACHDEF(cx)) {
1474 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1483 S_dopoptowhen(pTHX_ I32 startingblock)
1486 for (i = startingblock; i >= 0; i--) {
1487 const PERL_CONTEXT *cx = &cxstack[i];
1488 switch (CxTYPE(cx)) {
1492 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1500 Perl_dounwind(pTHX_ I32 cxix)
1504 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1507 while (cxstack_ix > cxix) {
1509 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1510 DEBUG_CX("UNWIND"); \
1511 /* Note: we don't need to restore the base context info till the end. */
1512 switch (CxTYPE(cx)) {
1515 continue; /* not break */
1523 case CXt_LOOP_LAZYIV:
1524 case CXt_LOOP_LAZYSV:
1526 case CXt_LOOP_PLAIN:
1537 PERL_UNUSED_VAR(optype);
1541 Perl_qerror(pTHX_ SV *err)
1543 PERL_ARGS_ASSERT_QERROR;
1546 if (PL_in_eval & EVAL_KEEPERR) {
1547 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1551 sv_catsv(ERRSV, err);
1554 sv_catsv(PL_errors, err);
1556 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1558 ++PL_parser->error_count;
1562 Perl_die_unwind(pTHX_ SV *msv)
1564 SV *exceptsv = sv_mortalcopy(msv);
1565 U8 in_eval = PL_in_eval;
1566 PERL_ARGS_ASSERT_DIE_UNWIND;
1573 * Historically, perl used to set ERRSV ($@) early in the die
1574 * process and rely on it not getting clobbered during unwinding.
1575 * That sucked, because it was liable to get clobbered, so the
1576 * setting of ERRSV used to emit the exception from eval{} has
1577 * been moved to much later, after unwinding (see just before
1578 * JMPENV_JUMP below). However, some modules were relying on the
1579 * early setting, by examining $@ during unwinding to use it as
1580 * a flag indicating whether the current unwinding was caused by
1581 * an exception. It was never a reliable flag for that purpose,
1582 * being totally open to false positives even without actual
1583 * clobberage, but was useful enough for production code to
1584 * semantically rely on it.
1586 * We'd like to have a proper introspective interface that
1587 * explicitly describes the reason for whatever unwinding
1588 * operations are currently in progress, so that those modules
1589 * work reliably and $@ isn't further overloaded. But we don't
1590 * have one yet. In its absence, as a stopgap measure, ERRSV is
1591 * now *additionally* set here, before unwinding, to serve as the
1592 * (unreliable) flag that it used to.
1594 * This behaviour is temporary, and should be removed when a
1595 * proper way to detect exceptional unwinding has been developed.
1596 * As of 2010-12, the authors of modules relying on the hack
1597 * are aware of the issue, because the modules failed on
1598 * perls 5.13.{1..7} which had late setting of $@ without this
1599 * early-setting hack.
1601 if (!(in_eval & EVAL_KEEPERR)) {
1602 SvTEMP_off(exceptsv);
1603 sv_setsv(ERRSV, exceptsv);
1606 if (in_eval & EVAL_KEEPERR) {
1607 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1611 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1612 && PL_curstackinfo->si_prev)
1626 JMPENV *restartjmpenv;
1629 if (cxix < cxstack_ix)
1632 POPBLOCK(cx,PL_curpm);
1633 if (CxTYPE(cx) != CXt_EVAL) {
1635 const char* message = SvPVx_const(exceptsv, msglen);
1636 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1637 PerlIO_write(Perl_error_log, message, msglen);
1641 namesv = cx->blk_eval.old_namesv;
1643 oldcop = cx->blk_oldcop;
1645 restartjmpenv = cx->blk_eval.cur_top_env;
1646 restartop = cx->blk_eval.retop;
1648 if (gimme == G_SCALAR)
1649 *++newsp = &PL_sv_undef;
1650 PL_stack_sp = newsp;
1654 if (optype == OP_REQUIRE) {
1655 assert (PL_curcop == oldcop);
1656 (void)hv_store(GvHVn(PL_incgv),
1657 SvPVX_const(namesv),
1658 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1660 /* note that unlike pp_entereval, pp_require isn't
1661 * supposed to trap errors. So now that we've popped the
1662 * EVAL that pp_require pushed, and processed the error
1663 * message, rethrow the error */
1664 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1665 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1668 if (!(in_eval & EVAL_KEEPERR))
1669 sv_setsv(ERRSV, exceptsv);
1670 PL_restartjmpenv = restartjmpenv;
1671 PL_restartop = restartop;
1673 NOT_REACHED; /* NOTREACHED */
1677 write_to_stderr(exceptsv);
1679 NOT_REACHED; /* NOTREACHED */
1685 if (SvTRUE(left) != SvTRUE(right))
1693 =head1 CV Manipulation Functions
1695 =for apidoc caller_cx
1697 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1698 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1699 information returned to Perl by C<caller>. Note that XSUBs don't get a
1700 stack frame, so C<caller_cx(0, NULL)> will return information for the
1701 immediately-surrounding Perl code.
1703 This function skips over the automatic calls to C<&DB::sub> made on the
1704 behalf of the debugger. If the stack frame requested was a sub called by
1705 C<DB::sub>, the return value will be the frame for the call to
1706 C<DB::sub>, since that has the correct line number/etc. for the call
1707 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1708 frame for the sub call itself.
1713 const PERL_CONTEXT *
1714 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1716 I32 cxix = dopoptosub(cxstack_ix);
1717 const PERL_CONTEXT *cx;
1718 const PERL_CONTEXT *ccstack = cxstack;
1719 const PERL_SI *top_si = PL_curstackinfo;
1722 /* we may be in a higher stacklevel, so dig down deeper */
1723 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1724 top_si = top_si->si_prev;
1725 ccstack = top_si->si_cxstack;
1726 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1730 /* caller() should not report the automatic calls to &DB::sub */
1731 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1732 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1736 cxix = dopoptosub_at(ccstack, cxix - 1);
1739 cx = &ccstack[cxix];
1740 if (dbcxp) *dbcxp = cx;
1742 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1743 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1744 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1745 field below is defined for any cx. */
1746 /* caller() should not report the automatic calls to &DB::sub */
1747 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1748 cx = &ccstack[dbcxix];
1757 const PERL_CONTEXT *cx;
1758 const PERL_CONTEXT *dbcx;
1759 I32 gimme = GIMME_V;
1760 const HEK *stash_hek;
1762 bool has_arg = MAXARG && TOPs;
1771 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1773 if (gimme != G_ARRAY) {
1781 assert(CopSTASH(cx->blk_oldcop));
1782 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1783 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1785 if (gimme != G_ARRAY) {
1788 PUSHs(&PL_sv_undef);
1791 sv_sethek(TARG, stash_hek);
1800 PUSHs(&PL_sv_undef);
1803 sv_sethek(TARG, stash_hek);
1806 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1807 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1808 cx->blk_sub.retop, TRUE);
1810 lcop = cx->blk_oldcop;
1811 mPUSHi((I32)CopLINE(lcop));
1814 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1815 /* So is ccstack[dbcxix]. */
1816 if (CvHASGV(dbcx->blk_sub.cv)) {
1817 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1818 PUSHs(boolSV(CxHASARGS(cx)));
1821 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1822 PUSHs(boolSV(CxHASARGS(cx)));
1826 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1829 gimme = (I32)cx->blk_gimme;
1830 if (gimme == G_VOID)
1831 PUSHs(&PL_sv_undef);
1833 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1834 if (CxTYPE(cx) == CXt_EVAL) {
1836 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1837 SV *cur_text = cx->blk_eval.cur_text;
1838 if (SvCUR(cur_text) >= 2) {
1839 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1840 SvUTF8(cur_text)|SVs_TEMP));
1843 /* I think this is will always be "", but be sure */
1844 PUSHs(sv_2mortal(newSVsv(cur_text)));
1850 else if (cx->blk_eval.old_namesv) {
1851 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1854 /* eval BLOCK (try blocks have old_namesv == 0) */
1856 PUSHs(&PL_sv_undef);
1857 PUSHs(&PL_sv_undef);
1861 PUSHs(&PL_sv_undef);
1862 PUSHs(&PL_sv_undef);
1864 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1865 && CopSTASH_eq(PL_curcop, PL_debstash))
1867 AV * const ary = cx->blk_sub.argarray;
1868 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1870 Perl_init_dbargs(aTHX);
1872 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1873 av_extend(PL_dbargs, AvFILLp(ary) + off);
1874 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1875 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1877 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1880 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1882 if (old_warnings == pWARN_NONE)
1883 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1884 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1885 mask = &PL_sv_undef ;
1886 else if (old_warnings == pWARN_ALL ||
1887 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1888 /* Get the bit mask for $warnings::Bits{all}, because
1889 * it could have been extended by warnings::register */
1891 HV * const bits = get_hv("warnings::Bits", 0);
1892 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1893 mask = newSVsv(*bits_all);
1896 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1900 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1904 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1905 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1915 if (MAXARG < 1 || (!TOPs && !POPs))
1916 tmps = NULL, len = 0;
1918 tmps = SvPVx_const(POPs, len);
1919 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1924 /* like pp_nextstate, but used instead when the debugger is active */
1928 PL_curcop = (COP*)PL_op;
1929 TAINT_NOT; /* Each statement is presumed innocent */
1930 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1935 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1936 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
1940 const I32 gimme = G_ARRAY;
1942 GV * const gv = PL_DBgv;
1945 if (gv && isGV_with_GP(gv))
1948 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1949 DIE(aTHX_ "No DB::DB routine defined");
1951 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1952 /* don't do recursive DB::DB call */
1966 (void)(*CvXSUB(cv))(aTHX_ cv);
1972 PUSHBLOCK(cx, CXt_SUB, SP);
1974 cx->blk_sub.retop = PL_op->op_next;
1976 if (CvDEPTH(cv) >= 2) {
1977 PERL_STACK_OVERFLOW_CHECK();
1978 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1981 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1982 RETURNOP(CvSTART(cv));
1989 /* S_leave_common: Common code that many functions in this file use on
1992 /* SVs on the stack that have any of the flags passed in are left as is.
1993 Other SVs are protected via the mortals stack if lvalue is true, and
1996 Also, taintedness is cleared.
2000 S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
2001 U32 flags, bool lvalue)
2004 PERL_ARGS_ASSERT_LEAVE_COMMON;
2007 if (flags & SVs_PADTMP) {
2008 flags &= ~SVs_PADTMP;
2011 if (gimme == G_SCALAR) {
2013 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2016 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2017 : sv_mortalcopy(*SP);
2019 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2022 *++MARK = &PL_sv_undef;
2026 else if (gimme == G_ARRAY) {
2027 /* in case LEAVE wipes old return values */
2028 while (++MARK <= SP) {
2029 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2033 ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
2034 : sv_mortalcopy(*MARK);
2035 TAINT_NOT; /* Each item is independent */
2038 /* When this function was called with MARK == newsp, we reach this
2039 * point with SP == newsp. */
2049 I32 gimme = GIMME_V;
2051 ENTER_with_name("block");
2054 PUSHBLOCK(cx, CXt_BLOCK, SP);
2067 if (PL_op->op_flags & OPf_SPECIAL) {
2068 cx = &cxstack[cxstack_ix];
2069 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2074 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2076 SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
2077 PL_op->op_private & OPpLVALUE);
2078 PL_curpm = newpm; /* Don't pop $1 et al till now */
2080 LEAVE_with_name("block");
2086 S_outside_integer(pTHX_ SV *sv)
2089 const NV nv = SvNV_nomg(sv);
2090 if (Perl_isinfnan(nv))
2092 #ifdef NV_PRESERVES_UV
2093 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2096 if (nv <= (NV)IV_MIN)
2099 ((nv > (NV)UV_MAX ||
2100 SvUV_nomg(sv) > (UV)IV_MAX)))
2111 const I32 gimme = GIMME_V;
2112 void *itervar; /* location of the iteration variable */
2113 U8 cxtype = CXt_LOOP_FOR;
2115 ENTER_with_name("loop1");
2118 if (PL_op->op_targ) { /* "my" variable */
2119 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2120 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2121 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2122 SVs_PADSTALE, SVs_PADSTALE);
2124 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2126 itervar = PL_comppad;
2128 itervar = &PAD_SVl(PL_op->op_targ);
2131 else if (LIKELY(isGV(TOPs))) { /* symbol table variable */
2132 GV * const gv = MUTABLE_GV(POPs);
2133 SV** svp = &GvSV(gv);
2134 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2136 itervar = (void *)gv;
2139 SV * const sv = POPs;
2140 assert(SvTYPE(sv) == SVt_PVMG);
2141 assert(SvMAGIC(sv));
2142 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2143 itervar = (void *)sv;
2144 cxtype |= CXp_FOR_LVREF;
2147 if (PL_op->op_private & OPpITER_DEF)
2148 cxtype |= CXp_FOR_DEF;
2150 ENTER_with_name("loop2");
2152 PUSHBLOCK(cx, cxtype, SP);
2153 PUSHLOOP_FOR(cx, itervar, MARK);
2154 if (PL_op->op_flags & OPf_STACKED) {
2155 SV *maybe_ary = POPs;
2156 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2158 SV * const right = maybe_ary;
2159 if (UNLIKELY(cxtype & CXp_FOR_LVREF))
2160 DIE(aTHX_ "Assigned value is not a reference");
2163 if (RANGE_IS_NUMERIC(sv,right)) {
2164 cx->cx_type &= ~CXTYPEMASK;
2165 cx->cx_type |= CXt_LOOP_LAZYIV;
2166 /* Make sure that no-one re-orders cop.h and breaks our
2168 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2169 if (S_outside_integer(aTHX_ sv) ||
2170 S_outside_integer(aTHX_ right))
2171 DIE(aTHX_ "Range iterator outside integer range");
2172 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2173 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2175 /* for correct -Dstv display */
2176 cx->blk_oldsp = sp - PL_stack_base;
2180 cx->cx_type &= ~CXTYPEMASK;
2181 cx->cx_type |= CXt_LOOP_LAZYSV;
2182 /* Make sure that no-one re-orders cop.h and breaks our
2184 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2185 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2186 cx->blk_loop.state_u.lazysv.end = right;
2187 SvREFCNT_inc(right);
2188 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2189 /* This will do the upgrade to SVt_PV, and warn if the value
2190 is uninitialised. */
2191 (void) SvPV_nolen_const(right);
2192 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2193 to replace !SvOK() with a pointer to "". */
2195 SvREFCNT_dec(right);
2196 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2200 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2201 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2202 SvREFCNT_inc(maybe_ary);
2203 cx->blk_loop.state_u.ary.ix =
2204 (PL_op->op_private & OPpITER_REVERSED) ?
2205 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2209 else { /* iterating over items on the stack */
2210 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2211 if (PL_op->op_private & OPpITER_REVERSED) {
2212 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2215 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2226 const I32 gimme = GIMME_V;
2228 ENTER_with_name("loop1");
2230 ENTER_with_name("loop2");
2232 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2233 PUSHLOOP_PLAIN(cx, SP);
2248 assert(CxTYPE_is_LOOP(cx));
2250 newsp = PL_stack_base + cx->blk_loop.resetsp;
2252 SP = leave_common(newsp, SP, MARK, gimme, 0,
2253 PL_op->op_private & OPpLVALUE);
2256 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2257 PL_curpm = newpm; /* ... and pop $1 et al */
2259 LEAVE_with_name("loop2");
2260 LEAVE_with_name("loop1");
2266 /* This duplicates most of pp_leavesub, but with additional code to handle
2267 * return args in lvalue context. It was forked from pp_leavesub to
2268 * avoid slowing down that function any further.
2270 * Any changes made to this function may need to be copied to pp_leavesub
2284 const char *what = NULL;
2286 if (CxMULTICALL(&cxstack[cxstack_ix])) {
2287 /* entry zero of a stack is always PL_sv_undef, which
2288 * simplifies converting a '()' return into undef in scalar context */
2289 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2294 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2299 ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2300 if (gimme == G_SCALAR) {
2301 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2305 if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
2306 !SvSMAGICAL(TOPs)) {
2308 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2309 : "a readonly value" : "a temporary";
2314 /* sub:lvalue{} will take us here. */
2324 "Can't return %s from lvalue subroutine", what
2329 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2330 if (!SvPADTMP(*SP)) {
2331 *MARK = SvREFCNT_inc(*SP);
2336 /* FREETMPS could clobber it */
2337 SV *sv = SvREFCNT_inc(*SP);
2339 *MARK = sv_mortalcopy(sv);
2346 ? sv_mortalcopy(*SP)
2348 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2353 *MARK = &PL_sv_undef;
2357 if (CxLVAL(cx) & OPpDEREF) {
2360 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2364 else if (gimme == G_ARRAY) {
2365 assert (!(CxLVAL(cx) & OPpDEREF));
2366 if (ref || !CxLVAL(cx))
2367 for (; MARK <= SP; MARK++)
2369 SvFLAGS(*MARK) & SVs_PADTMP
2370 ? sv_mortalcopy(*MARK)
2373 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2374 else for (; MARK <= SP; MARK++) {
2375 if (*MARK != &PL_sv_undef
2376 && (SvPADTMP(*MARK) || SvREADONLY(*MARK))
2378 /* Might be flattened array after $#array = */
2379 what = SvREADONLY(*MARK)
2380 ? "a readonly value" : "a temporary";
2383 else if (!SvTEMP(*MARK))
2384 *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2390 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2392 PL_curpm = newpm; /* ... and pop $1 et al */
2395 return cx->blk_sub.retop;
2404 const I32 cxix = dopoptosub(cxstack_ix);
2406 assert(cxstack_ix >= 0);
2407 if (cxix < cxstack_ix) {
2409 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2410 * sort block, which is a CXt_NULL
2413 /* if we were in list context, we would have to splice out
2414 * any junk before the return args, like we do in the general
2415 * pp_return case, e.g.
2416 * sub f { for (junk1, junk2) { return arg1, arg2 }}
2418 assert(cxstack[0].blk_gimme == G_SCALAR);
2422 DIE(aTHX_ "Can't return outside a subroutine");
2427 cx = &cxstack[cxix];
2429 oldsp = PL_stack_base + cx->blk_oldsp;
2430 if (oldsp != MARK) {
2431 /* Handle extra junk on the stack. For example,
2432 * for (1,2) { return 3,4 }
2433 * leaves 1,2,3,4 on the stack. In list context we
2434 * have to splice out the 1,2; In scalar context for
2435 * for (1,2) { return }
2436 * we need to set sp = oldsp so that pp_leavesub knows
2437 * to push &PL_sv_undef onto the stack.
2438 * Note that in pp_return we only do the extra processing
2439 * required to handle junk; everything else we leave to
2442 SSize_t nargs = SP - MARK;
2444 if (cx->blk_gimme == G_ARRAY) {
2445 /* shift return args to base of call stack frame */
2446 Move(MARK + 1, oldsp + 1, nargs, SV*);
2447 PL_stack_sp = oldsp + nargs;
2451 PL_stack_sp = oldsp;
2454 /* fall through to a normal exit */
2455 switch (CxTYPE(cx)) {
2457 return CxTRYBLOCK(cx)
2458 ? Perl_pp_leavetry(aTHX)
2459 : Perl_pp_leaveeval(aTHX);
2461 return CvLVALUE(cx->blk_sub.cv)
2462 ? Perl_pp_leavesublv(aTHX)
2463 : Perl_pp_leavesub(aTHX);
2465 return Perl_pp_leavewrite(aTHX);
2467 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2473 S_unwind_loop(pTHX_ const char * const opname)
2476 if (PL_op->op_flags & OPf_SPECIAL) {
2477 cxix = dopoptoloop(cxstack_ix);
2479 /* diag_listed_as: Can't "last" outside a loop block */
2480 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2485 const char * const label =
2486 PL_op->op_flags & OPf_STACKED
2487 ? SvPV(TOPs,label_len)
2488 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2489 const U32 label_flags =
2490 PL_op->op_flags & OPf_STACKED
2492 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2494 cxix = dopoptolabel(label, label_len, label_flags);
2496 /* diag_listed_as: Label not found for "last %s" */
2497 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2499 SVfARG(PL_op->op_flags & OPf_STACKED
2500 && !SvGMAGICAL(TOPp1s)
2502 : newSVpvn_flags(label,
2504 label_flags | SVs_TEMP)));
2506 if (cxix < cxstack_ix)
2519 S_unwind_loop(aTHX_ "last");
2522 cxstack_ix++; /* temporarily protect top context */
2524 CxTYPE(cx) == CXt_LOOP_LAZYIV
2525 || CxTYPE(cx) == CXt_LOOP_LAZYSV
2526 || CxTYPE(cx) == CXt_LOOP_FOR
2527 || CxTYPE(cx) == CXt_LOOP_PLAIN
2529 newsp = PL_stack_base + cx->blk_loop.resetsp;
2530 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2533 PL_stack_sp = newsp;
2537 /* Stack values are safe: */
2538 POPLOOP(cx); /* release loop vars ... */
2540 PL_curpm = newpm; /* ... and pop $1 et al */
2542 PERL_UNUSED_VAR(gimme);
2549 const I32 inner = PL_scopestack_ix;
2551 S_unwind_loop(aTHX_ "next");
2553 /* clear off anything above the scope we're re-entering, but
2554 * save the rest until after a possible continue block */
2556 if (PL_scopestack_ix < inner)
2557 leave_scope(PL_scopestack[PL_scopestack_ix]);
2558 PL_curcop = cx->blk_oldcop;
2560 return (cx)->blk_loop.my_op->op_nextop;
2565 const I32 cxix = S_unwind_loop(aTHX_ "redo");
2568 OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2570 if (redo_op->op_type == OP_ENTER) {
2571 /* pop one less context to avoid $x being freed in while (my $x..) */
2573 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2574 redo_op = redo_op->op_next;
2578 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2579 LEAVE_SCOPE(oldsave);
2581 PL_curcop = cx->blk_oldcop;
2587 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2590 static const char* const too_deep = "Target of goto is too deeply nested";
2592 PERL_ARGS_ASSERT_DOFINDLABEL;
2595 Perl_croak(aTHX_ "%s", too_deep);
2596 if (o->op_type == OP_LEAVE ||
2597 o->op_type == OP_SCOPE ||
2598 o->op_type == OP_LEAVELOOP ||
2599 o->op_type == OP_LEAVESUB ||
2600 o->op_type == OP_LEAVETRY)
2602 *ops++ = cUNOPo->op_first;
2604 Perl_croak(aTHX_ "%s", too_deep);
2607 if (o->op_flags & OPf_KIDS) {
2609 /* First try all the kids at this level, since that's likeliest. */
2610 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2611 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2612 STRLEN kid_label_len;
2613 U32 kid_label_flags;
2614 const char *kid_label = CopLABEL_len_flags(kCOP,
2615 &kid_label_len, &kid_label_flags);
2617 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2620 (const U8*)kid_label, kid_label_len,
2621 (const U8*)label, len) == 0)
2623 (const U8*)label, len,
2624 (const U8*)kid_label, kid_label_len) == 0)
2625 : ( len == kid_label_len && ((kid_label == label)
2626 || memEQ(kid_label, label, len)))))
2630 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2631 if (kid == PL_lastgotoprobe)
2633 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2636 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2637 ops[-1]->op_type == OP_DBSTATE)
2642 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2651 /* also used for: pp_dump() */
2659 #define GOTO_DEPTH 64
2660 OP *enterops[GOTO_DEPTH];
2661 const char *label = NULL;
2662 STRLEN label_len = 0;
2663 U32 label_flags = 0;
2664 const bool do_dump = (PL_op->op_type == OP_DUMP);
2665 static const char* const must_have_label = "goto must have label";
2667 if (PL_op->op_flags & OPf_STACKED) {
2668 /* goto EXPR or goto &foo */
2670 SV * const sv = POPs;
2673 /* This egregious kludge implements goto &subroutine */
2674 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2677 CV *cv = MUTABLE_CV(SvRV(sv));
2678 AV *arg = GvAV(PL_defgv);
2682 if (!CvROOT(cv) && !CvXSUB(cv)) {
2683 const GV * const gv = CvGV(cv);
2687 /* autoloaded stub? */
2688 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2690 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2692 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2693 if (autogv && (cv = GvCV(autogv)))
2695 tmpstr = sv_newmortal();
2696 gv_efullname3(tmpstr, gv, NULL);
2697 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2699 DIE(aTHX_ "Goto undefined subroutine");
2702 /* First do some returnish stuff. */
2703 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2705 cxix = dopoptosub(cxstack_ix);
2706 if (cxix < cxstack_ix) {
2709 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2715 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2716 if (CxTYPE(cx) == CXt_EVAL) {
2719 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2720 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2722 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2723 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2725 else if (CxMULTICALL(cx))
2728 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2730 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2731 AV* av = cx->blk_sub.argarray;
2733 /* abandon the original @_ if it got reified or if it is
2734 the same as the current @_ */
2735 if (AvREAL(av) || av == arg) {
2739 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2741 else CLEAR_ARGARRAY(av);
2743 /* We donate this refcount later to the callee’s pad. */
2744 SvREFCNT_inc_simple_void(arg);
2745 if (CxTYPE(cx) == CXt_SUB &&
2746 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2747 SvREFCNT_dec(cx->blk_sub.cv);
2748 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2749 LEAVE_SCOPE(oldsave);
2751 /* A destructor called during LEAVE_SCOPE could have undefined
2752 * our precious cv. See bug #99850. */
2753 if (!CvROOT(cv) && !CvXSUB(cv)) {
2754 const GV * const gv = CvGV(cv);
2757 SV * const tmpstr = sv_newmortal();
2758 gv_efullname3(tmpstr, gv, NULL);
2759 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2762 DIE(aTHX_ "Goto undefined subroutine");
2765 /* Now do some callish stuff. */
2767 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2771 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2772 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2775 PERL_UNUSED_VAR(newsp);
2776 PERL_UNUSED_VAR(gimme);
2778 /* put GvAV(defgv) back onto stack */
2780 EXTEND(SP, items+1); /* @_ could have been extended. */
2785 bool r = cBOOL(AvREAL(arg));
2786 for (index=0; index<items; index++)
2790 SV ** const svp = av_fetch(arg, index, 0);
2791 sv = svp ? *svp : NULL;
2793 else sv = AvARRAY(arg)[index];
2795 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2796 : sv_2mortal(newSVavdefelem(arg, index, 1));
2801 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2802 /* Restore old @_ */
2803 arg = GvAV(PL_defgv);
2804 GvAV(PL_defgv) = cx->blk_sub.savearray;
2808 retop = cx->blk_sub.retop;
2809 /* XS subs don't have a CxSUB, so pop it */
2810 POPBLOCK(cx, PL_curpm);
2811 /* Push a mark for the start of arglist */
2814 (void)(*CvXSUB(cv))(aTHX_ cv);
2819 PADLIST * const padlist = CvPADLIST(cv);
2820 cx->blk_sub.cv = cv;
2821 cx->blk_sub.olddepth = CvDEPTH(cv);
2824 if (CvDEPTH(cv) < 2)
2825 SvREFCNT_inc_simple_void_NN(cv);
2827 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2828 sub_crush_depth(cv);
2829 pad_push(padlist, CvDEPTH(cv));
2831 PL_curcop = cx->blk_oldcop;
2833 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2836 CX_CURPAD_SAVE(cx->blk_sub);
2838 /* cx->blk_sub.argarray has no reference count, so we
2839 need something to hang on to our argument array so
2840 that cx->blk_sub.argarray does not end up pointing
2841 to freed memory as the result of undef *_. So put
2842 it in the callee’s pad, donating our refer-
2845 SvREFCNT_dec(PAD_SVl(0));
2846 PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2849 /* GvAV(PL_defgv) might have been modified on scope
2850 exit, so restore it. */
2851 if (arg != GvAV(PL_defgv)) {
2852 AV * const av = GvAV(PL_defgv);
2853 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2857 else SvREFCNT_dec(arg);
2858 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2859 Perl_get_db_sub(aTHX_ NULL, cv);
2861 CV * const gotocv = get_cvs("DB::goto", 0);
2863 PUSHMARK( PL_stack_sp );
2864 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2869 retop = CvSTART(cv);
2870 goto putback_return;
2875 label = SvPV_nomg_const(sv, label_len);
2876 label_flags = SvUTF8(sv);
2879 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2880 /* goto LABEL or dump LABEL */
2881 label = cPVOP->op_pv;
2882 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2883 label_len = strlen(label);
2885 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2890 OP *gotoprobe = NULL;
2891 bool leaving_eval = FALSE;
2892 bool in_block = FALSE;
2893 PERL_CONTEXT *last_eval_cx = NULL;
2897 PL_lastgotoprobe = NULL;
2899 for (ix = cxstack_ix; ix >= 0; ix--) {
2901 switch (CxTYPE(cx)) {
2903 leaving_eval = TRUE;
2904 if (!CxTRYBLOCK(cx)) {
2905 gotoprobe = (last_eval_cx ?
2906 last_eval_cx->blk_eval.old_eval_root :
2911 /* else fall through */
2912 case CXt_LOOP_LAZYIV:
2913 case CXt_LOOP_LAZYSV:
2915 case CXt_LOOP_PLAIN:
2918 gotoprobe = OpSIBLING(cx->blk_oldcop);
2924 gotoprobe = OpSIBLING(cx->blk_oldcop);
2927 gotoprobe = PL_main_root;
2930 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2931 gotoprobe = CvROOT(cx->blk_sub.cv);
2937 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2940 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
2941 CxTYPE(cx), (long) ix);
2942 gotoprobe = PL_main_root;
2948 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
2949 enterops, enterops + GOTO_DEPTH);
2952 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
2953 sibl1->op_type == OP_UNSTACK &&
2954 (sibl2 = OpSIBLING(sibl1)))
2956 retop = dofindlabel(sibl2,
2957 label, label_len, label_flags, enterops,
2958 enterops + GOTO_DEPTH);
2963 PL_lastgotoprobe = gotoprobe;
2966 DIE(aTHX_ "Can't find label %"UTF8f,
2967 UTF8fARG(label_flags, label_len, label));
2969 /* if we're leaving an eval, check before we pop any frames
2970 that we're not going to punt, otherwise the error
2973 if (leaving_eval && *enterops && enterops[1]) {
2975 for (i = 1; enterops[i]; i++)
2976 if (enterops[i]->op_type == OP_ENTERITER)
2977 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2980 if (*enterops && enterops[1]) {
2981 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2983 deprecate("\"goto\" to jump into a construct");
2986 /* pop unwanted frames */
2988 if (ix < cxstack_ix) {
2992 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
2995 oldsave = PL_scopestack[PL_scopestack_ix];
2996 LEAVE_SCOPE(oldsave);
2999 /* push wanted frames */
3001 if (*enterops && enterops[1]) {
3002 OP * const oldop = PL_op;
3003 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3004 for (; enterops[ix]; ix++) {
3005 PL_op = enterops[ix];
3006 /* Eventually we may want to stack the needed arguments
3007 * for each op. For now, we punt on the hard ones. */
3008 if (PL_op->op_type == OP_ENTERITER)
3009 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3010 PL_op->op_ppaddr(aTHX);
3018 if (!retop) retop = PL_main_start;
3020 PL_restartop = retop;
3021 PL_do_undump = TRUE;
3025 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3026 PL_do_undump = FALSE;
3044 anum = 0; (void)POPs;
3050 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3053 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3056 PL_exit_flags |= PERL_EXIT_EXPECTED;
3058 PUSHs(&PL_sv_undef);
3065 S_save_lines(pTHX_ AV *array, SV *sv)
3067 const char *s = SvPVX_const(sv);
3068 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3071 PERL_ARGS_ASSERT_SAVE_LINES;
3073 while (s && s < send) {
3075 SV * const tmpstr = newSV_type(SVt_PVMG);
3077 t = (const char *)memchr(s, '\n', send - s);
3083 sv_setpvn(tmpstr, s, t - s);
3084 av_store(array, line++, tmpstr);
3092 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3094 0 is used as continue inside eval,
3096 3 is used for a die caught by an inner eval - continue inner loop
3098 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3099 establish a local jmpenv to handle exception traps.
3104 S_docatch(pTHX_ OP *o)
3107 OP * const oldop = PL_op;
3111 assert(CATCH_GET == TRUE);
3118 assert(cxstack_ix >= 0);
3119 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3120 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3125 /* die caught by an inner eval - continue inner loop */
3126 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3127 PL_restartjmpenv = NULL;
3128 PL_op = PL_restartop;
3137 NOT_REACHED; /* NOTREACHED */
3146 =for apidoc find_runcv
3148 Locate the CV corresponding to the currently executing sub or eval.
3149 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3150 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3151 entered. (This allows debuggers to eval in the scope of the breakpoint
3152 rather than in the scope of the debugger itself.)
3158 Perl_find_runcv(pTHX_ U32 *db_seqp)
3160 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3163 /* If this becomes part of the API, it might need a better name. */
3165 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3172 PL_curcop == &PL_compiling
3174 : PL_curcop->cop_seq;
3176 for (si = PL_curstackinfo; si; si = si->si_prev) {
3178 for (ix = si->si_cxix; ix >= 0; ix--) {
3179 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3181 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3182 cv = cx->blk_sub.cv;
3183 /* skip DB:: code */
3184 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3185 *db_seqp = cx->blk_oldcop->cop_seq;
3188 if (cx->cx_type & CXp_SUB_RE)
3191 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3192 cv = cx->blk_eval.cv;
3195 case FIND_RUNCV_padid_eq:
3197 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3200 case FIND_RUNCV_level_eq:
3201 if (level++ != arg) continue;
3209 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3213 /* Run yyparse() in a setjmp wrapper. Returns:
3214 * 0: yyparse() successful
3215 * 1: yyparse() failed
3219 S_try_yyparse(pTHX_ int gramtype)
3224 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3228 ret = yyparse(gramtype) ? 1 : 0;
3235 NOT_REACHED; /* NOTREACHED */
3242 /* Compile a require/do or an eval ''.
3244 * outside is the lexically enclosing CV (if any) that invoked us.
3245 * seq is the current COP scope value.
3246 * hh is the saved hints hash, if any.
3248 * Returns a bool indicating whether the compile was successful; if so,
3249 * PL_eval_start contains the first op of the compiled code; otherwise,
3252 * This function is called from two places: pp_require and pp_entereval.
3253 * These can be distinguished by whether PL_op is entereval.
3257 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3260 OP * const saveop = PL_op;
3261 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3262 COP * const oldcurcop = PL_curcop;
3263 bool in_require = (saveop->op_type == OP_REQUIRE);
3267 PL_in_eval = (in_require
3268 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3270 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3271 ? EVAL_RE_REPARSING : 0)));
3275 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3277 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3278 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3279 cxstack[cxstack_ix].blk_gimme = gimme;
3281 CvOUTSIDE_SEQ(evalcv) = seq;
3282 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3284 /* set up a scratch pad */
3286 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3287 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3290 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3292 /* make sure we compile in the right package */
3294 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3295 SAVEGENERICSV(PL_curstash);
3296 PL_curstash = (HV *)CopSTASH(PL_curcop);
3297 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3298 else SvREFCNT_inc_simple_void(PL_curstash);
3300 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3301 SAVESPTR(PL_beginav);
3302 PL_beginav = newAV();
3303 SAVEFREESV(PL_beginav);
3304 SAVESPTR(PL_unitcheckav);
3305 PL_unitcheckav = newAV();
3306 SAVEFREESV(PL_unitcheckav);
3309 ENTER_with_name("evalcomp");
3310 SAVESPTR(PL_compcv);
3313 /* try to compile it */
3315 PL_eval_root = NULL;
3316 PL_curcop = &PL_compiling;
3317 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3318 PL_in_eval |= EVAL_KEEPERR;
3325 hv_clear(GvHV(PL_hintgv));
3328 PL_hints = saveop->op_private & OPpEVAL_COPHH
3329 ? oldcurcop->cop_hints : saveop->op_targ;
3331 /* making 'use re eval' not be in scope when compiling the
3332 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3333 * infinite recursion when S_has_runtime_code() gives a false
3334 * positive: the second time round, HINT_RE_EVAL isn't set so we
3335 * don't bother calling S_has_runtime_code() */
3336 if (PL_in_eval & EVAL_RE_REPARSING)
3337 PL_hints &= ~HINT_RE_EVAL;
3340 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3341 SvREFCNT_dec(GvHV(PL_hintgv));
3342 GvHV(PL_hintgv) = hh;
3345 SAVECOMPILEWARNINGS();
3347 if (PL_dowarn & G_WARN_ALL_ON)
3348 PL_compiling.cop_warnings = pWARN_ALL ;
3349 else if (PL_dowarn & G_WARN_ALL_OFF)
3350 PL_compiling.cop_warnings = pWARN_NONE ;
3352 PL_compiling.cop_warnings = pWARN_STD ;
3355 PL_compiling.cop_warnings =
3356 DUP_WARNINGS(oldcurcop->cop_warnings);
3357 cophh_free(CopHINTHASH_get(&PL_compiling));
3358 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3359 /* The label, if present, is the first entry on the chain. So rather
3360 than writing a blank label in front of it (which involves an
3361 allocation), just use the next entry in the chain. */
3362 PL_compiling.cop_hints_hash
3363 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3364 /* Check the assumption that this removed the label. */
3365 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3368 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3371 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3373 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3374 * so honour CATCH_GET and trap it here if necessary */
3376 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3378 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3379 SV **newsp; /* Used by POPBLOCK. */
3381 I32 optype; /* Used by POPEVAL. */
3387 PERL_UNUSED_VAR(newsp);
3388 PERL_UNUSED_VAR(optype);
3390 /* note that if yystatus == 3, then the EVAL CX block has already
3391 * been popped, and various vars restored */
3393 if (yystatus != 3) {
3395 op_free(PL_eval_root);
3396 PL_eval_root = NULL;
3398 SP = PL_stack_base + POPMARK; /* pop original mark */
3399 POPBLOCK(cx,PL_curpm);
3401 namesv = cx->blk_eval.old_namesv;
3402 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3403 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3409 /* If cx is still NULL, it means that we didn't go in the
3410 * POPEVAL branch. */
3411 cx = &cxstack[cxstack_ix];
3412 assert(CxTYPE(cx) == CXt_EVAL);
3413 namesv = cx->blk_eval.old_namesv;
3415 (void)hv_store(GvHVn(PL_incgv),
3416 SvPVX_const(namesv),
3417 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3419 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3422 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3425 if (!*(SvPV_nolen_const(errsv))) {
3426 sv_setpvs(errsv, "Compilation error");
3429 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3434 LEAVE_with_name("evalcomp");
3436 CopLINE_set(&PL_compiling, 0);
3437 SAVEFREEOP(PL_eval_root);
3438 cv_forget_slab(evalcv);
3440 DEBUG_x(dump_eval());
3442 /* Register with debugger: */
3443 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3444 CV * const cv = get_cvs("DB::postponed", 0);
3448 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3450 call_sv(MUTABLE_SV(cv), G_DISCARD);
3454 if (PL_unitcheckav) {
3455 OP *es = PL_eval_start;
3456 call_list(PL_scopestack_ix, PL_unitcheckav);
3460 /* compiled okay, so do it */
3462 CvDEPTH(evalcv) = 1;
3463 SP = PL_stack_base + POPMARK; /* pop original mark */
3464 PL_op = saveop; /* The caller may need it. */
3465 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3472 S_check_type_and_open(pTHX_ SV *name)
3477 const char *p = SvPV_const(name, len);
3480 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3482 /* checking here captures a reasonable error message when
3483 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3484 * user gets a confusing message about looking for the .pmc file
3485 * rather than for the .pm file so do the check in S_doopen_pm when
3486 * PMC is on instead of here. S_doopen_pm calls this func.
3487 * This check prevents a \0 in @INC causing problems.
3489 #ifdef PERL_DISABLE_PMC
3490 if (!IS_SAFE_PATHNAME(p, len, "require"))
3494 /* on Win32 stat is expensive (it does an open() and close() twice and
3495 a couple other IO calls), the open will fail with a dir on its own with
3496 errno EACCES, so only do a stat to separate a dir from a real EACCES
3497 caused by user perms */
3499 /* we use the value of errno later to see how stat() or open() failed.
3500 * We don't want it set if the stat succeeded but we still failed,
3501 * such as if the name exists, but is a directory */
3504 st_rc = PerlLIO_stat(p, &st);
3506 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3511 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3513 /* EACCES stops the INC search early in pp_require to implement
3514 feature RT #113422 */
3515 if(!retio && errno == EACCES) { /* exists but probably a directory */
3517 st_rc = PerlLIO_stat(p, &st);
3519 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3530 #ifndef PERL_DISABLE_PMC
3532 S_doopen_pm(pTHX_ SV *name)
3535 const char *p = SvPV_const(name, namelen);
3537 PERL_ARGS_ASSERT_DOOPEN_PM;
3539 /* check the name before trying for the .pmc name to avoid the
3540 * warning referring to the .pmc which the user probably doesn't
3541 * know or care about
3543 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3546 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3547 SV *const pmcsv = sv_newmortal();
3550 SvSetSV_nosteal(pmcsv,name);
3551 sv_catpvs(pmcsv, "c");
3553 pmcio = check_type_and_open(pmcsv);
3557 return check_type_and_open(name);
3560 # define doopen_pm(name) check_type_and_open(name)
3561 #endif /* !PERL_DISABLE_PMC */
3563 /* require doesn't search for absolute names, or when the name is
3564 explicitly relative the current directory */
3565 PERL_STATIC_INLINE bool
3566 S_path_is_searchable(const char *name)
3568 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3570 if (PERL_FILE_IS_ABSOLUTE(name)
3572 || (*name == '.' && ((name[1] == '/' ||
3573 (name[1] == '.' && name[2] == '/'))
3574 || (name[1] == '\\' ||
3575 ( name[1] == '.' && name[2] == '\\')))
3578 || (*name == '.' && (name[1] == '/' ||
3579 (name[1] == '.' && name[2] == '/')))
3590 /* also used for: pp_dofile() */
3602 int vms_unixname = 0;
3605 const char *tryname = NULL;
3607 const I32 gimme = GIMME_V;
3608 int filter_has_file = 0;
3609 PerlIO *tryrsfp = NULL;
3610 SV *filter_cache = NULL;
3611 SV *filter_state = NULL;
3612 SV *filter_sub = NULL;
3616 bool path_searchable;
3620 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3621 sv = sv_2mortal(new_version(sv));
3622 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3623 upg_version(PL_patchlevel, TRUE);
3624 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3625 if ( vcmp(sv,PL_patchlevel) <= 0 )
3626 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3627 SVfARG(sv_2mortal(vnormal(sv))),
3628 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3632 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3635 SV * const req = SvRV(sv);
3636 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3638 /* get the left hand term */
3639 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3641 first = SvIV(*av_fetch(lav,0,0));
3642 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3643 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3644 || av_tindex(lav) > 1 /* FP with > 3 digits */
3645 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3647 DIE(aTHX_ "Perl %"SVf" required--this is only "
3649 SVfARG(sv_2mortal(vnormal(req))),
3650 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3653 else { /* probably 'use 5.10' or 'use 5.8' */
3657 if (av_tindex(lav)>=1)
3658 second = SvIV(*av_fetch(lav,1,0));
3660 second /= second >= 600 ? 100 : 10;
3661 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3662 (int)first, (int)second);
3663 upg_version(hintsv, TRUE);
3665 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3666 "--this is only %"SVf", stopped",
3667 SVfARG(sv_2mortal(vnormal(req))),
3668 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3669 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3678 DIE(aTHX_ "Missing or undefined argument to require");
3679 name = SvPV_nomg_const(sv, len);
3680 if (!(name && len > 0 && *name))
3681 DIE(aTHX_ "Missing or undefined argument to require");
3683 if (!IS_SAFE_PATHNAME(name, len, "require")) {
3684 DIE(aTHX_ "Can't locate %s: %s",
3685 pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3686 SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3689 TAINT_PROPER("require");
3691 path_searchable = path_is_searchable(name);
3694 /* The key in the %ENV hash is in the syntax of file passed as the argument
3695 * usually this is in UNIX format, but sometimes in VMS format, which
3696 * can result in a module being pulled in more than once.
3697 * To prevent this, the key must be stored in UNIX format if the VMS
3698 * name can be translated to UNIX.
3702 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3704 unixlen = strlen(unixname);
3710 /* if not VMS or VMS name can not be translated to UNIX, pass it
3713 unixname = (char *) name;
3716 if (PL_op->op_type == OP_REQUIRE) {
3717 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3718 unixname, unixlen, 0);
3720 if (*svp != &PL_sv_undef)
3723 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3724 "Compilation failed in require", unixname);
3728 LOADING_FILE_PROBE(unixname);
3730 /* prepare to compile file */
3732 if (!path_searchable) {
3733 /* At this point, name is SvPVX(sv) */
3735 tryrsfp = doopen_pm(sv);
3737 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3738 AV * const ar = GvAVn(PL_incgv);
3745 namesv = newSV_type(SVt_PV);
3746 for (i = 0; i <= AvFILL(ar); i++) {
3747 SV * const dirsv = *av_fetch(ar, i, TRUE);
3755 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3756 && !SvOBJECT(SvRV(loader)))
3758 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3762 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3763 PTR2UV(SvRV(dirsv)), name);
3764 tryname = SvPVX_const(namesv);
3767 if (SvPADTMP(nsv)) {
3768 nsv = sv_newmortal();
3769 SvSetSV_nosteal(nsv,sv);
3772 ENTER_with_name("call_INC");
3780 if (SvGMAGICAL(loader)) {
3781 SV *l = sv_newmortal();
3782 sv_setsv_nomg(l, loader);
3785 if (sv_isobject(loader))
3786 count = call_method("INC", G_ARRAY);
3788 count = call_sv(loader, G_ARRAY);
3798 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3799 && !isGV_with_GP(SvRV(arg))) {
3800 filter_cache = SvRV(arg);
3807 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3811 if (isGV_with_GP(arg)) {
3812 IO * const io = GvIO((const GV *)arg);
3817 tryrsfp = IoIFP(io);
3818 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3819 PerlIO_close(IoOFP(io));
3830 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3832 SvREFCNT_inc_simple_void_NN(filter_sub);
3835 filter_state = SP[i];
3836 SvREFCNT_inc_simple_void(filter_state);
3840 if (!tryrsfp && (filter_cache || filter_sub)) {
3841 tryrsfp = PerlIO_open(BIT_BUCKET,
3847 /* FREETMPS may free our filter_cache */
3848 SvREFCNT_inc_simple_void(filter_cache);
3852 LEAVE_with_name("call_INC");
3854 /* Now re-mortalize it. */
3855 sv_2mortal(filter_cache);
3857 /* Adjust file name if the hook has set an %INC entry.
3858 This needs to happen after the FREETMPS above. */
3859 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3861 tryname = SvPV_nolen_const(*svp);
3868 filter_has_file = 0;
3869 filter_cache = NULL;
3871 SvREFCNT_dec_NN(filter_state);
3872 filter_state = NULL;
3875 SvREFCNT_dec_NN(filter_sub);
3880 if (path_searchable) {
3885 dir = SvPV_nomg_const(dirsv, dirlen);
3891 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3895 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3898 sv_setpv(namesv, unixdir);
3899 sv_catpv(namesv, unixname);
3901 # ifdef __SYMBIAN32__
3902 if (PL_origfilename[0] &&
3903 PL_origfilename[1] == ':' &&
3904 !(dir[0] && dir[1] == ':'))
3905 Perl_sv_setpvf(aTHX_ namesv,
3910 Perl_sv_setpvf(aTHX_ namesv,
3914 /* The equivalent of
3915 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3916 but without the need to parse the format string, or
3917 call strlen on either pointer, and with the correct
3918 allocation up front. */
3920 char *tmp = SvGROW(namesv, dirlen + len + 2);
3922 memcpy(tmp, dir, dirlen);
3925 /* Avoid '<dir>//<file>' */
3926 if (!dirlen || *(tmp-1) != '/') {
3929 /* So SvCUR_set reports the correct length below */
3933 /* name came from an SV, so it will have a '\0' at the
3934 end that we can copy as part of this memcpy(). */
3935 memcpy(tmp, name, len + 1);
3937 SvCUR_set(namesv, dirlen + len + 1);
3942 TAINT_PROPER("require");
3943 tryname = SvPVX_const(namesv);
3944 tryrsfp = doopen_pm(namesv);
3946 if (tryname[0] == '.' && tryname[1] == '/') {
3948 while (*++tryname == '/') {}
3952 else if (errno == EMFILE || errno == EACCES) {
3953 /* no point in trying other paths if out of handles;
3954 * on the other hand, if we couldn't open one of the
3955 * files, then going on with the search could lead to
3956 * unexpected results; see perl #113422
3965 saved_errno = errno; /* sv_2mortal can realloc things */
3968 if (PL_op->op_type == OP_REQUIRE) {
3969 if(saved_errno == EMFILE || saved_errno == EACCES) {
3970 /* diag_listed_as: Can't locate %s */
3971 DIE(aTHX_ "Can't locate %s: %s: %s",
3972 name, tryname, Strerror(saved_errno));
3974 if (namesv) { /* did we lookup @INC? */
3975 AV * const ar = GvAVn(PL_incgv);
3977 SV *const msg = newSVpvs_flags("", SVs_TEMP);
3978 SV *const inc = newSVpvs_flags("", SVs_TEMP);
3979 for (i = 0; i <= AvFILL(ar); i++) {
3980 sv_catpvs(inc, " ");
3981 sv_catsv(inc, *av_fetch(ar, i, TRUE));
3983 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
3984 const char *c, *e = name + len - 3;
3985 sv_catpv(msg, " (you may need to install the ");
3986 for (c = name; c < e; c++) {
3988 sv_catpvs(msg, "::");
3991 sv_catpvn(msg, c, 1);
3994 sv_catpv(msg, " module)");
3996 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
3997 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
3999 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4000 sv_catpv(msg, " (did you run h2ph?)");
4003 /* diag_listed_as: Can't locate %s */
4005 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4009 DIE(aTHX_ "Can't locate %s", name);
4016 SETERRNO(0, SS_NORMAL);
4018 /* Assume success here to prevent recursive requirement. */
4019 /* name is never assigned to again, so len is still strlen(name) */
4020 /* Check whether a hook in @INC has already filled %INC */
4022 (void)hv_store(GvHVn(PL_incgv),
4023 unixname, unixlen, newSVpv(tryname,0),0);
4025 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4027 (void)hv_store(GvHVn(PL_incgv),
4028 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4031 ENTER_with_name("eval");
4033 SAVECOPFILE_FREE(&PL_compiling);
4034 CopFILE_set(&PL_compiling, tryname);
4035 lex_start(NULL, tryrsfp, 0);
4037 if (filter_sub || filter_cache) {
4038 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4039 than hanging another SV from it. In turn, filter_add() optionally
4040 takes the SV to use as the filter (or creates a new SV if passed
4041 NULL), so simply pass in whatever value filter_cache has. */
4042 SV * const fc = filter_cache ? newSV(0) : NULL;
4044 if (fc) sv_copypv(fc, filter_cache);
4045 datasv = filter_add(S_run_user_filter, fc);
4046 IoLINES(datasv) = filter_has_file;
4047 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4048 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4051 /* switch to eval mode */
4052 PUSHBLOCK(cx, CXt_EVAL, SP);
4054 cx->blk_eval.retop = PL_op->op_next;
4056 SAVECOPLINE(&PL_compiling);
4057 CopLINE_set(&PL_compiling, 0);
4061 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4062 op = DOCATCH(PL_eval_start);
4064 op = PL_op->op_next;
4066 LOADED_FILE_PROBE(unixname);
4071 /* This is a op added to hold the hints hash for
4072 pp_entereval. The hash can be modified by the code
4073 being eval'ed, so we return a copy instead. */
4078 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4088 const I32 gimme = GIMME_V;
4089 const U32 was = PL_breakable_sub_gen;
4090 char tbuf[TYPE_DIGITS(long) + 12];
4091 bool saved_delete = FALSE;
4092 char *tmpbuf = tbuf;
4095 U32 seq, lex_flags = 0;
4096 HV *saved_hh = NULL;
4097 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4099 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4100 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4102 else if (PL_hints & HINT_LOCALIZE_HH || (
4103 PL_op->op_private & OPpEVAL_COPHH
4104 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4106 saved_hh = cop_hints_2hv(PL_curcop, 0);
4107 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4111 /* make sure we've got a plain PV (no overload etc) before testing
4112 * for taint. Making a copy here is probably overkill, but better
4113 * safe than sorry */
4115 const char * const p = SvPV_const(sv, len);
4117 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4118 lex_flags |= LEX_START_COPIED;
4120 if (bytes && SvUTF8(sv))
4121 SvPVbyte_force(sv, len);
4123 else if (bytes && SvUTF8(sv)) {
4124 /* Don't modify someone else's scalar */
4127 (void)sv_2mortal(sv);
4128 SvPVbyte_force(sv,len);
4129 lex_flags |= LEX_START_COPIED;
4132 TAINT_IF(SvTAINTED(sv));
4133 TAINT_PROPER("eval");
4135 ENTER_with_name("eval");
4136 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4137 ? LEX_IGNORE_UTF8_HINTS
4138 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4143 /* switch to eval mode */
4145 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4146 SV * const temp_sv = sv_newmortal();
4147 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4148 (unsigned long)++PL_evalseq,
4149 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4150 tmpbuf = SvPVX(temp_sv);
4151 len = SvCUR(temp_sv);
4154 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4155 SAVECOPFILE_FREE(&PL_compiling);
4156 CopFILE_set(&PL_compiling, tmpbuf+2);
4157 SAVECOPLINE(&PL_compiling);
4158 CopLINE_set(&PL_compiling, 1);
4159 /* special case: an eval '' executed within the DB package gets lexically
4160 * placed in the first non-DB CV rather than the current CV - this
4161 * allows the debugger to execute code, find lexicals etc, in the
4162 * scope of the code being debugged. Passing &seq gets find_runcv
4163 * to do the dirty work for us */
4164 runcv = find_runcv(&seq);
4166 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4168 cx->blk_eval.retop = PL_op->op_next;
4170 /* prepare to compile string */
4172 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4173 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4175 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4176 deleting the eval's FILEGV from the stash before gv_check() runs
4177 (i.e. before run-time proper). To work around the coredump that
4178 ensues, we always turn GvMULTI_on for any globals that were
4179 introduced within evals. See force_ident(). GSAR 96-10-12 */
4180 char *const safestr = savepvn(tmpbuf, len);
4181 SAVEDELETE(PL_defstash, safestr, len);
4182 saved_delete = TRUE;
4187 if (doeval(gimme, runcv, seq, saved_hh)) {
4188 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4189 ? PERLDB_LINE_OR_SAVESRC
4190 : PERLDB_SAVESRC_NOSUBS) {
4191 /* Retain the filegv we created. */
4192 } else if (!saved_delete) {
4193 char *const safestr = savepvn(tmpbuf, len);
4194 SAVEDELETE(PL_defstash, safestr, len);
4196 return DOCATCH(PL_eval_start);
4198 /* We have already left the scope set up earlier thanks to the LEAVE
4200 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4201 ? PERLDB_LINE_OR_SAVESRC
4202 : PERLDB_SAVESRC_INVALID) {
4203 /* Retain the filegv we created. */
4204 } else if (!saved_delete) {
4205 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4207 return PL_op->op_next;
4222 /* grab this value before POPEVAL restores old PL_in_eval */
4223 bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4228 namesv = cx->blk_eval.old_namesv;
4229 retop = cx->blk_eval.retop;
4230 evalcv = cx->blk_eval.cv;
4232 SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
4233 gimme, SVs_TEMP, FALSE);
4234 PL_curpm = newpm; /* Don't pop $1 et al till now */
4237 assert(CvDEPTH(evalcv) == 1);
4239 CvDEPTH(evalcv) = 0;
4241 if (optype == OP_REQUIRE &&
4242 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4244 /* Unassume the success we assumed earlier. */
4245 (void)hv_delete(GvHVn(PL_incgv),
4246 SvPVX_const(namesv),
4247 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4249 Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4250 NOT_REACHED; /* NOTREACHED */
4251 /* die_unwind() did LEAVE, or we won't be here */
4254 LEAVE_with_name("eval");
4262 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4263 close to the related Perl_create_eval_scope. */
4265 Perl_delete_eval_scope(pTHX)
4276 LEAVE_with_name("eval_scope");
4277 PERL_UNUSED_VAR(newsp);
4278 PERL_UNUSED_VAR(gimme);
4279 PERL_UNUSED_VAR(optype);
4282 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4283 also needed by Perl_fold_constants. */
4285 Perl_create_eval_scope(pTHX_ U32 flags)
4288 const I32 gimme = GIMME_V;
4290 ENTER_with_name("eval_scope");
4293 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4296 PL_in_eval = EVAL_INEVAL;
4297 if (flags & G_KEEPERR)
4298 PL_in_eval |= EVAL_KEEPERR;
4301 if (flags & G_FAKINGEVAL) {
4302 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4309 PERL_CONTEXT * const cx = create_eval_scope(0);
4310 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4311 return DOCATCH(PL_op->op_next);
4326 retop = cx->blk_eval.retop;
4328 PERL_UNUSED_VAR(optype);
4330 SP = leave_common(newsp, SP, newsp, gimme,
4331 SVs_PADTMP|SVs_TEMP, FALSE);
4332 PL_curpm = newpm; /* Don't pop $1 et al till now */
4334 LEAVE_with_name("eval_scope");
4343 const I32 gimme = GIMME_V;
4345 ENTER_with_name("given");
4348 assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4352 PUSHBLOCK(cx, CXt_GIVEN, SP);
4365 PERL_UNUSED_CONTEXT;
4368 assert(CxTYPE(cx) == CXt_GIVEN);
4370 SP = leave_common(newsp, SP, newsp, gimme,
4371 SVs_PADTMP|SVs_TEMP, FALSE);
4372 PL_curpm = newpm; /* Don't pop $1 et al till now */
4374 LEAVE_with_name("given");
4378 /* Helper routines used by pp_smartmatch */
4380 S_make_matcher(pTHX_ REGEXP *re)
4382 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4384 PERL_ARGS_ASSERT_MAKE_MATCHER;
4386 PM_SETRE(matcher, ReREFCNT_inc(re));
4388 SAVEFREEOP((OP *) matcher);
4389 ENTER_with_name("matcher"); SAVETMPS;
4395 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4400 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4402 PL_op = (OP *) matcher;
4405 (void) Perl_pp_match(aTHX);
4407 result = SvTRUEx(POPs);
4414 S_destroy_matcher(pTHX_ PMOP *matcher)
4416 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4417 PERL_UNUSED_ARG(matcher);
4420 LEAVE_with_name("matcher");
4423 /* Do a smart match */
4426 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4427 return do_smartmatch(NULL, NULL, 0);
4430 /* This version of do_smartmatch() implements the
4431 * table of smart matches that is found in perlsyn.
4434 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4438 bool object_on_left = FALSE;
4439 SV *e = TOPs; /* e is for 'expression' */
4440 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4442 /* Take care only to invoke mg_get() once for each argument.
4443 * Currently we do this by copying the SV if it's magical. */
4445 if (!copied && SvGMAGICAL(d))
4446 d = sv_mortalcopy(d);
4453 e = sv_mortalcopy(e);
4455 /* First of all, handle overload magic of the rightmost argument */
4458 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4459 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4461 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4468 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4471 SP -= 2; /* Pop the values */
4476 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4483 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4484 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4485 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4487 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4488 object_on_left = TRUE;
4491 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4493 if (object_on_left) {
4494 goto sm_any_sub; /* Treat objects like scalars */
4496 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4497 /* Test sub truth for each key */
4499 bool andedresults = TRUE;
4500 HV *hv = (HV*) SvRV(d);
4501 I32 numkeys = hv_iterinit(hv);
4502 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4505 while ( (he = hv_iternext(hv)) ) {
4506 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4507 ENTER_with_name("smartmatch_hash_key_test");
4510 PUSHs(hv_iterkeysv(he));
4512 c = call_sv(e, G_SCALAR);
4515 andedresults = FALSE;
4517 andedresults = SvTRUEx(POPs) && andedresults;
4519 LEAVE_with_name("smartmatch_hash_key_test");
4526 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4527 /* Test sub truth for each element */
4529 bool andedresults = TRUE;
4530 AV *av = (AV*) SvRV(d);
4531 const I32 len = av_tindex(av);
4532 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4535 for (i = 0; i <= len; ++i) {
4536 SV * const * const svp = av_fetch(av, i, FALSE);
4537 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4538 ENTER_with_name("smartmatch_array_elem_test");
4544 c = call_sv(e, G_SCALAR);
4547 andedresults = FALSE;
4549 andedresults = SvTRUEx(POPs) && andedresults;
4551 LEAVE_with_name("smartmatch_array_elem_test");
4560 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4561 ENTER_with_name("smartmatch_coderef");
4566 c = call_sv(e, G_SCALAR);
4570 else if (SvTEMP(TOPs))
4571 SvREFCNT_inc_void(TOPs);
4573 LEAVE_with_name("smartmatch_coderef");
4578 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4579 if (object_on_left) {
4580 goto sm_any_hash; /* Treat objects like scalars */
4582 else if (!SvOK(d)) {
4583 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4586 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4587 /* Check that the key-sets are identical */
4589 HV *other_hv = MUTABLE_HV(SvRV(d));
4592 U32 this_key_count = 0,
4593 other_key_count = 0;
4594 HV *hv = MUTABLE_HV(SvRV(e));
4596 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4597 /* Tied hashes don't know how many keys they have. */
4598 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4599 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4603 HV * const temp = other_hv;
4609 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4613 /* The hashes have the same number of keys, so it suffices
4614 to check that one is a subset of the other. */
4615 (void) hv_iterinit(hv);
4616 while ( (he = hv_iternext(hv)) ) {
4617 SV *key = hv_iterkeysv(he);
4619 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4622 if(!hv_exists_ent(other_hv, key, 0)) {
4623 (void) hv_iterinit(hv); /* reset iterator */
4629 (void) hv_iterinit(other_hv);
4630 while ( hv_iternext(other_hv) )
4634 other_key_count = HvUSEDKEYS(other_hv);
4636 if (this_key_count != other_key_count)
4641 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4642 AV * const other_av = MUTABLE_AV(SvRV(d));
4643 const SSize_t other_len = av_tindex(other_av) + 1;
4645 HV *hv = MUTABLE_HV(SvRV(e));
4647 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4648 for (i = 0; i < other_len; ++i) {
4649 SV ** const svp = av_fetch(other_av, i, FALSE);
4650 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4651 if (svp) { /* ??? When can this not happen? */
4652 if (hv_exists_ent(hv, *svp, 0))
4658 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4659 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4662 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4664 HV *hv = MUTABLE_HV(SvRV(e));
4666 (void) hv_iterinit(hv);
4667 while ( (he = hv_iternext(hv)) ) {
4668 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4670 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4672 (void) hv_iterinit(hv);
4673 destroy_matcher(matcher);
4678 destroy_matcher(matcher);
4684 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4685 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4692 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4693 if (object_on_left) {
4694 goto sm_any_array; /* Treat objects like scalars */
4696 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4697 AV * const other_av = MUTABLE_AV(SvRV(e));
4698 const SSize_t other_len = av_tindex(other_av) + 1;
4701 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4702 for (i = 0; i < other_len; ++i) {
4703 SV ** const svp = av_fetch(other_av, i, FALSE);
4705 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4706 if (svp) { /* ??? When can this not happen? */
4707 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4713 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4714 AV *other_av = MUTABLE_AV(SvRV(d));
4715 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4716 if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4720 const SSize_t other_len = av_tindex(other_av);
4722 if (NULL == seen_this) {
4723 seen_this = newHV();
4724 (void) sv_2mortal(MUTABLE_SV(seen_this));
4726 if (NULL == seen_other) {
4727 seen_other = newHV();
4728 (void) sv_2mortal(MUTABLE_SV(seen_other));
4730 for(i = 0; i <= other_len; ++i) {
4731 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4732 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4734 if (!this_elem || !other_elem) {
4735 if ((this_elem && SvOK(*this_elem))
4736 || (other_elem && SvOK(*other_elem)))
4739 else if (hv_exists_ent(seen_this,
4740 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4741 hv_exists_ent(seen_other,
4742 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4744 if (*this_elem != *other_elem)
4748 (void)hv_store_ent(seen_this,
4749 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4751 (void)hv_store_ent(seen_other,
4752 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4758 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4759 (void) do_smartmatch(seen_this, seen_other, 0);
4761 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4770 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4771 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4774 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4775 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4778 for(i = 0; i <= this_len; ++i) {
4779 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4780 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4782 if (svp && matcher_matches_sv(matcher, *svp)) {
4784 destroy_matcher(matcher);
4789 destroy_matcher(matcher);
4793 else if (!SvOK(d)) {
4794 /* undef ~~ array */
4795 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4798 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4799 for (i = 0; i <= this_len; ++i) {
4800 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4801 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4802 if (!svp || !SvOK(*svp))
4811 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4813 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4814 for (i = 0; i <= this_len; ++i) {
4815 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4822 /* infinite recursion isn't supposed to happen here */
4823 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4824 (void) do_smartmatch(NULL, NULL, 1);
4826 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4835 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4836 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4837 SV *t = d; d = e; e = t;
4838 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4841 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4842 SV *t = d; d = e; e = t;
4843 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4844 goto sm_regex_array;
4847 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4850 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4852 result = matcher_matches_sv(matcher, d);
4854 PUSHs(result ? &PL_sv_yes : &PL_sv_no);
4855 destroy_matcher(matcher);
4860 /* See if there is overload magic on left */
4861 else if (object_on_left && SvAMAGIC(d)) {
4863 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4864 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4867 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4875 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4878 else if (!SvOK(d)) {
4879 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4880 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4885 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4886 DEBUG_M(if (SvNIOK(e))
4887 Perl_deb(aTHX_ " applying rule Any-Num\n");
4889 Perl_deb(aTHX_ " applying rule Num-numish\n");
4891 /* numeric comparison */
4894 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4895 (void) Perl_pp_i_eq(aTHX);
4897 (void) Perl_pp_eq(aTHX);
4905 /* As a last resort, use string comparison */
4906 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4909 return Perl_pp_seq(aTHX);
4916 const I32 gimme = GIMME_V;
4918 /* This is essentially an optimization: if the match
4919 fails, we don't want to push a context and then
4920 pop it again right away, so we skip straight
4921 to the op that follows the leavewhen.
4922 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4924 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4925 RETURNOP(cLOGOP->op_other->op_next);
4927 ENTER_with_name("when");
4930 PUSHBLOCK(cx, CXt_WHEN, SP);
4945 cxix = dopoptogiven(cxstack_ix);
4947 /* diag_listed_as: Can't "when" outside a topicalizer */
4948 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
4949 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
4952 assert(CxTYPE(cx) == CXt_WHEN);
4954 SP = leave_common(newsp, SP, newsp, gimme,
4955 SVs_PADTMP|SVs_TEMP, FALSE);
4956 PL_curpm = newpm; /* pop $1 et al */
4958 LEAVE_with_name("when");
4960 if (cxix < cxstack_ix)
4963 cx = &cxstack[cxix];
4965 if (CxFOREACH(cx)) {
4966 /* clear off anything above the scope we're re-entering */
4967 I32 inner = PL_scopestack_ix;
4970 if (PL_scopestack_ix < inner)
4971 leave_scope(PL_scopestack[PL_scopestack_ix]);
4972 PL_curcop = cx->blk_oldcop;
4975 return cx->blk_loop.my_op->op_nextop;
4979 RETURNOP(cx->blk_givwhen.leave_op);
4992 PERL_UNUSED_VAR(gimme);
4994 cxix = dopoptowhen(cxstack_ix);
4996 DIE(aTHX_ "Can't \"continue\" outside a when block");
4998 if (cxix < cxstack_ix)
5002 assert(CxTYPE(cx) == CXt_WHEN);
5005 PL_curpm = newpm; /* pop $1 et al */
5007 LEAVE_with_name("when");
5008 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5016 cxix = dopoptogiven(cxstack_ix);
5018 DIE(aTHX_ "Can't \"break\" outside a given block");
5020 cx = &cxstack[cxix];
5022 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5024 if (cxix < cxstack_ix)
5027 /* Restore the sp at the time we entered the given block */
5030 return cx->blk_givwhen.leave_op;
5034 S_doparseform(pTHX_ SV *sv)
5037 char *s = SvPV(sv, len);
5039 char *base = NULL; /* start of current field */
5040 I32 skipspaces = 0; /* number of contiguous spaces seen */
5041 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5042 bool repeat = FALSE; /* ~~ seen on this line */
5043 bool postspace = FALSE; /* a text field may need right padding */
5046 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5048 bool ischop; /* it's a ^ rather than a @ */
5049 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5050 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5054 PERL_ARGS_ASSERT_DOPARSEFORM;
5057 Perl_croak(aTHX_ "Null picture in formline");
5059 if (SvTYPE(sv) >= SVt_PVMG) {
5060 /* This might, of course, still return NULL. */
5061 mg = mg_find(sv, PERL_MAGIC_fm);
5063 sv_upgrade(sv, SVt_PVMG);
5067 /* still the same as previously-compiled string? */
5068 SV *old = mg->mg_obj;
5069 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5070 && len == SvCUR(old)
5071 && strnEQ(SvPVX(old), SvPVX(sv), len)
5073 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5077 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5078 Safefree(mg->mg_ptr);
5084 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5085 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5088 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5089 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5093 /* estimate the buffer size needed */
5094 for (base = s; s <= send; s++) {
5095 if (*s == '\n' || *s == '@' || *s == '^')
5101 Newx(fops, maxops, U32);
5106 *fpc++ = FF_LINEMARK;
5107 noblank = repeat = FALSE;
5125 case ' ': case '\t':
5132 } /* else FALL THROUGH */
5140 *fpc++ = FF_LITERAL;
5148 *fpc++ = (U32)skipspaces;
5152 *fpc++ = FF_NEWLINE;
5156 arg = fpc - linepc + 1;
5163 *fpc++ = FF_LINEMARK;
5164 noblank = repeat = FALSE;
5173 ischop = s[-1] == '^';
5179 arg = (s - base) - 1;
5181 *fpc++ = FF_LITERAL;
5187 if (*s == '*') { /* @* or ^* */
5189 *fpc++ = 2; /* skip the @* or ^* */
5191 *fpc++ = FF_LINESNGL;
5194 *fpc++ = FF_LINEGLOB;
5196 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5197 arg = ischop ? FORM_NUM_BLANK : 0;
5202 const char * const f = ++s;
5205 arg |= FORM_NUM_POINT + (s - f);
5207 *fpc++ = s - base; /* fieldsize for FETCH */
5208 *fpc++ = FF_DECIMAL;
5210 unchopnum |= ! ischop;
5212 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5213 arg = ischop ? FORM_NUM_BLANK : 0;
5215 s++; /* skip the '0' first */
5219 const char * const f = ++s;
5222 arg |= FORM_NUM_POINT + (s - f);
5224 *fpc++ = s - base; /* fieldsize for FETCH */
5225 *fpc++ = FF_0DECIMAL;
5227 unchopnum |= ! ischop;
5229 else { /* text field */
5231 bool ismore = FALSE;
5234 while (*++s == '>') ;
5235 prespace = FF_SPACE;
5237 else if (*s == '|') {
5238 while (*++s == '|') ;
5239 prespace = FF_HALFSPACE;
5244 while (*++s == '<') ;
5247 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5251 *fpc++ = s - base; /* fieldsize for FETCH */
5253 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5256 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5270 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5273 mg->mg_ptr = (char *) fops;
5274 mg->mg_len = arg * sizeof(U32);
5275 mg->mg_obj = sv_copy;
5276 mg->mg_flags |= MGf_REFCOUNTED;
5278 if (unchopnum && repeat)
5279 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5286 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5288 /* Can value be printed in fldsize chars, using %*.*f ? */
5292 int intsize = fldsize - (value < 0 ? 1 : 0);
5294 if (frcsize & FORM_NUM_POINT)
5296 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5299 while (intsize--) pwr *= 10.0;
5300 while (frcsize--) eps /= 10.0;
5303 if (value + eps >= pwr)
5306 if (value - eps <= -pwr)
5313 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5315 SV * const datasv = FILTER_DATA(idx);
5316 const int filter_has_file = IoLINES(datasv);
5317 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5318 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5323 char *prune_from = NULL;
5324 bool read_from_cache = FALSE;
5328 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5330 assert(maxlen >= 0);
5333 /* I was having segfault trouble under Linux 2.2.5 after a
5334 parse error occurred. (Had to hack around it with a test
5335 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5336 not sure where the trouble is yet. XXX */
5339 SV *const cache = datasv;
5342 const char *cache_p = SvPV(cache, cache_len);
5346 /* Running in block mode and we have some cached data already.
5348 if (cache_len >= umaxlen) {
5349 /* In fact, so much data we don't even need to call
5354 const char *const first_nl =
5355 (const char *)memchr(cache_p, '\n', cache_len);
5357 take = first_nl + 1 - cache_p;
5361 sv_catpvn(buf_sv, cache_p, take);
5362 sv_chop(cache, cache_p + take);
5363 /* Definitely not EOF */
5367 sv_catsv(buf_sv, cache);
5369 umaxlen -= cache_len;
5372 read_from_cache = TRUE;
5376 /* Filter API says that the filter appends to the contents of the buffer.
5377 Usually the buffer is "", so the details don't matter. But if it's not,
5378 then clearly what it contains is already filtered by this filter, so we
5379 don't want to pass it in a second time.
5380 I'm going to use a mortal in case the upstream filter croaks. */
5381 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5382 ? sv_newmortal() : buf_sv;
5383 SvUPGRADE(upstream, SVt_PV);
5385 if (filter_has_file) {
5386 status = FILTER_READ(idx+1, upstream, 0);
5389 if (filter_sub && status >= 0) {
5393 ENTER_with_name("call_filter_sub");
5398 DEFSV_set(upstream);
5402 PUSHs(filter_state);
5405 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5415 SV * const errsv = ERRSV;
5416 if (SvTRUE_NN(errsv))
5417 err = newSVsv(errsv);
5423 LEAVE_with_name("call_filter_sub");
5426 if (SvGMAGICAL(upstream)) {
5428 if (upstream == buf_sv) mg_free(buf_sv);
5430 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5431 if(!err && SvOK(upstream)) {
5432 got_p = SvPV_nomg(upstream, got_len);
5434 if (got_len > umaxlen) {
5435 prune_from = got_p + umaxlen;
5438 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5439 if (first_nl && first_nl + 1 < got_p + got_len) {
5440 /* There's a second line here... */
5441 prune_from = first_nl + 1;
5445 if (!err && prune_from) {
5446 /* Oh. Too long. Stuff some in our cache. */
5447 STRLEN cached_len = got_p + got_len - prune_from;
5448 SV *const cache = datasv;
5451 /* Cache should be empty. */
5452 assert(!SvCUR(cache));
5455 sv_setpvn(cache, prune_from, cached_len);
5456 /* If you ask for block mode, you may well split UTF-8 characters.
5457 "If it breaks, you get to keep both parts"
5458 (Your code is broken if you don't put them back together again
5459 before something notices.) */
5460 if (SvUTF8(upstream)) {
5463 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5465 /* Cannot just use sv_setpvn, as that could free the buffer
5466 before we have a chance to assign it. */
5467 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5468 got_len - cached_len);
5470 /* Can't yet be EOF */
5475 /* If they are at EOF but buf_sv has something in it, then they may never
5476 have touched the SV upstream, so it may be undefined. If we naively
5477 concatenate it then we get a warning about use of uninitialised value.
5479 if (!err && upstream != buf_sv &&
5481 sv_catsv_nomg(buf_sv, upstream);
5483 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5486 IoLINES(datasv) = 0;
5488 SvREFCNT_dec(filter_state);
5489 IoTOP_GV(datasv) = NULL;
5492 SvREFCNT_dec(filter_sub);
5493 IoBOTTOM_GV(datasv) = NULL;
5495 filter_del(S_run_user_filter);
5501 if (status == 0 && read_from_cache) {
5502 /* If we read some data from the cache (and by getting here it implies
5503 that we emptied the cache) then we aren't yet at EOF, and mustn't
5504 report that to our caller. */
5511 * ex: set ts=8 sts=4 sw=4 et: