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 RUN_PP_CATCHABLY(thispp) \
38 STMT_START { if (CATCH_GET) return docatch(thispp); } STMT_END
40 #define dopopto_cursub() \
41 (PL_curstackinfo->si_cxsubix >= 0 \
42 ? PL_curstackinfo->si_cxsubix \
43 : dopoptosub_at(cxstack, cxstack_ix))
45 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
51 const PERL_CONTEXT *cx;
54 if (PL_op->op_private & OPpOFFBYONE) {
55 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
58 cxix = dopopto_cursub();
64 switch (cx->blk_gimme) {
83 PMOP *pm = (PMOP*)cLOGOP->op_other;
88 const regexp_engine *eng;
89 bool is_bare_re= FALSE;
91 if (PL_op->op_flags & OPf_STACKED) {
101 /* prevent recompiling under /o and ithreads. */
102 #if defined(USE_ITHREADS)
103 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
110 assert (re != (REGEXP*) &PL_sv_undef);
111 eng = re ? RX_ENGINE(re) : current_re_engine();
113 new_re = (eng->op_comp
115 : &Perl_re_op_compile
116 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
118 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
120 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
122 if (pm->op_pmflags & PMf_HAS_CV)
123 ReANY(new_re)->qr_anoncv
124 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
128 /* The match's LHS's get-magic might need to access this op's regexp
129 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
130 get-magic now before we replace the regexp. Hopefully this hack can
131 be replaced with the approach described at
132 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
134 if (pm->op_type == OP_MATCH) {
136 const bool was_tainted = TAINT_get;
137 if (pm->op_flags & OPf_STACKED)
139 else if (pm->op_targ)
140 lhs = PAD_SV(pm->op_targ);
143 /* Restore the previous value of PL_tainted (which may have been
144 modified by get-magic), to avoid incorrectly setting the
145 RXf_TAINTED flag with RX_TAINT_on further down. */
146 TAINT_set(was_tainted);
147 #ifdef NO_TAINT_SUPPORT
148 PERL_UNUSED_VAR(was_tainted);
151 tmp = reg_temp_copy(NULL, new_re);
152 ReREFCNT_dec(new_re);
158 PM_SETRE(pm, new_re);
162 assert(TAINTING_get || !TAINT_get);
164 SvTAINTED_on((SV*)new_re);
168 /* handle the empty pattern */
169 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) {
170 if (PL_curpm == PL_reg_curpm) {
171 if (PL_curpm_under && PL_curpm_under == PL_reg_curpm) {
172 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
177 #if !defined(USE_ITHREADS)
178 /* can't change the optree at runtime either */
179 /* PMf_KEEP is handled differently under threads to avoid these problems */
180 if (pm->op_pmflags & PMf_KEEP) {
181 cLOGOP->op_first->op_next = PL_op->op_next;
193 PERL_CONTEXT *cx = CX_CUR();
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() */
221 sv_catsv_nomg(dstr, POPs);
222 if (UNLIKELY(TAINT_get))
223 cx->sb_rxtainted |= SUBST_TAINT_REPL;
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))
284 /* sv_magic(), when adding magic (e.g.taint magic), also
285 * recalculates any pos() magic, converting any byte offset
286 * to utf8 offset. Make sure pos() is reset before this
287 * happens rather than using the now invalid value (since
288 * we've just replaced targ's pvx buffer with the
289 * potentially shorter dstr buffer). Normally (i.e. in
290 * non-taint cases), pos() gets removed a few lines later
291 * with the SvSETMAGIC().
295 mg = mg_find_mglob(targ);
297 MgBYTEPOS_set(mg, targ, SvPVX(targ), -1);
303 /* PL_tainted must be correctly set for this mg_set */
312 RETURNOP(pm->op_next);
313 NOT_REACHED; /* NOTREACHED */
315 cx->sb_iters = saviters;
317 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
320 assert(!RX_SUBOFFSET(rx));
321 cx->sb_orig = orig = RX_SUBBEG(rx);
323 cx->sb_strend = s + (cx->sb_strend - m);
325 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
327 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
328 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
330 sv_catpvn_nomg(dstr, s, m-s);
332 cx->sb_s = RX_OFFS(rx)[0].end + orig;
333 { /* Update the pos() information. */
335 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
338 /* the string being matched against may no longer be a string,
339 * e.g. $_=0; s/.../$_++/ge */
342 SvPV_force_nomg_nolen(sv);
344 if (!(mg = mg_find_mglob(sv))) {
345 mg = sv_magicext_mglob(sv);
347 MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
350 (void)ReREFCNT_inc(rx);
351 /* update the taint state of various various variables in preparation
352 * for calling the code block.
353 * See "how taint works" above pp_subst() */
355 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
356 cx->sb_rxtainted |= SUBST_TAINT_PAT;
358 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
359 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
360 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
362 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
364 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
365 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
366 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
367 ? cx->sb_dstr : cx->sb_targ);
370 rxres_save(&cx->sb_rxres, rx);
372 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
376 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
381 PERL_ARGS_ASSERT_RXRES_SAVE;
384 if (!p || p[1] < RX_NPARENS(rx)) {
386 i = 7 + (RX_NPARENS(rx)+1) * 2;
388 i = 6 + (RX_NPARENS(rx)+1) * 2;
397 /* what (if anything) to free on croak */
398 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
399 RX_MATCH_COPIED_off(rx);
400 *p++ = RX_NPARENS(rx);
403 *p++ = PTR2UV(RX_SAVED_COPY(rx));
404 RX_SAVED_COPY(rx) = NULL;
407 *p++ = PTR2UV(RX_SUBBEG(rx));
408 *p++ = (UV)RX_SUBLEN(rx);
409 *p++ = (UV)RX_SUBOFFSET(rx);
410 *p++ = (UV)RX_SUBCOFFSET(rx);
411 for (i = 0; i <= RX_NPARENS(rx); ++i) {
412 *p++ = (UV)RX_OFFS(rx)[i].start;
413 *p++ = (UV)RX_OFFS(rx)[i].end;
418 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
423 PERL_ARGS_ASSERT_RXRES_RESTORE;
426 RX_MATCH_COPY_FREE(rx);
427 RX_MATCH_COPIED_set(rx, *p);
429 RX_NPARENS(rx) = *p++;
432 if (RX_SAVED_COPY(rx))
433 SvREFCNT_dec (RX_SAVED_COPY(rx));
434 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
438 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
439 RX_SUBLEN(rx) = (I32)(*p++);
440 RX_SUBOFFSET(rx) = (I32)*p++;
441 RX_SUBCOFFSET(rx) = (I32)*p++;
442 for (i = 0; i <= RX_NPARENS(rx); ++i) {
443 RX_OFFS(rx)[i].start = (I32)(*p++);
444 RX_OFFS(rx)[i].end = (I32)(*p++);
449 S_rxres_free(pTHX_ void **rsp)
451 UV * const p = (UV*)*rsp;
453 PERL_ARGS_ASSERT_RXRES_FREE;
457 void *tmp = INT2PTR(char*,*p);
460 U32 i = 9 + p[1] * 2;
462 U32 i = 8 + p[1] * 2;
467 SvREFCNT_dec (INT2PTR(SV*,p[2]));
470 PoisonFree(p, i, sizeof(UV));
479 #define FORM_NUM_BLANK (1<<30)
480 #define FORM_NUM_POINT (1<<29)
484 dSP; dMARK; dORIGMARK;
485 SV * const tmpForm = *++MARK;
486 SV *formsv; /* contains text of original format */
487 U32 *fpc; /* format ops program counter */
488 char *t; /* current append position in target string */
489 const char *f; /* current position in format string */
491 SV *sv = NULL; /* current item */
492 const char *item = NULL;/* string value of current item */
493 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
494 I32 itembytes = 0; /* as itemsize, but length in bytes */
495 I32 fieldsize = 0; /* width of current field */
496 I32 lines = 0; /* number of lines that have been output */
497 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
498 const char *chophere = NULL; /* where to chop current item */
499 STRLEN linemark = 0; /* pos of start of line in output */
501 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
502 STRLEN len; /* length of current sv */
503 STRLEN linemax; /* estimate of output size in bytes */
504 bool item_is_utf8 = FALSE;
505 bool targ_is_utf8 = FALSE;
508 U8 *source; /* source of bytes to append */
509 STRLEN to_copy; /* how may bytes to append */
510 char trans; /* what chars to translate */
511 bool copied_form = FALSE; /* have we duplicated the form? */
513 mg = doparseform(tmpForm);
515 fpc = (U32*)mg->mg_ptr;
516 /* the actual string the format was compiled from.
517 * with overload etc, this may not match tmpForm */
521 SvPV_force(PL_formtarget, len);
522 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
523 SvTAINTED_on(PL_formtarget);
524 if (DO_UTF8(PL_formtarget))
526 /* this is an initial estimate of how much output buffer space
527 * to allocate. It may be exceeded later */
528 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
529 t = SvGROW(PL_formtarget, len + linemax + 1);
530 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
532 f = SvPV_const(formsv, len);
536 const char *name = "???";
539 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
540 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
541 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
542 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
543 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
545 case FF_CHECKNL: name = "CHECKNL"; break;
546 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
547 case FF_SPACE: name = "SPACE"; break;
548 case FF_HALFSPACE: name = "HALFSPACE"; break;
549 case FF_ITEM: name = "ITEM"; break;
550 case FF_CHOP: name = "CHOP"; break;
551 case FF_LINEGLOB: name = "LINEGLOB"; break;
552 case FF_NEWLINE: name = "NEWLINE"; break;
553 case FF_MORE: name = "MORE"; break;
554 case FF_LINEMARK: name = "LINEMARK"; break;
555 case FF_END: name = "END"; break;
556 case FF_0DECIMAL: name = "0DECIMAL"; break;
557 case FF_LINESNGL: name = "LINESNGL"; break;
560 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
562 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
565 case FF_LINEMARK: /* start (or end) of a line */
566 linemark = t - SvPVX(PL_formtarget);
571 case FF_LITERAL: /* append <arg> literal chars */
576 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
579 case FF_SKIP: /* skip <arg> chars in format */
583 case FF_FETCH: /* get next item and set field size to <arg> */
592 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
595 SvTAINTED_on(PL_formtarget);
598 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
600 const char *s = item = SvPV_const(sv, len);
601 const char *send = s + len;
604 item_is_utf8 = DO_UTF8(sv);
616 if (itemsize == fieldsize)
619 itembytes = s - item;
624 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
626 const char *s = item = SvPV_const(sv, len);
627 const char *send = s + len;
631 item_is_utf8 = DO_UTF8(sv);
633 /* look for a legal split position */
641 /* provisional split point */
645 /* we delay testing fieldsize until after we've
646 * processed the possible split char directly
647 * following the last field char; so if fieldsize=3
648 * and item="a b cdef", we consume "a b", not "a".
649 * Ditto further down.
651 if (size == fieldsize)
655 if (strchr(PL_chopset, *s)) {
656 /* provisional split point */
657 /* for a non-space split char, we include
658 * the split char; hence the '+1' */
662 if (size == fieldsize)
674 if (!chophere || s == send) {
678 itembytes = chophere - item;
683 case FF_SPACE: /* append padding space (diff of field, item size) */
684 arg = fieldsize - itemsize;
692 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
693 arg = fieldsize - itemsize;
702 case FF_ITEM: /* append a text item, while blanking ctrl chars */
708 case FF_CHOP: /* (for ^*) chop the current item */
709 if (sv != &PL_sv_no) {
710 const char *s = chophere;
712 ((sv == tmpForm || SvSMAGICAL(sv))
713 || (SvGMAGICAL(tmpForm) && !sv_only_taint_gmagic(tmpForm))) ) {
714 /* sv and tmpForm are either the same SV, or magic might allow modification
715 of tmpForm when sv is modified, so copy */
716 SV *newformsv = sv_mortalcopy(formsv);
719 f = SvPV_nolen(newformsv) + (f - SvPV_nolen(formsv));
720 Newx(new_compiled, mg->mg_len / sizeof(U32), U32);
721 memcpy(new_compiled, mg->mg_ptr, mg->mg_len);
722 SAVEFREEPV(new_compiled);
723 fpc = new_compiled + (fpc - (U32*)mg->mg_ptr);
735 /* tied, overloaded or similar strangeness.
736 * Do it the hard way */
737 sv_setpvn(sv, s, len - (s-item));
743 case FF_LINESNGL: /* process ^* */
747 case FF_LINEGLOB: /* process @* */
749 const bool oneline = fpc[-1] == FF_LINESNGL;
750 const char *s = item = SvPV_const(sv, len);
751 const char *const send = s + len;
753 item_is_utf8 = DO_UTF8(sv);
764 to_copy = s - item - 1;
778 /* append to_copy bytes from source to PL_formstring.
779 * item_is_utf8 implies source is utf8.
780 * if trans, translate certain characters during the copy */
785 SvCUR_set(PL_formtarget,
786 t - SvPVX_const(PL_formtarget));
788 if (targ_is_utf8 && !item_is_utf8) {
789 source = tmp = bytes_to_utf8(source, &to_copy);
792 if (item_is_utf8 && !targ_is_utf8) {
794 /* Upgrade targ to UTF8, and then we reduce it to
795 a problem we have a simple solution for.
796 Don't need get magic. */
797 sv_utf8_upgrade_nomg(PL_formtarget);
799 /* re-calculate linemark */
800 s = (U8*)SvPVX(PL_formtarget);
801 /* the bytes we initially allocated to append the
802 * whole line may have been gobbled up during the
803 * upgrade, so allocate a whole new line's worth
807 s += UTF8_SAFE_SKIP(s,
808 (U8 *) SvEND(PL_formtarget));
809 linemark = s - (U8*)SvPVX(PL_formtarget);
811 /* Easy. They agree. */
812 assert (item_is_utf8 == targ_is_utf8);
815 /* @* and ^* are the only things that can exceed
816 * the linemax, so grow by the output size, plus
817 * a whole new form's worth in case of any further
819 grow = linemax + to_copy;
821 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
822 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
824 Copy(source, t, to_copy, char);
826 /* blank out ~ or control chars, depending on trans.
827 * works on bytes not chars, so relies on not
828 * matching utf8 continuation bytes */
830 U8 *send = s + to_copy;
833 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
840 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
846 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
849 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
852 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
855 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
857 /* If the field is marked with ^ and the value is undefined,
859 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
867 /* overflow evidence */
868 if (num_overflow(value, fieldsize, arg)) {
874 /* Formats aren't yet marked for locales, so assume "yes". */
876 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
878 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
879 STORE_LC_NUMERIC_SET_TO_NEEDED();
880 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
883 const char* qfmt = quadmath_format_single(fmt);
886 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
887 len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
889 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
894 /* we generate fmt ourselves so it is safe */
895 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
896 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
897 GCC_DIAG_RESTORE_STMT;
899 PERL_MY_SNPRINTF_POST_GUARD(len, max);
900 RESTORE_LC_NUMERIC();
905 case FF_NEWLINE: /* delete trailing spaces, then append \n */
907 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
912 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
915 if (arg) { /* repeat until fields exhausted? */
921 t = SvPVX(PL_formtarget) + linemark;
926 case FF_MORE: /* replace long end of string with '...' */
928 const char *s = chophere;
929 const char *send = item + len;
931 while (isSPACE(*s) && (s < send))
936 arg = fieldsize - itemsize;
943 if (strBEGINs(s1," ")) {
944 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
954 case FF_END: /* tidy up, then return */
956 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
958 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
960 SvUTF8_on(PL_formtarget);
961 FmLINES(PL_formtarget) += lines;
963 if (fpc[-1] == FF_BLANK)
964 RETURNOP(cLISTOP->op_first);
971 /* also used for: pp_mapstart() */
977 if (PL_stack_base + TOPMARK == SP) {
979 if (GIMME_V == G_SCALAR)
981 RETURNOP(PL_op->op_next->op_next);
983 PL_stack_sp = PL_stack_base + TOPMARK + 1;
984 Perl_pp_pushmark(aTHX); /* push dst */
985 Perl_pp_pushmark(aTHX); /* push src */
986 ENTER_with_name("grep"); /* enter outer scope */
990 ENTER_with_name("grep_item"); /* enter inner scope */
993 src = PL_stack_base[TOPMARK];
995 src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
1002 if (PL_op->op_type == OP_MAPSTART)
1003 Perl_pp_pushmark(aTHX); /* push top */
1004 return ((LOGOP*)PL_op->op_next)->op_other;
1010 const U8 gimme = GIMME_V;
1011 I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
1017 /* first, move source pointer to the next item in the source list */
1018 ++PL_markstack_ptr[-1];
1020 /* if there are new items, push them into the destination list */
1021 if (items && gimme != G_VOID) {
1022 /* might need to make room back there first */
1023 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1024 /* XXX this implementation is very pessimal because the stack
1025 * is repeatedly extended for every set of items. Is possible
1026 * to do this without any stack extension or copying at all
1027 * by maintaining a separate list over which the map iterates
1028 * (like foreach does). --gsar */
1030 /* everything in the stack after the destination list moves
1031 * towards the end the stack by the amount of room needed */
1032 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1034 /* items to shift up (accounting for the moved source pointer) */
1035 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1037 /* This optimization is by Ben Tilly and it does
1038 * things differently from what Sarathy (gsar)
1039 * is describing. The downside of this optimization is
1040 * that leaves "holes" (uninitialized and hopefully unused areas)
1041 * to the Perl stack, but on the other hand this
1042 * shouldn't be a problem. If Sarathy's idea gets
1043 * implemented, this optimization should become
1044 * irrelevant. --jhi */
1046 shift = count; /* Avoid shifting too often --Ben Tilly */
1050 dst = (SP += shift);
1051 PL_markstack_ptr[-1] += shift;
1052 *PL_markstack_ptr += shift;
1056 /* copy the new items down to the destination list */
1057 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1058 if (gimme == G_ARRAY) {
1059 /* add returned items to the collection (making mortal copies
1060 * if necessary), then clear the current temps stack frame
1061 * *except* for those items. We do this splicing the items
1062 * into the start of the tmps frame (so some items may be on
1063 * the tmps stack twice), then moving PL_tmps_floor above
1064 * them, then freeing the frame. That way, the only tmps that
1065 * accumulate over iterations are the return values for map.
1066 * We have to do to this way so that everything gets correctly
1067 * freed if we die during the map.
1071 /* make space for the slice */
1072 EXTEND_MORTAL(items);
1073 tmpsbase = PL_tmps_floor + 1;
1074 Move(PL_tmps_stack + tmpsbase,
1075 PL_tmps_stack + tmpsbase + items,
1076 PL_tmps_ix - PL_tmps_floor,
1078 PL_tmps_ix += items;
1083 sv = sv_mortalcopy(sv);
1085 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1087 /* clear the stack frame except for the items */
1088 PL_tmps_floor += items;
1090 /* FREETMPS may have cleared the TEMP flag on some of the items */
1093 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1096 /* scalar context: we don't care about which values map returns
1097 * (we use undef here). And so we certainly don't want to do mortal
1098 * copies of meaningless values. */
1099 while (items-- > 0) {
1101 *dst-- = &PL_sv_undef;
1109 LEAVE_with_name("grep_item"); /* exit inner scope */
1112 if (PL_markstack_ptr[-1] > TOPMARK) {
1114 (void)POPMARK; /* pop top */
1115 LEAVE_with_name("grep"); /* exit outer scope */
1116 (void)POPMARK; /* pop src */
1117 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1118 (void)POPMARK; /* pop dst */
1119 SP = PL_stack_base + POPMARK; /* pop original mark */
1120 if (gimme == G_SCALAR) {
1124 else if (gimme == G_ARRAY)
1131 ENTER_with_name("grep_item"); /* enter inner scope */
1134 /* set $_ to the new source item */
1135 src = PL_stack_base[PL_markstack_ptr[-1]];
1136 if (SvPADTMP(src)) {
1137 src = sv_mortalcopy(src);
1142 RETURNOP(cLOGOP->op_other);
1151 if (GIMME_V == G_ARRAY)
1154 if (SvTRUE_NN(targ))
1155 return cLOGOP->op_other;
1164 if (GIMME_V == G_ARRAY) {
1165 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1169 SV * const targ = PAD_SV(PL_op->op_targ);
1172 if (PL_op->op_private & OPpFLIP_LINENUM) {
1173 if (GvIO(PL_last_in_gv)) {
1174 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1177 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1179 flip = SvIV(sv) == SvIV(GvSV(gv));
1182 flip = SvTRUE_NN(sv);
1185 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1186 if (PL_op->op_flags & OPf_SPECIAL) {
1194 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1203 /* This code tries to decide if "$left .. $right" should use the
1204 magical string increment, or if the range is numeric. Initially,
1205 an exception was made for *any* string beginning with "0" (see
1206 [#18165], AMS 20021031), but now that is only applied when the
1207 string's length is also >1 - see the rules now documented in
1210 #define RANGE_IS_NUMERIC(left,right) ( \
1211 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1212 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1213 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1214 looks_like_number(left)) && SvPOKp(left) \
1215 && !(*SvPVX_const(left) == '0' && SvCUR(left)>1 ) )) \
1216 && (!SvOK(right) || looks_like_number(right))))
1222 if (GIMME_V == G_ARRAY) {
1228 if (RANGE_IS_NUMERIC(left,right)) {
1230 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1231 (SvOK(right) && (SvIOK(right)
1232 ? SvIsUV(right) && SvUV(right) > IV_MAX
1233 : SvNV_nomg(right) > IV_MAX)))
1234 DIE(aTHX_ "Range iterator outside integer range");
1235 i = SvIV_nomg(left);
1236 j = SvIV_nomg(right);
1238 /* Dance carefully around signed max. */
1239 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1242 /* The wraparound of signed integers is undefined
1243 * behavior, but here we aim for count >=1, and
1244 * negative count is just wrong. */
1246 #if IVSIZE > Size_t_size
1253 Perl_croak(aTHX_ "Out of memory during list extend");
1260 SV * const sv = sv_2mortal(newSViv(i));
1262 if (n) /* avoid incrementing above IV_MAX */
1268 const char * const lpv = SvPV_nomg_const(left, llen);
1269 const char * const tmps = SvPV_nomg_const(right, len);
1271 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1272 if (DO_UTF8(right) && IN_UNI_8_BIT)
1273 len = sv_len_utf8_nomg(right);
1274 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1276 if (strEQ(SvPVX_const(sv),tmps))
1278 sv = sv_2mortal(newSVsv(sv));
1285 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1289 if (PL_op->op_private & OPpFLIP_LINENUM) {
1290 if (GvIO(PL_last_in_gv)) {
1291 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1294 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1295 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1299 flop = SvTRUE_NN(sv);
1303 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1304 sv_catpvs(targ, "E0");
1314 static const char * const context_name[] = {
1316 NULL, /* CXt_WHEN never actually needs "block" */
1317 NULL, /* CXt_BLOCK never actually needs "block" */
1318 NULL, /* CXt_GIVEN never actually needs "block" */
1319 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1320 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1321 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1322 NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1323 NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1331 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1335 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1337 for (i = cxstack_ix; i >= 0; i--) {
1338 const PERL_CONTEXT * const cx = &cxstack[i];
1339 switch (CxTYPE(cx)) {
1345 /* diag_listed_as: Exiting subroutine via %s */
1346 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1347 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1348 if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1351 case CXt_LOOP_PLAIN:
1352 case CXt_LOOP_LAZYIV:
1353 case CXt_LOOP_LAZYSV:
1357 STRLEN cx_label_len = 0;
1358 U32 cx_label_flags = 0;
1359 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1361 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1364 (const U8*)cx_label, cx_label_len,
1365 (const U8*)label, len) == 0)
1367 (const U8*)label, len,
1368 (const U8*)cx_label, cx_label_len) == 0)
1369 : (len == cx_label_len && ((cx_label == label)
1370 || memEQ(cx_label, label, len))) )) {
1371 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1372 (long)i, cx_label));
1375 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1386 Perl_dowantarray(pTHX)
1388 const U8 gimme = block_gimme();
1389 return (gimme == G_VOID) ? G_SCALAR : gimme;
1392 /* note that this function has mostly been superseded by Perl_gimme_V */
1395 Perl_block_gimme(pTHX)
1397 const I32 cxix = dopopto_cursub();
1402 gimme = (cxstack[cxix].blk_gimme & G_WANT);
1404 Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1410 Perl_is_lvalue_sub(pTHX)
1412 const I32 cxix = dopopto_cursub();
1413 assert(cxix >= 0); /* We should only be called from inside subs */
1415 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1416 return CxLVAL(cxstack + cxix);
1421 /* only used by cx_pushsub() */
1423 Perl_was_lvalue_sub(pTHX)
1425 const I32 cxix = dopoptosub(cxstack_ix-1);
1426 assert(cxix >= 0); /* We should only be called from inside subs */
1428 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1429 return CxLVAL(cxstack + cxix);
1435 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1439 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1441 PERL_UNUSED_CONTEXT;
1444 for (i = startingblock; i >= 0; i--) {
1445 const PERL_CONTEXT * const cx = &cxstk[i];
1446 switch (CxTYPE(cx)) {
1450 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1451 * twice; the first for the normal foo() call, and the second
1452 * for a faked up re-entry into the sub to execute the
1453 * code block. Hide this faked entry from the world. */
1454 if (cx->cx_type & CXp_SUB_RE_FAKE)
1459 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1467 S_dopoptoeval(pTHX_ I32 startingblock)
1470 for (i = startingblock; i >= 0; i--) {
1471 const PERL_CONTEXT *cx = &cxstack[i];
1472 switch (CxTYPE(cx)) {
1476 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1484 S_dopoptoloop(pTHX_ I32 startingblock)
1487 for (i = startingblock; i >= 0; i--) {
1488 const PERL_CONTEXT * const cx = &cxstack[i];
1489 switch (CxTYPE(cx)) {
1495 /* diag_listed_as: Exiting subroutine via %s */
1496 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1497 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1498 if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1501 case CXt_LOOP_PLAIN:
1502 case CXt_LOOP_LAZYIV:
1503 case CXt_LOOP_LAZYSV:
1506 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1513 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1516 S_dopoptogivenfor(pTHX_ I32 startingblock)
1519 for (i = startingblock; i >= 0; i--) {
1520 const PERL_CONTEXT *cx = &cxstack[i];
1521 switch (CxTYPE(cx)) {
1525 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1527 case CXt_LOOP_PLAIN:
1528 assert(!(cx->cx_type & CXp_FOR_DEF));
1530 case CXt_LOOP_LAZYIV:
1531 case CXt_LOOP_LAZYSV:
1534 if (cx->cx_type & CXp_FOR_DEF) {
1535 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1544 S_dopoptowhen(pTHX_ I32 startingblock)
1547 for (i = startingblock; i >= 0; i--) {
1548 const PERL_CONTEXT *cx = &cxstack[i];
1549 switch (CxTYPE(cx)) {
1553 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1560 /* dounwind(): pop all contexts above (but not including) cxix.
1561 * Note that it clears the savestack frame associated with each popped
1562 * context entry, but doesn't free any temps.
1563 * It does a cx_popblock() of the last frame that it pops, and leaves
1564 * cxstack_ix equal to cxix.
1568 Perl_dounwind(pTHX_ I32 cxix)
1570 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1573 while (cxstack_ix > cxix) {
1574 PERL_CONTEXT *cx = CX_CUR();
1576 CX_DEBUG(cx, "UNWIND");
1577 /* Note: we don't need to restore the base context info till the end. */
1581 switch (CxTYPE(cx)) {
1584 /* CXt_SUBST is not a block context type, so skip the
1585 * cx_popblock(cx) below */
1586 if (cxstack_ix == cxix + 1) {
1597 case CXt_LOOP_PLAIN:
1598 case CXt_LOOP_LAZYIV:
1599 case CXt_LOOP_LAZYSV:
1612 /* these two don't have a POPFOO() */
1618 if (cxstack_ix == cxix + 1) {
1627 Perl_qerror(pTHX_ SV *err)
1629 PERL_ARGS_ASSERT_QERROR;
1632 if (PL_in_eval & EVAL_KEEPERR) {
1633 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1637 sv_catsv(ERRSV, err);
1640 sv_catsv(PL_errors, err);
1642 Perl_warn(aTHX_ "%" SVf, SVfARG(err));
1644 ++PL_parser->error_count;
1649 /* pop a CXt_EVAL context and in addition, if it was a require then
1651 * 0: do nothing extra;
1652 * 1: undef $INC{$name}; croak "$name did not return a true value";
1653 * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1657 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1659 SV *namesv = NULL; /* init to avoid dumb compiler warning */
1663 do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1665 /* keep namesv alive after cx_popeval() */
1666 namesv = cx->blk_eval.old_namesv;
1667 cx->blk_eval.old_namesv = NULL;
1676 HV *inc_hv = GvHVn(PL_incgv);
1677 I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv);
1678 const char *key = SvPVX_const(namesv);
1681 (void)hv_delete(inc_hv, key, klen, G_DISCARD);
1682 fmt = "%" SVf " did not return a true value";
1686 (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0);
1687 fmt = "%" SVf "Compilation failed in require";
1689 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1692 Perl_croak(aTHX_ fmt, SVfARG(errsv));
1697 /* die_unwind(): this is the final destination for the various croak()
1698 * functions. If we're in an eval, unwind the context and other stacks
1699 * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1700 * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1701 * to is a require the exception will be rethrown, as requires don't
1702 * actually trap exceptions.
1706 Perl_die_unwind(pTHX_ SV *msv)
1709 U8 in_eval = PL_in_eval;
1710 PERL_ARGS_ASSERT_DIE_UNWIND;
1715 /* We need to keep this SV alive through all the stack unwinding
1716 * and FREETMPSing below, while ensuing that it doesn't leak
1717 * if we call out to something which then dies (e.g. sub STORE{die}
1718 * when unlocalising a tied var). So we do a dance with
1719 * mortalising and SAVEFREEing.
1721 sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1724 * Historically, perl used to set ERRSV ($@) early in the die
1725 * process and rely on it not getting clobbered during unwinding.
1726 * That sucked, because it was liable to get clobbered, so the
1727 * setting of ERRSV used to emit the exception from eval{} has
1728 * been moved to much later, after unwinding (see just before
1729 * JMPENV_JUMP below). However, some modules were relying on the
1730 * early setting, by examining $@ during unwinding to use it as
1731 * a flag indicating whether the current unwinding was caused by
1732 * an exception. It was never a reliable flag for that purpose,
1733 * being totally open to false positives even without actual
1734 * clobberage, but was useful enough for production code to
1735 * semantically rely on it.
1737 * We'd like to have a proper introspective interface that
1738 * explicitly describes the reason for whatever unwinding
1739 * operations are currently in progress, so that those modules
1740 * work reliably and $@ isn't further overloaded. But we don't
1741 * have one yet. In its absence, as a stopgap measure, ERRSV is
1742 * now *additionally* set here, before unwinding, to serve as the
1743 * (unreliable) flag that it used to.
1745 * This behaviour is temporary, and should be removed when a
1746 * proper way to detect exceptional unwinding has been developed.
1747 * As of 2010-12, the authors of modules relying on the hack
1748 * are aware of the issue, because the modules failed on
1749 * perls 5.13.{1..7} which had late setting of $@ without this
1750 * early-setting hack.
1752 if (!(in_eval & EVAL_KEEPERR)) {
1753 /* remove any read-only/magic from the SV, so we don't
1754 get infinite recursion when setting ERRSV */
1756 sv_setsv_flags(ERRSV, exceptsv,
1757 (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
1760 if (in_eval & EVAL_KEEPERR) {
1761 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1765 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1766 && PL_curstackinfo->si_prev)
1776 JMPENV *restartjmpenv;
1779 if (cxix < cxstack_ix)
1783 assert(CxTYPE(cx) == CXt_EVAL);
1785 /* return false to the caller of eval */
1786 oldsp = PL_stack_base + cx->blk_oldsp;
1787 gimme = cx->blk_gimme;
1788 if (gimme == G_SCALAR)
1789 *++oldsp = &PL_sv_undef;
1790 PL_stack_sp = oldsp;
1792 restartjmpenv = cx->blk_eval.cur_top_env;
1793 restartop = cx->blk_eval.retop;
1795 /* We need a FREETMPS here to avoid late-called destructors
1796 * clobbering $@ *after* we set it below, e.g.
1797 * sub DESTROY { eval { die "X" } }
1798 * eval { my $x = bless []; die $x = 0, "Y" };
1800 * Here the clearing of the $x ref mortalises the anon array,
1801 * which needs to be freed *before* $& is set to "Y",
1802 * otherwise it gets overwritten with "X".
1804 * However, the FREETMPS will clobber exceptsv, so preserve it
1805 * on the savestack for now.
1807 SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv));
1809 /* now we're about to pop the savestack, so re-mortalise it */
1810 sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1812 /* Note that unlike pp_entereval, pp_require isn't supposed to
1813 * trap errors. So if we're a require, after we pop the
1814 * CXt_EVAL that pp_require pushed, rethrow the error with
1815 * croak(exceptsv). This is all handled by the call below when
1818 S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
1820 if (!(in_eval & EVAL_KEEPERR)) {
1822 sv_setsv(ERRSV, exceptsv);
1824 PL_restartjmpenv = restartjmpenv;
1825 PL_restartop = restartop;
1827 NOT_REACHED; /* NOTREACHED */
1831 write_to_stderr(exceptsv);
1833 NOT_REACHED; /* NOTREACHED */
1839 if (SvTRUE_NN(left) != SvTRUE_NN(right))
1847 =head1 CV Manipulation Functions
1849 =for apidoc caller_cx
1851 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1852 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1853 information returned to Perl by C<caller>. Note that XSUBs don't get a
1854 stack frame, so C<caller_cx(0, NULL)> will return information for the
1855 immediately-surrounding Perl code.
1857 This function skips over the automatic calls to C<&DB::sub> made on the
1858 behalf of the debugger. If the stack frame requested was a sub called by
1859 C<DB::sub>, the return value will be the frame for the call to
1860 C<DB::sub>, since that has the correct line number/etc. for the call
1861 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1862 frame for the sub call itself.
1867 const PERL_CONTEXT *
1868 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1870 I32 cxix = dopopto_cursub();
1871 const PERL_CONTEXT *cx;
1872 const PERL_CONTEXT *ccstack = cxstack;
1873 const PERL_SI *top_si = PL_curstackinfo;
1876 /* we may be in a higher stacklevel, so dig down deeper */
1877 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1878 top_si = top_si->si_prev;
1879 ccstack = top_si->si_cxstack;
1880 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1884 /* caller() should not report the automatic calls to &DB::sub */
1885 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1886 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1890 cxix = dopoptosub_at(ccstack, cxix - 1);
1893 cx = &ccstack[cxix];
1894 if (dbcxp) *dbcxp = cx;
1896 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1897 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1898 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1899 field below is defined for any cx. */
1900 /* caller() should not report the automatic calls to &DB::sub */
1901 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1902 cx = &ccstack[dbcxix];
1911 const PERL_CONTEXT *cx;
1912 const PERL_CONTEXT *dbcx;
1914 const HEK *stash_hek;
1916 bool has_arg = MAXARG && TOPs;
1925 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1927 if (gimme != G_ARRAY) {
1934 CX_DEBUG(cx, "CALLER");
1935 assert(CopSTASH(cx->blk_oldcop));
1936 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1937 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1939 if (gimme != G_ARRAY) {
1942 PUSHs(&PL_sv_undef);
1945 sv_sethek(TARG, stash_hek);
1954 PUSHs(&PL_sv_undef);
1957 sv_sethek(TARG, stash_hek);
1960 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1961 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1962 cx->blk_sub.retop, TRUE);
1964 lcop = cx->blk_oldcop;
1965 mPUSHu(CopLINE(lcop));
1968 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1969 /* So is ccstack[dbcxix]. */
1970 if (CvHASGV(dbcx->blk_sub.cv)) {
1971 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1972 PUSHs(boolSV(CxHASARGS(cx)));
1975 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1976 PUSHs(boolSV(CxHASARGS(cx)));
1980 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1983 gimme = cx->blk_gimme;
1984 if (gimme == G_VOID)
1985 PUSHs(&PL_sv_undef);
1987 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1988 if (CxTYPE(cx) == CXt_EVAL) {
1990 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1991 SV *cur_text = cx->blk_eval.cur_text;
1992 if (SvCUR(cur_text) >= 2) {
1993 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1994 SvUTF8(cur_text)|SVs_TEMP));
1997 /* I think this is will always be "", but be sure */
1998 PUSHs(sv_2mortal(newSVsv(cur_text)));
2004 else if (cx->blk_eval.old_namesv) {
2005 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
2008 /* eval BLOCK (try blocks have old_namesv == 0) */
2010 PUSHs(&PL_sv_undef);
2011 PUSHs(&PL_sv_undef);
2015 PUSHs(&PL_sv_undef);
2016 PUSHs(&PL_sv_undef);
2018 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
2019 && CopSTASH_eq(PL_curcop, PL_debstash))
2021 /* slot 0 of the pad contains the original @_ */
2022 AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
2023 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2024 cx->blk_sub.olddepth+1]))[0]);
2025 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
2027 Perl_init_dbargs(aTHX);
2029 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
2030 av_extend(PL_dbargs, AvFILLp(ary) + off);
2031 if (AvFILLp(ary) + 1 + off)
2032 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
2033 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
2035 mPUSHi(CopHINTS_get(cx->blk_oldcop));
2038 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
2040 if (old_warnings == pWARN_NONE)
2041 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
2042 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
2043 mask = &PL_sv_undef ;
2044 else if (old_warnings == pWARN_ALL ||
2045 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
2046 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
2049 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
2053 PUSHs(cx->blk_oldcop->cop_hints_hash ?
2054 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2064 if (MAXARG < 1 || (!TOPs && !POPs)) {
2066 tmps = NULL, len = 0;
2069 tmps = SvPVx_const(POPs, len);
2070 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
2075 /* like pp_nextstate, but used instead when the debugger is active */
2079 PL_curcop = (COP*)PL_op;
2080 TAINT_NOT; /* Each statement is presumed innocent */
2081 PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
2086 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2087 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2091 const U8 gimme = G_ARRAY;
2092 GV * const gv = PL_DBgv;
2095 if (gv && isGV_with_GP(gv))
2098 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2099 DIE(aTHX_ "No DB::DB routine defined");
2101 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2102 /* don't do recursive DB::DB call */
2112 (void)(*CvXSUB(cv))(aTHX_ cv);
2118 cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
2119 cx_pushsub(cx, cv, PL_op->op_next, 0);
2120 /* OP_DBSTATE's op_private holds hint bits rather than
2121 * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2122 * any CxLVAL() flags that have now been mis-calculated */
2129 if (CvDEPTH(cv) >= 2)
2130 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2131 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2132 RETURNOP(CvSTART(cv));
2144 (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2156 assert(CxTYPE(cx) == CXt_BLOCK);
2158 if (PL_op->op_flags & OPf_SPECIAL)
2159 /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */
2160 cx->blk_oldpm = PL_curpm;
2162 oldsp = PL_stack_base + cx->blk_oldsp;
2163 gimme = cx->blk_gimme;
2165 if (gimme == G_VOID)
2166 PL_stack_sp = oldsp;
2168 leave_adjust_stacks(oldsp, oldsp, gimme,
2169 PL_op->op_private & OPpLVALUE ? 3 : 1);
2179 S_outside_integer(pTHX_ SV *sv)
2182 const NV nv = SvNV_nomg(sv);
2183 if (Perl_isinfnan(nv))
2185 #ifdef NV_PRESERVES_UV
2186 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2189 if (nv <= (NV)IV_MIN)
2192 ((nv > (NV)UV_MAX ||
2193 SvUV_nomg(sv) > (UV)IV_MAX)))
2204 const U8 gimme = GIMME_V;
2205 void *itervarp; /* GV or pad slot of the iteration variable */
2206 SV *itersave; /* the old var in the iterator var slot */
2209 if (PL_op->op_targ) { /* "my" variable */
2210 itervarp = &PAD_SVl(PL_op->op_targ);
2211 itersave = *(SV**)itervarp;
2213 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2214 /* the SV currently in the pad slot is never live during
2215 * iteration (the slot is always aliased to one of the items)
2216 * so it's always stale */
2217 SvPADSTALE_on(itersave);
2219 SvREFCNT_inc_simple_void_NN(itersave);
2220 cxflags = CXp_FOR_PAD;
2223 SV * const sv = POPs;
2224 itervarp = (void *)sv;
2225 if (LIKELY(isGV(sv))) { /* symbol table variable */
2226 itersave = GvSV(sv);
2227 SvREFCNT_inc_simple_void(itersave);
2228 cxflags = CXp_FOR_GV;
2229 if (PL_op->op_private & OPpITER_DEF)
2230 cxflags |= CXp_FOR_DEF;
2232 else { /* LV ref: for \$foo (...) */
2233 assert(SvTYPE(sv) == SVt_PVMG);
2234 assert(SvMAGIC(sv));
2235 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2237 cxflags = CXp_FOR_LVREF;
2240 /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2241 assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2243 /* Note that this context is initially set as CXt_NULL. Further on
2244 * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2245 * there mustn't be anything in the blk_loop substruct that requires
2246 * freeing or undoing, in case we die in the meantime. And vice-versa.
2248 cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2249 cx_pushloop_for(cx, itervarp, itersave);
2251 if (PL_op->op_flags & OPf_STACKED) {
2252 /* OPf_STACKED implies either a single array: for(@), with a
2253 * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2255 SV *maybe_ary = POPs;
2256 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2259 SV * const right = maybe_ary;
2260 if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2261 DIE(aTHX_ "Assigned value is not a reference");
2264 if (RANGE_IS_NUMERIC(sv,right)) {
2265 cx->cx_type |= CXt_LOOP_LAZYIV;
2266 if (S_outside_integer(aTHX_ sv) ||
2267 S_outside_integer(aTHX_ right))
2268 DIE(aTHX_ "Range iterator outside integer range");
2269 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2270 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2273 cx->cx_type |= CXt_LOOP_LAZYSV;
2274 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2275 cx->blk_loop.state_u.lazysv.end = right;
2276 SvREFCNT_inc_simple_void_NN(right);
2277 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2278 /* This will do the upgrade to SVt_PV, and warn if the value
2279 is uninitialised. */
2280 (void) SvPV_nolen_const(right);
2281 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2282 to replace !SvOK() with a pointer to "". */
2284 SvREFCNT_dec(right);
2285 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2289 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2290 /* for (@array) {} */
2291 cx->cx_type |= CXt_LOOP_ARY;
2292 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2293 SvREFCNT_inc_simple_void_NN(maybe_ary);
2294 cx->blk_loop.state_u.ary.ix =
2295 (PL_op->op_private & OPpITER_REVERSED) ?
2296 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2299 /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
2301 else { /* iterating over items on the stack */
2302 cx->cx_type |= CXt_LOOP_LIST;
2303 cx->blk_oldsp = SP - PL_stack_base;
2304 cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2305 cx->blk_loop.state_u.stack.ix =
2306 (PL_op->op_private & OPpITER_REVERSED)
2308 : cx->blk_loop.state_u.stack.basesp;
2309 /* pre-extend stack so pp_iter doesn't have to check every time
2310 * it pushes yes/no */
2320 const U8 gimme = GIMME_V;
2322 cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2323 cx_pushloop_plain(cx);
2336 assert(CxTYPE_is_LOOP(cx));
2337 oldsp = PL_stack_base + cx->blk_oldsp;
2338 base = CxTYPE(cx) == CXt_LOOP_LIST
2339 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2341 gimme = cx->blk_gimme;
2343 if (gimme == G_VOID)
2346 leave_adjust_stacks(oldsp, base, gimme,
2347 PL_op->op_private & OPpLVALUE ? 3 : 1);
2350 cx_poploop(cx); /* Stack values are safe: release loop vars ... */
2358 /* This duplicates most of pp_leavesub, but with additional code to handle
2359 * return args in lvalue context. It was forked from pp_leavesub to
2360 * avoid slowing down that function any further.
2362 * Any changes made to this function may need to be copied to pp_leavesub
2365 * also tail-called by pp_return
2376 assert(CxTYPE(cx) == CXt_SUB);
2378 if (CxMULTICALL(cx)) {
2379 /* entry zero of a stack is always PL_sv_undef, which
2380 * simplifies converting a '()' return into undef in scalar context */
2381 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2385 gimme = cx->blk_gimme;
2386 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2388 if (gimme == G_VOID)
2389 PL_stack_sp = oldsp;
2391 U8 lval = CxLVAL(cx);
2392 bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2393 const char *what = NULL;
2395 if (gimme == G_SCALAR) {
2397 /* check for bad return arg */
2398 if (oldsp < PL_stack_sp) {
2399 SV *sv = *PL_stack_sp;
2400 if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2402 SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2403 : "a readonly value" : "a temporary";
2408 /* sub:lvalue{} will take us here. */
2413 "Can't return %s from lvalue subroutine", what);
2417 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2419 if (lval & OPpDEREF) {
2420 /* lval_sub()->{...} and similar */
2424 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2430 assert(gimme == G_ARRAY);
2431 assert (!(lval & OPpDEREF));
2434 /* scan for bad return args */
2436 for (p = PL_stack_sp; p > oldsp; p--) {
2438 /* the PL_sv_undef exception is to allow things like
2439 * this to work, where PL_sv_undef acts as 'skip'
2440 * placeholder on the LHS of list assigns:
2441 * sub foo :lvalue { undef }
2442 * ($a, undef, foo(), $b) = 1..4;
2444 if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2446 /* Might be flattened array after $#array = */
2447 what = SvREADONLY(sv)
2448 ? "a readonly value" : "a temporary";
2454 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2459 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
2461 retop = cx->blk_sub.retop;
2472 const I32 cxix = dopopto_cursub();
2474 assert(cxstack_ix >= 0);
2475 if (cxix < cxstack_ix) {
2477 if (!( PL_curstackinfo->si_type == PERLSI_SORT
2478 || ( PL_curstackinfo->si_type == PERLSI_MULTICALL
2479 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2482 DIE(aTHX_ "Can't return outside a subroutine");
2484 * a sort block, which is a CXt_NULL not a CXt_SUB;
2485 * or a /(?{...})/ block.
2486 * Handle specially. */
2487 assert(CxTYPE(&cxstack[0]) == CXt_NULL
2488 || ( CxTYPE(&cxstack[0]) == CXt_SUB
2489 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2490 if (cxstack_ix > 0) {
2491 /* See comment below about context popping. Since we know
2492 * we're scalar and not lvalue, we can preserve the return
2493 * value in a simpler fashion than there. */
2495 assert(cxstack[0].blk_gimme == G_SCALAR);
2496 if ( (sp != PL_stack_base)
2497 && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2499 *SP = sv_mortalcopy(sv);
2502 /* caller responsible for popping cxstack[0] */
2506 /* There are contexts that need popping. Doing this may free the
2507 * return value(s), so preserve them first: e.g. popping the plain
2508 * loop here would free $x:
2509 * sub f { { my $x = 1; return $x } }
2510 * We may also need to shift the args down; for example,
2511 * for (1,2) { return 3,4 }
2512 * leaves 1,2,3,4 on the stack. Both these actions will be done by
2513 * leave_adjust_stacks(), along with freeing any temps. Note that
2514 * whoever we tail-call (e.g. pp_leaveeval) will also call
2515 * leave_adjust_stacks(); however, the second call is likely to
2516 * just see a bunch of SvTEMPs with a ref count of 1, and so just
2517 * pass them through, rather than copying them again. So this
2518 * isn't as inefficient as it sounds.
2520 cx = &cxstack[cxix];
2522 if (cx->blk_gimme != G_VOID)
2523 leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2525 CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2529 cx = &cxstack[cxix]; /* CX stack may have been realloced */
2532 /* Like in the branch above, we need to handle any extra junk on
2533 * the stack. But because we're not also popping extra contexts, we
2534 * don't have to worry about prematurely freeing args. So we just
2535 * need to do the bare minimum to handle junk, and leave the main
2536 * arg processing in the function we tail call, e.g. pp_leavesub.
2537 * In list context we have to splice out the junk; in scalar
2538 * context we can leave as-is (pp_leavesub will later return the
2539 * top stack element). But for an empty arg list, e.g.
2540 * for (1,2) { return }
2541 * we need to set sp = oldsp so that pp_leavesub knows to push
2542 * &PL_sv_undef onto the stack.
2545 cx = &cxstack[cxix];
2546 oldsp = PL_stack_base + cx->blk_oldsp;
2547 if (oldsp != MARK) {
2548 SSize_t nargs = SP - MARK;
2550 if (cx->blk_gimme == G_ARRAY) {
2551 /* shift return args to base of call stack frame */
2552 Move(MARK + 1, oldsp + 1, nargs, SV*);
2553 PL_stack_sp = oldsp + nargs;
2557 PL_stack_sp = oldsp;
2561 /* fall through to a normal exit */
2562 switch (CxTYPE(cx)) {
2564 return CxTRYBLOCK(cx)
2565 ? Perl_pp_leavetry(aTHX)
2566 : Perl_pp_leaveeval(aTHX);
2568 return CvLVALUE(cx->blk_sub.cv)
2569 ? Perl_pp_leavesublv(aTHX)
2570 : Perl_pp_leavesub(aTHX);
2572 return Perl_pp_leavewrite(aTHX);
2574 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2578 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2580 static PERL_CONTEXT *
2584 if (PL_op->op_flags & OPf_SPECIAL) {
2585 cxix = dopoptoloop(cxstack_ix);
2587 /* diag_listed_as: Can't "last" outside a loop block */
2588 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2594 const char * const label =
2595 PL_op->op_flags & OPf_STACKED
2596 ? SvPV(TOPs,label_len)
2597 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2598 const U32 label_flags =
2599 PL_op->op_flags & OPf_STACKED
2601 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2603 cxix = dopoptolabel(label, label_len, label_flags);
2605 /* diag_listed_as: Label not found for "last %s" */
2606 Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"",
2608 SVfARG(PL_op->op_flags & OPf_STACKED
2609 && !SvGMAGICAL(TOPp1s)
2611 : newSVpvn_flags(label,
2613 label_flags | SVs_TEMP)));
2615 if (cxix < cxstack_ix)
2617 return &cxstack[cxix];
2626 cx = S_unwind_loop(aTHX);
2628 assert(CxTYPE_is_LOOP(cx));
2629 PL_stack_sp = PL_stack_base
2630 + (CxTYPE(cx) == CXt_LOOP_LIST
2631 ? cx->blk_loop.state_u.stack.basesp
2637 /* Stack values are safe: */
2639 cx_poploop(cx); /* release loop vars ... */
2641 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2651 /* if not a bare 'next' in the main scope, search for it */
2653 if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
2654 cx = S_unwind_loop(aTHX);
2657 PL_curcop = cx->blk_oldcop;
2659 return (cx)->blk_loop.my_op->op_nextop;
2664 PERL_CONTEXT *cx = S_unwind_loop(aTHX);
2665 OP* redo_op = cx->blk_loop.my_op->op_redoop;
2667 if (redo_op->op_type == OP_ENTER) {
2668 /* pop one less context to avoid $x being freed in while (my $x..) */
2671 assert(CxTYPE(cx) == CXt_BLOCK);
2672 redo_op = redo_op->op_next;
2678 PL_curcop = cx->blk_oldcop;
2683 #define UNENTERABLE (OP *)1
2684 #define GOTO_DEPTH 64
2687 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2690 static const char* const too_deep = "Target of goto is too deeply nested";
2692 PERL_ARGS_ASSERT_DOFINDLABEL;
2695 Perl_croak(aTHX_ "%s", too_deep);
2696 if (o->op_type == OP_LEAVE ||
2697 o->op_type == OP_SCOPE ||
2698 o->op_type == OP_LEAVELOOP ||
2699 o->op_type == OP_LEAVESUB ||
2700 o->op_type == OP_LEAVETRY ||
2701 o->op_type == OP_LEAVEGIVEN)
2703 *ops++ = cUNOPo->op_first;
2705 else if (oplimit - opstack < GOTO_DEPTH) {
2706 if (o->op_flags & OPf_KIDS
2707 && cUNOPo->op_first->op_type == OP_PUSHMARK) {
2708 *ops++ = UNENTERABLE;
2710 else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type]
2711 && OP_CLASS(o) != OA_LOGOP
2712 && o->op_type != OP_LINESEQ
2713 && o->op_type != OP_SREFGEN
2714 && o->op_type != OP_ENTEREVAL
2715 && o->op_type != OP_GLOB
2716 && o->op_type != OP_RV2CV) {
2717 OP * const kid = cUNOPo->op_first;
2718 if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid))
2719 *ops++ = UNENTERABLE;
2723 Perl_croak(aTHX_ "%s", too_deep);
2725 if (o->op_flags & OPf_KIDS) {
2727 OP * const kid1 = cUNOPo->op_first;
2728 /* First try all the kids at this level, since that's likeliest. */
2729 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2730 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2731 STRLEN kid_label_len;
2732 U32 kid_label_flags;
2733 const char *kid_label = CopLABEL_len_flags(kCOP,
2734 &kid_label_len, &kid_label_flags);
2736 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2739 (const U8*)kid_label, kid_label_len,
2740 (const U8*)label, len) == 0)
2742 (const U8*)label, len,
2743 (const U8*)kid_label, kid_label_len) == 0)
2744 : ( len == kid_label_len && ((kid_label == label)
2745 || memEQ(kid_label, label, len)))))
2749 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2750 bool first_kid_of_binary = FALSE;
2751 if (kid == PL_lastgotoprobe)
2753 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2756 else if (ops[-1] != UNENTERABLE
2757 && (ops[-1]->op_type == OP_NEXTSTATE ||
2758 ops[-1]->op_type == OP_DBSTATE))
2763 if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) {
2764 first_kid_of_binary = TRUE;
2767 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2769 if (first_kid_of_binary)
2770 *ops++ = UNENTERABLE;
2779 S_check_op_type(pTHX_ OP * const o)
2781 /* Eventually we may want to stack the needed arguments
2782 * for each op. For now, we punt on the hard ones. */
2783 /* XXX This comment seems to me like wishful thinking. --sprout */
2784 if (o == UNENTERABLE)
2786 "Can't \"goto\" into a binary or list expression");
2787 if (o->op_type == OP_ENTERITER)
2789 "Can't \"goto\" into the middle of a foreach loop");
2790 if (o->op_type == OP_ENTERGIVEN)
2792 "Can't \"goto\" into a \"given\" block");
2795 /* also used for: pp_dump() */
2803 OP *enterops[GOTO_DEPTH];
2804 const char *label = NULL;
2805 STRLEN label_len = 0;
2806 U32 label_flags = 0;
2807 const bool do_dump = (PL_op->op_type == OP_DUMP);
2808 static const char* const must_have_label = "goto must have label";
2810 if (PL_op->op_flags & OPf_STACKED) {
2811 /* goto EXPR or goto &foo */
2813 SV * const sv = POPs;
2816 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2817 /* This egregious kludge implements goto &subroutine */
2820 CV *cv = MUTABLE_CV(SvRV(sv));
2821 AV *arg = GvAV(PL_defgv);
2823 while (!CvROOT(cv) && !CvXSUB(cv)) {
2824 const GV * const gv = CvGV(cv);
2828 /* autoloaded stub? */
2829 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2831 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2833 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2834 if (autogv && (cv = GvCV(autogv)))
2836 tmpstr = sv_newmortal();
2837 gv_efullname3(tmpstr, gv, NULL);
2838 DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
2840 DIE(aTHX_ "Goto undefined subroutine");
2843 cxix = dopopto_cursub();
2845 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2847 cx = &cxstack[cxix];
2848 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2849 if (CxTYPE(cx) == CXt_EVAL) {
2851 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2852 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2854 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2855 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2857 else if (CxMULTICALL(cx))
2858 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2860 /* First do some returnish stuff. */
2862 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2864 if (cxix < cxstack_ix) {
2871 /* protect @_ during save stack unwind. */
2873 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
2875 assert(PL_scopestack_ix == cx->blk_oldscopesp);
2878 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2879 /* this is part of cx_popsub_args() */
2880 AV* av = MUTABLE_AV(PAD_SVl(0));
2881 assert(AvARRAY(MUTABLE_AV(
2882 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2883 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2885 /* we are going to donate the current @_ from the old sub
2886 * to the new sub. This first part of the donation puts a
2887 * new empty AV in the pad[0] slot of the old sub,
2888 * unless pad[0] and @_ differ (e.g. if the old sub did
2889 * local *_ = []); in which case clear the old pad[0]
2890 * array in the usual way */
2891 if (av == arg || AvREAL(av))
2892 clear_defarray(av, av == arg);
2893 else CLEAR_ARGARRAY(av);
2896 /* don't restore PL_comppad here. It won't be needed if the
2897 * sub we're going to is non-XS, but restoring it early then
2898 * croaking (e.g. the "Goto undefined subroutine" below)
2899 * means the CX block gets processed again in dounwind,
2900 * but this time with the wrong PL_comppad */
2902 /* A destructor called during LEAVE_SCOPE could have undefined
2903 * our precious cv. See bug #99850. */
2904 if (!CvROOT(cv) && !CvXSUB(cv)) {
2905 const GV * const gv = CvGV(cv);
2907 SV * const tmpstr = sv_newmortal();
2908 gv_efullname3(tmpstr, gv, NULL);
2909 DIE(aTHX_ "Goto undefined subroutine &%" SVf,
2912 DIE(aTHX_ "Goto undefined subroutine");
2915 if (CxTYPE(cx) == CXt_SUB) {
2916 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2917 SvREFCNT_dec_NN(cx->blk_sub.cv);
2920 /* Now do some callish stuff. */
2922 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2923 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2928 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2930 /* put GvAV(defgv) back onto stack */
2932 EXTEND(SP, items+1); /* @_ could have been extended. */
2937 bool r = cBOOL(AvREAL(arg));
2938 for (index=0; index<items; index++)
2942 SV ** const svp = av_fetch(arg, index, 0);
2943 sv = svp ? *svp : NULL;
2945 else sv = AvARRAY(arg)[index];
2947 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2948 : sv_2mortal(newSVavdefelem(arg, index, 1));
2952 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2953 /* Restore old @_ */
2954 CX_POP_SAVEARRAY(cx);
2957 retop = cx->blk_sub.retop;
2958 PL_comppad = cx->blk_sub.prevcomppad;
2959 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2961 /* XS subs don't have a CXt_SUB, so pop it;
2962 * this is a cx_popblock(), less all the stuff we already did
2963 * for cx_topblock() earlier */
2964 PL_curcop = cx->blk_oldcop;
2965 /* this is cx_popsub, less all the stuff we already did */
2966 PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
2970 /* Push a mark for the start of arglist */
2973 (void)(*CvXSUB(cv))(aTHX_ cv);
2978 PADLIST * const padlist = CvPADLIST(cv);
2980 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2982 /* partial unrolled cx_pushsub(): */
2984 cx->blk_sub.cv = cv;
2985 cx->blk_sub.olddepth = CvDEPTH(cv);
2988 SvREFCNT_inc_simple_void_NN(cv);
2989 if (CvDEPTH(cv) > 1) {
2990 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2991 sub_crush_depth(cv);
2992 pad_push(padlist, CvDEPTH(cv));
2994 PL_curcop = cx->blk_oldcop;
2995 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2998 /* second half of donating @_ from the old sub to the
2999 * new sub: abandon the original pad[0] AV in the
3000 * new sub, and replace it with the donated @_.
3001 * pad[0] takes ownership of the extra refcount
3002 * we gave arg earlier */
3004 SvREFCNT_dec(PAD_SVl(0));
3005 PAD_SVl(0) = (SV *)arg;
3006 SvREFCNT_inc_simple_void_NN(arg);
3009 /* GvAV(PL_defgv) might have been modified on scope
3010 exit, so point it at arg again. */
3011 if (arg != GvAV(PL_defgv)) {
3012 AV * const av = GvAV(PL_defgv);
3013 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
3018 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
3019 Perl_get_db_sub(aTHX_ NULL, cv);
3021 CV * const gotocv = get_cvs("DB::goto", 0);
3023 PUSHMARK( PL_stack_sp );
3024 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
3029 retop = CvSTART(cv);
3030 goto putback_return;
3035 label = SvPV_nomg_const(sv, label_len);
3036 label_flags = SvUTF8(sv);
3039 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
3040 /* goto LABEL or dump LABEL */
3041 label = cPVOP->op_pv;
3042 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
3043 label_len = strlen(label);
3045 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
3050 OP *gotoprobe = NULL;
3051 bool leaving_eval = FALSE;
3052 bool in_block = FALSE;
3053 bool pseudo_block = FALSE;
3054 PERL_CONTEXT *last_eval_cx = NULL;
3058 PL_lastgotoprobe = NULL;
3060 for (ix = cxstack_ix; ix >= 0; ix--) {
3062 switch (CxTYPE(cx)) {
3064 leaving_eval = TRUE;
3065 if (!CxTRYBLOCK(cx)) {
3066 gotoprobe = (last_eval_cx ?
3067 last_eval_cx->blk_eval.old_eval_root :
3072 /* else fall through */
3073 case CXt_LOOP_PLAIN:
3074 case CXt_LOOP_LAZYIV:
3075 case CXt_LOOP_LAZYSV:
3080 gotoprobe = OpSIBLING(cx->blk_oldcop);
3086 gotoprobe = OpSIBLING(cx->blk_oldcop);
3089 gotoprobe = PL_main_root;
3092 gotoprobe = CvROOT(cx->blk_sub.cv);
3093 pseudo_block = cBOOL(CxMULTICALL(cx));
3097 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3100 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3101 CxTYPE(cx), (long) ix);
3102 gotoprobe = PL_main_root;
3108 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3109 enterops, enterops + GOTO_DEPTH);
3112 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3113 sibl1->op_type == OP_UNSTACK &&
3114 (sibl2 = OpSIBLING(sibl1)))
3116 retop = dofindlabel(sibl2,
3117 label, label_len, label_flags, enterops,
3118 enterops + GOTO_DEPTH);
3124 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3125 PL_lastgotoprobe = gotoprobe;
3128 DIE(aTHX_ "Can't find label %" UTF8f,
3129 UTF8fARG(label_flags, label_len, label));
3131 /* if we're leaving an eval, check before we pop any frames
3132 that we're not going to punt, otherwise the error
3135 if (leaving_eval && *enterops && enterops[1]) {
3137 for (i = 1; enterops[i]; i++)
3138 S_check_op_type(aTHX_ enterops[i]);
3141 if (*enterops && enterops[1]) {
3142 I32 i = enterops[1] != UNENTERABLE
3143 && enterops[1]->op_type == OP_ENTER && in_block
3147 deprecate("\"goto\" to jump into a construct");
3150 /* pop unwanted frames */
3152 if (ix < cxstack_ix) {
3154 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3160 /* push wanted frames */
3162 if (*enterops && enterops[1]) {
3163 OP * const oldop = PL_op;
3164 ix = enterops[1] != UNENTERABLE
3165 && enterops[1]->op_type == OP_ENTER && in_block
3168 for (; enterops[ix]; ix++) {
3169 PL_op = enterops[ix];
3170 S_check_op_type(aTHX_ PL_op);
3171 DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n",
3173 PL_op->op_ppaddr(aTHX);
3181 if (!retop) retop = PL_main_start;
3183 PL_restartop = retop;
3184 PL_do_undump = TRUE;
3188 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3189 PL_do_undump = FALSE;
3207 anum = 0; (void)POPs;
3213 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3216 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3219 PL_exit_flags |= PERL_EXIT_EXPECTED;
3221 PUSHs(&PL_sv_undef);
3228 S_save_lines(pTHX_ AV *array, SV *sv)
3230 const char *s = SvPVX_const(sv);
3231 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3234 PERL_ARGS_ASSERT_SAVE_LINES;
3236 while (s && s < send) {
3238 SV * const tmpstr = newSV_type(SVt_PVMG);
3240 t = (const char *)memchr(s, '\n', send - s);
3246 sv_setpvn(tmpstr, s, t - s);
3247 av_store(array, line++, tmpstr);
3255 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3257 0 is used as continue inside eval,
3259 3 is used for a die caught by an inner eval - continue inner loop
3261 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3262 establish a local jmpenv to handle exception traps.
3267 S_docatch(pTHX_ Perl_ppaddr_t firstpp)
3270 OP * const oldop = PL_op;
3273 assert(CATCH_GET == TRUE);
3278 PL_op = firstpp(aTHX);
3283 /* die caught by an inner eval - continue inner loop */
3284 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3285 PL_restartjmpenv = NULL;
3286 PL_op = PL_restartop;
3295 NOT_REACHED; /* NOTREACHED */
3304 =for apidoc find_runcv
3306 Locate the CV corresponding to the currently executing sub or eval.
3307 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3308 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3309 entered. (This allows debuggers to eval in the scope of the breakpoint
3310 rather than in the scope of the debugger itself.)
3316 Perl_find_runcv(pTHX_ U32 *db_seqp)
3318 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3321 /* If this becomes part of the API, it might need a better name. */
3323 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3330 PL_curcop == &PL_compiling
3332 : PL_curcop->cop_seq;
3334 for (si = PL_curstackinfo; si; si = si->si_prev) {
3336 for (ix = si->si_cxix; ix >= 0; ix--) {
3337 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3339 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3340 cv = cx->blk_sub.cv;
3341 /* skip DB:: code */
3342 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3343 *db_seqp = cx->blk_oldcop->cop_seq;
3346 if (cx->cx_type & CXp_SUB_RE)
3349 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3350 cv = cx->blk_eval.cv;
3353 case FIND_RUNCV_padid_eq:
3355 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3358 case FIND_RUNCV_level_eq:
3359 if (level++ != arg) continue;
3367 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3371 /* Run yyparse() in a setjmp wrapper. Returns:
3372 * 0: yyparse() successful
3373 * 1: yyparse() failed
3377 S_try_yyparse(pTHX_ int gramtype)
3382 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3386 ret = yyparse(gramtype) ? 1 : 0;
3393 NOT_REACHED; /* NOTREACHED */
3400 /* Compile a require/do or an eval ''.
3402 * outside is the lexically enclosing CV (if any) that invoked us.
3403 * seq is the current COP scope value.
3404 * hh is the saved hints hash, if any.
3406 * Returns a bool indicating whether the compile was successful; if so,
3407 * PL_eval_start contains the first op of the compiled code; otherwise,
3410 * This function is called from two places: pp_require and pp_entereval.
3411 * These can be distinguished by whether PL_op is entereval.
3415 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3418 OP * const saveop = PL_op;
3419 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3420 COP * const oldcurcop = PL_curcop;
3421 bool in_require = (saveop->op_type == OP_REQUIRE);
3425 PL_in_eval = (in_require
3426 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3428 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3429 ? EVAL_RE_REPARSING : 0)));
3433 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3435 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3436 CX_CUR()->blk_eval.cv = evalcv;
3437 CX_CUR()->blk_gimme = gimme;
3439 CvOUTSIDE_SEQ(evalcv) = seq;
3440 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3442 /* set up a scratch pad */
3444 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3445 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3448 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3450 /* make sure we compile in the right package */
3452 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3453 SAVEGENERICSV(PL_curstash);
3454 PL_curstash = (HV *)CopSTASH(PL_curcop);
3455 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3457 SvREFCNT_inc_simple_void(PL_curstash);
3458 save_item(PL_curstname);
3459 sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash));
3462 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3463 SAVESPTR(PL_beginav);
3464 PL_beginav = newAV();
3465 SAVEFREESV(PL_beginav);
3466 SAVESPTR(PL_unitcheckav);
3467 PL_unitcheckav = newAV();
3468 SAVEFREESV(PL_unitcheckav);
3471 ENTER_with_name("evalcomp");
3472 SAVESPTR(PL_compcv);
3475 /* try to compile it */
3477 PL_eval_root = NULL;
3478 PL_curcop = &PL_compiling;
3479 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3480 PL_in_eval |= EVAL_KEEPERR;
3487 hv_clear(GvHV(PL_hintgv));
3490 PL_hints = saveop->op_private & OPpEVAL_COPHH
3491 ? oldcurcop->cop_hints : (U32)saveop->op_targ;
3493 /* making 'use re eval' not be in scope when compiling the
3494 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3495 * infinite recursion when S_has_runtime_code() gives a false
3496 * positive: the second time round, HINT_RE_EVAL isn't set so we
3497 * don't bother calling S_has_runtime_code() */
3498 if (PL_in_eval & EVAL_RE_REPARSING)
3499 PL_hints &= ~HINT_RE_EVAL;
3502 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3503 SvREFCNT_dec(GvHV(PL_hintgv));
3504 GvHV(PL_hintgv) = hh;
3507 SAVECOMPILEWARNINGS();
3509 if (PL_dowarn & G_WARN_ALL_ON)
3510 PL_compiling.cop_warnings = pWARN_ALL ;
3511 else if (PL_dowarn & G_WARN_ALL_OFF)
3512 PL_compiling.cop_warnings = pWARN_NONE ;
3514 PL_compiling.cop_warnings = pWARN_STD ;
3517 PL_compiling.cop_warnings =
3518 DUP_WARNINGS(oldcurcop->cop_warnings);
3519 cophh_free(CopHINTHASH_get(&PL_compiling));
3520 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3521 /* The label, if present, is the first entry on the chain. So rather
3522 than writing a blank label in front of it (which involves an
3523 allocation), just use the next entry in the chain. */
3524 PL_compiling.cop_hints_hash
3525 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3526 /* Check the assumption that this removed the label. */
3527 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3530 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3533 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3535 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3536 * so honour CATCH_GET and trap it here if necessary */
3539 /* compile the code */
3540 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3542 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3547 /* note that if yystatus == 3, then the require/eval died during
3548 * compilation, so the EVAL CX block has already been popped, and
3549 * various vars restored */
3550 if (yystatus != 3) {
3552 op_free(PL_eval_root);
3553 PL_eval_root = NULL;
3555 SP = PL_stack_base + POPMARK; /* pop original mark */
3557 assert(CxTYPE(cx) == CXt_EVAL);
3558 /* pop the CXt_EVAL, and if was a require, croak */
3559 S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
3562 /* die_unwind() re-croaks when in require, having popped the
3563 * require EVAL context. So we should never catch a require
3565 assert(!in_require);
3568 if (!*(SvPV_nolen_const(errsv)))
3569 sv_setpvs(errsv, "Compilation error");
3571 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3576 /* Compilation successful. Now clean up */
3578 LEAVE_with_name("evalcomp");
3580 CopLINE_set(&PL_compiling, 0);
3581 SAVEFREEOP(PL_eval_root);
3582 cv_forget_slab(evalcv);
3584 DEBUG_x(dump_eval());
3586 /* Register with debugger: */
3587 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3588 CV * const cv = get_cvs("DB::postponed", 0);
3592 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3594 call_sv(MUTABLE_SV(cv), G_DISCARD);
3598 if (PL_unitcheckav) {
3599 OP *es = PL_eval_start;
3600 call_list(PL_scopestack_ix, PL_unitcheckav);
3604 CvDEPTH(evalcv) = 1;
3605 SP = PL_stack_base + POPMARK; /* pop original mark */
3606 PL_op = saveop; /* The caller may need it. */
3607 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3613 /* Return NULL if the file doesn't exist or isn't a file;
3614 * else return PerlIO_openn().
3618 S_check_type_and_open(pTHX_ SV *name)
3623 const char *p = SvPV_const(name, len);
3626 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3628 /* checking here captures a reasonable error message when
3629 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3630 * user gets a confusing message about looking for the .pmc file
3631 * rather than for the .pm file so do the check in S_doopen_pm when
3632 * PMC is on instead of here. S_doopen_pm calls this func.
3633 * This check prevents a \0 in @INC causing problems.
3635 #ifdef PERL_DISABLE_PMC
3636 if (!IS_SAFE_PATHNAME(p, len, "require"))
3640 /* on Win32 stat is expensive (it does an open() and close() twice and
3641 a couple other IO calls), the open will fail with a dir on its own with
3642 errno EACCES, so only do a stat to separate a dir from a real EACCES
3643 caused by user perms */
3645 st_rc = PerlLIO_stat(p, &st);
3651 if(S_ISBLK(st.st_mode)) {
3655 else if(S_ISDIR(st.st_mode)) {
3664 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3666 /* EACCES stops the INC search early in pp_require to implement
3667 feature RT #113422 */
3668 if(!retio && errno == EACCES) { /* exists but probably a directory */
3670 st_rc = PerlLIO_stat(p, &st);
3672 if(S_ISDIR(st.st_mode))
3674 else if(S_ISBLK(st.st_mode))
3685 /* doopen_pm(): return the equivalent of PerlIO_openn() on the given name,
3686 * but first check for bad names (\0) and non-files.
3687 * Also if the filename ends in .pm and unless PERL_DISABLE_PMC,
3688 * try loading Foo.pmc first.
3690 #ifndef PERL_DISABLE_PMC
3692 S_doopen_pm(pTHX_ SV *name)
3695 const char *p = SvPV_const(name, namelen);
3697 PERL_ARGS_ASSERT_DOOPEN_PM;
3699 /* check the name before trying for the .pmc name to avoid the
3700 * warning referring to the .pmc which the user probably doesn't
3701 * know or care about
3703 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3706 if (memENDPs(p, namelen, ".pm")) {
3707 SV *const pmcsv = sv_newmortal();
3710 SvSetSV_nosteal(pmcsv,name);
3711 sv_catpvs(pmcsv, "c");
3713 pmcio = check_type_and_open(pmcsv);
3717 return check_type_and_open(name);
3720 # define doopen_pm(name) check_type_and_open(name)
3721 #endif /* !PERL_DISABLE_PMC */
3723 /* require doesn't search in @INC for absolute names, or when the name is
3724 explicitly relative the current directory: i.e. ./, ../ */
3725 PERL_STATIC_INLINE bool
3726 S_path_is_searchable(const char *name)
3728 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3730 if (PERL_FILE_IS_ABSOLUTE(name)
3732 || (*name == '.' && ((name[1] == '/' ||
3733 (name[1] == '.' && name[2] == '/'))
3734 || (name[1] == '\\' ||
3735 ( name[1] == '.' && name[2] == '\\')))
3738 || (*name == '.' && (name[1] == '/' ||
3739 (name[1] == '.' && name[2] == '/')))
3750 /* implement 'require 5.010001' */
3753 S_require_version(pTHX_ SV *sv)
3757 sv = sv_2mortal(new_version(sv));
3758 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3759 upg_version(PL_patchlevel, TRUE);
3760 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3761 if ( vcmp(sv,PL_patchlevel) <= 0 )
3762 DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
3763 SVfARG(sv_2mortal(vnormal(sv))),
3764 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3768 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3771 SV * const req = SvRV(sv);
3772 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3774 /* get the left hand term */
3775 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3777 first = SvIV(*av_fetch(lav,0,0));
3778 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3779 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3780 || av_tindex(lav) > 1 /* FP with > 3 digits */
3781 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3783 DIE(aTHX_ "Perl %" SVf " required--this is only "
3784 "%" SVf ", stopped",
3785 SVfARG(sv_2mortal(vnormal(req))),
3786 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3789 else { /* probably 'use 5.10' or 'use 5.8' */
3793 if (av_tindex(lav)>=1)
3794 second = SvIV(*av_fetch(lav,1,0));
3796 second /= second >= 600 ? 100 : 10;
3797 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3798 (int)first, (int)second);
3799 upg_version(hintsv, TRUE);
3801 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)"
3802 "--this is only %" SVf ", stopped",
3803 SVfARG(sv_2mortal(vnormal(req))),
3804 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3805 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3814 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
3815 * The first form will have already been converted at compile time to
3816 * the second form */
3819 S_require_file(pTHX_ SV *sv)
3829 int vms_unixname = 0;
3832 /* tryname is the actual pathname (with @INC prefix) which was loaded.
3833 * It's stored as a value in %INC, and used for error messages */
3834 const char *tryname = NULL;
3835 SV *namesv = NULL; /* SV equivalent of tryname */
3836 const U8 gimme = GIMME_V;
3837 int filter_has_file = 0;
3838 PerlIO *tryrsfp = NULL;
3839 SV *filter_cache = NULL;
3840 SV *filter_state = NULL;
3841 SV *filter_sub = NULL;
3845 bool path_searchable;
3846 I32 old_savestack_ix;
3847 const bool op_is_require = PL_op->op_type == OP_REQUIRE;
3848 const char *const op_name = op_is_require ? "require" : "do";
3849 SV ** svp_cached = NULL;
3851 assert(op_is_require || PL_op->op_type == OP_DOFILE);
3854 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3855 name = SvPV_nomg_const(sv, len);
3856 if (!(name && len > 0 && *name))
3857 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3860 /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */
3861 if (op_is_require) {
3862 /* can optimize to only perform one single lookup */
3863 svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0);
3864 if ( svp_cached && *svp_cached != &PL_sv_undef ) RETPUSHYES;
3868 if (!IS_SAFE_PATHNAME(name, len, op_name)) {
3869 if (!op_is_require) {
3873 DIE(aTHX_ "Can't locate %s: %s",
3874 pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
3875 NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3878 TAINT_PROPER(op_name);
3880 path_searchable = path_is_searchable(name);
3883 /* The key in the %ENV hash is in the syntax of file passed as the argument
3884 * usually this is in UNIX format, but sometimes in VMS format, which
3885 * can result in a module being pulled in more than once.
3886 * To prevent this, the key must be stored in UNIX format if the VMS
3887 * name can be translated to UNIX.
3891 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3893 unixlen = strlen(unixname);
3899 /* if not VMS or VMS name can not be translated to UNIX, pass it
3902 unixname = (char *) name;
3905 if (op_is_require) {
3906 /* reuse the previous hv_fetch result if possible */
3907 SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3909 if (*svp != &PL_sv_undef)
3912 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3913 "Compilation failed in require", unixname);
3916 /*XXX OPf_KIDS should always be true? -dapm 4/2017 */
3917 if (PL_op->op_flags & OPf_KIDS) {
3918 SVOP * const kid = (SVOP*)cUNOP->op_first;
3920 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3921 /* Make sure that a bareword module name (e.g. ::Foo::Bar)
3922 * doesn't map to a naughty pathname like /Foo/Bar.pm.
3923 * Note that the parser will normally detect such errors
3924 * at compile time before we reach here, but
3925 * Perl_load_module() can fake up an identical optree
3926 * without going near the parser, and being able to put
3927 * anything as the bareword. So we include a duplicate set
3928 * of checks here at runtime.
3930 const STRLEN package_len = len - 3;
3931 const char slashdot[2] = {'/', '.'};
3933 const char backslashdot[2] = {'\\', '.'};
3936 /* Disallow *purported* barewords that map to absolute
3937 filenames, filenames relative to the current or parent
3938 directory, or (*nix) hidden filenames. Also sanity check
3939 that the generated filename ends .pm */
3940 if (!path_searchable || len < 3 || name[0] == '.'
3941 || !memEQs(name + package_len, len - package_len, ".pm"))
3942 DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv);
3943 if (memchr(name, 0, package_len)) {
3944 /* diag_listed_as: Bareword in require contains "%s" */
3945 DIE(aTHX_ "Bareword in require contains \"\\0\"");
3947 if (ninstr(name, name + package_len, slashdot,
3948 slashdot + sizeof(slashdot))) {
3949 /* diag_listed_as: Bareword in require contains "%s" */
3950 DIE(aTHX_ "Bareword in require contains \"/.\"");
3953 if (ninstr(name, name + package_len, backslashdot,
3954 backslashdot + sizeof(backslashdot))) {
3955 /* diag_listed_as: Bareword in require contains "%s" */
3956 DIE(aTHX_ "Bareword in require contains \"\\.\"");
3963 PERL_DTRACE_PROBE_FILE_LOADING(unixname);
3965 /* Try to locate and open a file, possibly using @INC */
3967 /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load
3968 * the file directly rather than via @INC ... */
3969 if (!path_searchable) {
3970 /* At this point, name is SvPVX(sv) */
3972 tryrsfp = doopen_pm(sv);
3975 /* ... but if we fail, still search @INC for code references;
3976 * these are applied even on on-searchable paths (except
3977 * if we got EACESS).
3979 * For searchable paths, just search @INC normally
3981 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3982 AV * const ar = GvAVn(PL_incgv);
3989 namesv = newSV_type(SVt_PV);
3990 for (i = 0; i <= AvFILL(ar); i++) {
3991 SV * const dirsv = *av_fetch(ar, i, TRUE);
3999 if (SvTYPE(SvRV(loader)) == SVt_PVAV
4000 && !SvOBJECT(SvRV(loader)))
4002 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
4006 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
4007 PTR2UV(SvRV(dirsv)), name);
4008 tryname = SvPVX_const(namesv);
4011 if (SvPADTMP(nsv)) {
4012 nsv = sv_newmortal();
4013 SvSetSV_nosteal(nsv,sv);
4016 ENTER_with_name("call_INC");
4024 if (SvGMAGICAL(loader)) {
4025 SV *l = sv_newmortal();
4026 sv_setsv_nomg(l, loader);
4029 if (sv_isobject(loader))
4030 count = call_method("INC", G_ARRAY);
4032 count = call_sv(loader, G_ARRAY);
4042 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
4043 && !isGV_with_GP(SvRV(arg))) {
4044 filter_cache = SvRV(arg);
4051 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
4055 if (isGV_with_GP(arg)) {
4056 IO * const io = GvIO((const GV *)arg);
4061 tryrsfp = IoIFP(io);
4062 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
4063 PerlIO_close(IoOFP(io));
4074 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
4076 SvREFCNT_inc_simple_void_NN(filter_sub);
4079 filter_state = SP[i];
4080 SvREFCNT_inc_simple_void(filter_state);
4084 if (!tryrsfp && (filter_cache || filter_sub)) {
4085 tryrsfp = PerlIO_open(BIT_BUCKET,
4091 /* FREETMPS may free our filter_cache */
4092 SvREFCNT_inc_simple_void(filter_cache);
4096 LEAVE_with_name("call_INC");
4098 /* Now re-mortalize it. */
4099 sv_2mortal(filter_cache);
4101 /* Adjust file name if the hook has set an %INC entry.
4102 This needs to happen after the FREETMPS above. */
4103 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
4105 tryname = SvPV_nolen_const(*svp);
4112 filter_has_file = 0;
4113 filter_cache = NULL;
4115 SvREFCNT_dec_NN(filter_state);
4116 filter_state = NULL;
4119 SvREFCNT_dec_NN(filter_sub);
4123 else if (path_searchable) {
4124 /* match against a plain @INC element (non-searchable
4125 * paths are only matched against refs in @INC) */
4130 dir = SvPV_nomg_const(dirsv, dirlen);
4136 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
4140 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4143 sv_setpv(namesv, unixdir);
4144 sv_catpv(namesv, unixname);
4145 #elif defined(__SYMBIAN32__)
4146 if (PL_origfilename[0] &&
4147 PL_origfilename[1] == ':' &&
4148 !(dir[0] && dir[1] == ':'))
4149 Perl_sv_setpvf(aTHX_ namesv,
4154 Perl_sv_setpvf(aTHX_ namesv,
4158 /* The equivalent of
4159 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4160 but without the need to parse the format string, or
4161 call strlen on either pointer, and with the correct
4162 allocation up front. */
4164 char *tmp = SvGROW(namesv, dirlen + len + 2);
4166 memcpy(tmp, dir, dirlen);
4169 /* Avoid '<dir>//<file>' */
4170 if (!dirlen || *(tmp-1) != '/') {
4173 /* So SvCUR_set reports the correct length below */
4177 /* name came from an SV, so it will have a '\0' at the
4178 end that we can copy as part of this memcpy(). */
4179 memcpy(tmp, name, len + 1);
4181 SvCUR_set(namesv, dirlen + len + 1);
4185 TAINT_PROPER(op_name);
4186 tryname = SvPVX_const(namesv);
4187 tryrsfp = doopen_pm(namesv);
4189 if (tryname[0] == '.' && tryname[1] == '/') {
4191 while (*++tryname == '/') {}
4195 else if (errno == EMFILE || errno == EACCES) {
4196 /* no point in trying other paths if out of handles;
4197 * on the other hand, if we couldn't open one of the
4198 * files, then going on with the search could lead to
4199 * unexpected results; see perl #113422
4208 /* at this point we've ether opened a file (tryrsfp) or set errno */
4210 saved_errno = errno; /* sv_2mortal can realloc things */
4213 /* we failed; croak if require() or return undef if do() */
4214 if (op_is_require) {
4215 if(saved_errno == EMFILE || saved_errno == EACCES) {
4216 /* diag_listed_as: Can't locate %s */
4217 DIE(aTHX_ "Can't locate %s: %s: %s",
4218 name, tryname, Strerror(saved_errno));
4220 if (path_searchable) { /* did we lookup @INC? */
4221 AV * const ar = GvAVn(PL_incgv);
4223 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4224 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4225 for (i = 0; i <= AvFILL(ar); i++) {
4226 sv_catpvs(inc, " ");
4227 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4229 if (memENDPs(name, len, ".pm")) {
4230 const char *e = name + len - (sizeof(".pm") - 1);
4232 bool utf8 = cBOOL(SvUTF8(sv));
4234 /* if the filename, when converted from "Foo/Bar.pm"
4235 * form back to Foo::Bar form, makes a valid
4236 * package name (i.e. parseable by C<require
4237 * Foo::Bar>), then emit a hint.
4239 * this loop is modelled after the one in
4243 if (utf8 && isIDFIRST_utf8_safe(c, e)) {
4245 while (c < e && isIDCONT_utf8_safe(
4246 (const U8*) c, (const U8*) e))
4249 else if (isWORDCHAR_A(*c)) {
4250 while (c < e && isWORDCHAR_A(*c))
4259 if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
4260 sv_catpvs(msg, " (you may need to install the ");
4261 for (c = name; c < e; c++) {
4263 sv_catpvs(msg, "::");
4266 sv_catpvn(msg, c, 1);
4269 sv_catpvs(msg, " module)");
4272 else if (memENDs(name, len, ".h")) {
4273 sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4275 else if (memENDs(name, len, ".ph")) {
4276 sv_catpvs(msg, " (did you run h2ph?)");
4279 /* diag_listed_as: Can't locate %s */
4281 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4285 DIE(aTHX_ "Can't locate %s", name);
4288 #ifdef DEFAULT_INC_EXCLUDES_DOT
4292 /* the complication is to match the logic from doopen_pm() so
4293 * we don't treat do "sda1" as a previously successful "do".
4295 bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED)
4296 && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode)
4297 && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL;
4303 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4304 "do \"%s\" failed, '.' is no longer in @INC; "
4305 "did you mean do \"./%s\"?",
4314 SETERRNO(0, SS_NORMAL);
4316 /* Update %INC. Assume success here to prevent recursive requirement. */
4317 /* name is never assigned to again, so len is still strlen(name) */
4318 /* Check whether a hook in @INC has already filled %INC */
4320 (void)hv_store(GvHVn(PL_incgv),
4321 unixname, unixlen, newSVpv(tryname,0),0);
4323 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4325 (void)hv_store(GvHVn(PL_incgv),
4326 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4329 /* Now parse the file */
4331 old_savestack_ix = PL_savestack_ix;
4332 SAVECOPFILE_FREE(&PL_compiling);
4333 CopFILE_set(&PL_compiling, tryname);
4334 lex_start(NULL, tryrsfp, 0);
4336 if (filter_sub || filter_cache) {
4337 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4338 than hanging another SV from it. In turn, filter_add() optionally
4339 takes the SV to use as the filter (or creates a new SV if passed
4340 NULL), so simply pass in whatever value filter_cache has. */
4341 SV * const fc = filter_cache ? newSV(0) : NULL;
4343 if (fc) sv_copypv(fc, filter_cache);
4344 datasv = filter_add(S_run_user_filter, fc);
4345 IoLINES(datasv) = filter_has_file;
4346 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4347 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4350 /* switch to eval mode */
4352 cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4353 cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4355 SAVECOPLINE(&PL_compiling);
4356 CopLINE_set(&PL_compiling, 0);
4360 if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4363 op = PL_op->op_next;
4365 PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4371 /* also used for: pp_dofile() */
4375 RUN_PP_CATCHABLY(Perl_pp_require);
4382 return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4383 ? S_require_version(aTHX_ sv)
4384 : S_require_file(aTHX_ sv);
4389 /* This is a op added to hold the hints hash for
4390 pp_entereval. The hash can be modified by the code
4391 being eval'ed, so we return a copy instead. */
4396 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4408 char tbuf[TYPE_DIGITS(long) + 12];
4416 I32 old_savestack_ix;
4418 RUN_PP_CATCHABLY(Perl_pp_entereval);
4421 was = PL_breakable_sub_gen;
4422 saved_delete = FALSE;
4426 bytes = PL_op->op_private & OPpEVAL_BYTES;
4428 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4429 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4431 else if (PL_hints & HINT_LOCALIZE_HH || (
4432 PL_op->op_private & OPpEVAL_COPHH
4433 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4435 saved_hh = cop_hints_2hv(PL_curcop, 0);
4436 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4440 /* make sure we've got a plain PV (no overload etc) before testing
4441 * for taint. Making a copy here is probably overkill, but better
4442 * safe than sorry */
4444 const char * const p = SvPV_const(sv, len);
4446 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4447 lex_flags |= LEX_START_COPIED;
4449 if (bytes && SvUTF8(sv))
4450 SvPVbyte_force(sv, len);
4452 else if (bytes && SvUTF8(sv)) {
4453 /* Don't modify someone else's scalar */
4456 (void)sv_2mortal(sv);
4457 SvPVbyte_force(sv,len);
4458 lex_flags |= LEX_START_COPIED;
4461 TAINT_IF(SvTAINTED(sv));
4462 TAINT_PROPER("eval");
4464 old_savestack_ix = PL_savestack_ix;
4466 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4467 ? LEX_IGNORE_UTF8_HINTS
4468 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4472 /* switch to eval mode */
4474 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4475 SV * const temp_sv = sv_newmortal();
4476 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]",
4477 (unsigned long)++PL_evalseq,
4478 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4479 tmpbuf = SvPVX(temp_sv);
4480 len = SvCUR(temp_sv);
4483 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4484 SAVECOPFILE_FREE(&PL_compiling);
4485 CopFILE_set(&PL_compiling, tmpbuf+2);
4486 SAVECOPLINE(&PL_compiling);
4487 CopLINE_set(&PL_compiling, 1);
4488 /* special case: an eval '' executed within the DB package gets lexically
4489 * placed in the first non-DB CV rather than the current CV - this
4490 * allows the debugger to execute code, find lexicals etc, in the
4491 * scope of the code being debugged. Passing &seq gets find_runcv
4492 * to do the dirty work for us */
4493 runcv = find_runcv(&seq);
4496 cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
4497 cx_pusheval(cx, PL_op->op_next, NULL);
4499 /* prepare to compile string */
4501 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4502 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4504 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4505 deleting the eval's FILEGV from the stash before gv_check() runs
4506 (i.e. before run-time proper). To work around the coredump that
4507 ensues, we always turn GvMULTI_on for any globals that were
4508 introduced within evals. See force_ident(). GSAR 96-10-12 */
4509 char *const safestr = savepvn(tmpbuf, len);
4510 SAVEDELETE(PL_defstash, safestr, len);
4511 saved_delete = TRUE;
4516 if (doeval_compile(gimme, runcv, seq, saved_hh)) {
4517 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4518 ? PERLDB_LINE_OR_SAVESRC
4519 : PERLDB_SAVESRC_NOSUBS) {
4520 /* Retain the filegv we created. */
4521 } else if (!saved_delete) {
4522 char *const safestr = savepvn(tmpbuf, len);
4523 SAVEDELETE(PL_defstash, safestr, len);
4525 return PL_eval_start;
4527 /* We have already left the scope set up earlier thanks to the LEAVE
4528 in doeval_compile(). */
4529 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4530 ? PERLDB_LINE_OR_SAVESRC
4531 : PERLDB_SAVESRC_INVALID) {
4532 /* Retain the filegv we created. */
4533 } else if (!saved_delete) {
4534 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4536 return PL_op->op_next;
4541 /* also tail-called by pp_return */
4556 assert(CxTYPE(cx) == CXt_EVAL);
4558 oldsp = PL_stack_base + cx->blk_oldsp;
4559 gimme = cx->blk_gimme;
4561 /* did require return a false value? */
4562 failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE
4563 && !(gimme == G_SCALAR
4564 ? SvTRUE_NN(*PL_stack_sp)
4565 : PL_stack_sp > oldsp);
4567 if (gimme == G_VOID) {
4568 PL_stack_sp = oldsp;
4569 /* free now to avoid late-called destructors clobbering $@ */
4573 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4575 /* the cx_popeval does a leavescope, which frees the optree associated
4576 * with eval, which if it frees the nextstate associated with
4577 * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
4578 * regex when running under 'use re Debug' because it needs PL_curcop
4579 * to get the current hints. So restore it early.
4581 PL_curcop = cx->blk_oldcop;
4583 /* grab this value before cx_popeval restores the old PL_in_eval */
4584 keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4585 retop = cx->blk_eval.retop;
4586 evalcv = cx->blk_eval.cv;
4588 assert(CvDEPTH(evalcv) == 1);
4590 CvDEPTH(evalcv) = 0;
4592 /* pop the CXt_EVAL, and if a require failed, croak */
4593 S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
4601 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4602 close to the related Perl_create_eval_scope. */
4604 Perl_delete_eval_scope(pTHX)
4615 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4616 also needed by Perl_fold_constants. */
4618 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
4621 const U8 gimme = GIMME_V;
4623 cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
4624 PL_stack_sp, PL_savestack_ix);
4625 cx_pusheval(cx, retop, NULL);
4627 PL_in_eval = EVAL_INEVAL;
4628 if (flags & G_KEEPERR)
4629 PL_in_eval |= EVAL_KEEPERR;
4632 if (flags & G_FAKINGEVAL) {
4633 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4639 RUN_PP_CATCHABLY(Perl_pp_entertry);
4642 create_eval_scope(cLOGOP->op_other->op_next, 0);
4643 return PL_op->op_next;
4647 /* also tail-called by pp_return */
4659 assert(CxTYPE(cx) == CXt_EVAL);
4660 oldsp = PL_stack_base + cx->blk_oldsp;
4661 gimme = cx->blk_gimme;
4663 if (gimme == G_VOID) {
4664 PL_stack_sp = oldsp;
4665 /* free now to avoid late-called destructors clobbering $@ */
4669 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4673 retop = cx->blk_eval.retop;
4684 const U8 gimme = GIMME_V;
4688 assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4689 GvSV(PL_defgv) = SvREFCNT_inc(newsv);
4691 cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
4692 cx_pushgiven(cx, origsv);
4702 PERL_UNUSED_CONTEXT;
4705 assert(CxTYPE(cx) == CXt_GIVEN);
4706 oldsp = PL_stack_base + cx->blk_oldsp;
4707 gimme = cx->blk_gimme;
4709 if (gimme == G_VOID)
4710 PL_stack_sp = oldsp;
4712 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4722 /* Helper routines used by pp_smartmatch */
4724 S_make_matcher(pTHX_ REGEXP *re)
4726 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4728 PERL_ARGS_ASSERT_MAKE_MATCHER;
4730 PM_SETRE(matcher, ReREFCNT_inc(re));
4732 SAVEFREEOP((OP *) matcher);
4733 ENTER_with_name("matcher"); SAVETMPS;
4739 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4744 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4746 PL_op = (OP *) matcher;
4749 (void) Perl_pp_match(aTHX);
4751 result = SvTRUEx(POPs);
4758 S_destroy_matcher(pTHX_ PMOP *matcher)
4760 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4761 PERL_UNUSED_ARG(matcher);
4764 LEAVE_with_name("matcher");
4767 /* Do a smart match */
4770 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4771 return do_smartmatch(NULL, NULL, 0);
4774 /* This version of do_smartmatch() implements the
4775 * table of smart matches that is found in perlsyn.
4778 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4782 bool object_on_left = FALSE;
4783 SV *e = TOPs; /* e is for 'expression' */
4784 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4786 /* Take care only to invoke mg_get() once for each argument.
4787 * Currently we do this by copying the SV if it's magical. */
4789 if (!copied && SvGMAGICAL(d))
4790 d = sv_mortalcopy(d);
4797 e = sv_mortalcopy(e);
4799 /* First of all, handle overload magic of the rightmost argument */
4802 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4803 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4805 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4812 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4815 SP -= 2; /* Pop the values */
4820 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4827 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4828 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4829 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4831 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4832 object_on_left = TRUE;
4835 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4837 if (object_on_left) {
4838 goto sm_any_sub; /* Treat objects like scalars */
4840 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4841 /* Test sub truth for each key */
4843 bool andedresults = TRUE;
4844 HV *hv = (HV*) SvRV(d);
4845 I32 numkeys = hv_iterinit(hv);
4846 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4849 while ( (he = hv_iternext(hv)) ) {
4850 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4851 ENTER_with_name("smartmatch_hash_key_test");
4854 PUSHs(hv_iterkeysv(he));
4856 c = call_sv(e, G_SCALAR);
4859 andedresults = FALSE;
4861 andedresults = SvTRUEx(POPs) && andedresults;
4863 LEAVE_with_name("smartmatch_hash_key_test");
4870 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4871 /* Test sub truth for each element */
4873 bool andedresults = TRUE;
4874 AV *av = (AV*) SvRV(d);
4875 const I32 len = av_tindex(av);
4876 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4879 for (i = 0; i <= len; ++i) {
4880 SV * const * const svp = av_fetch(av, i, FALSE);
4881 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4882 ENTER_with_name("smartmatch_array_elem_test");
4888 c = call_sv(e, G_SCALAR);
4891 andedresults = FALSE;
4893 andedresults = SvTRUEx(POPs) && andedresults;
4895 LEAVE_with_name("smartmatch_array_elem_test");
4904 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4905 ENTER_with_name("smartmatch_coderef");
4910 c = call_sv(e, G_SCALAR);
4914 else if (SvTEMP(TOPs))
4915 SvREFCNT_inc_void(TOPs);
4917 LEAVE_with_name("smartmatch_coderef");
4922 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4923 if (object_on_left) {
4924 goto sm_any_hash; /* Treat objects like scalars */
4926 else if (!SvOK(d)) {
4927 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4930 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4931 /* Check that the key-sets are identical */
4933 HV *other_hv = MUTABLE_HV(SvRV(d));
4936 U32 this_key_count = 0,
4937 other_key_count = 0;
4938 HV *hv = MUTABLE_HV(SvRV(e));
4940 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4941 /* Tied hashes don't know how many keys they have. */
4942 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4943 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4947 HV * const temp = other_hv;
4953 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4957 /* The hashes have the same number of keys, so it suffices
4958 to check that one is a subset of the other. */
4959 (void) hv_iterinit(hv);
4960 while ( (he = hv_iternext(hv)) ) {
4961 SV *key = hv_iterkeysv(he);
4963 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4966 if(!hv_exists_ent(other_hv, key, 0)) {
4967 (void) hv_iterinit(hv); /* reset iterator */
4973 (void) hv_iterinit(other_hv);
4974 while ( hv_iternext(other_hv) )
4978 other_key_count = HvUSEDKEYS(other_hv);
4980 if (this_key_count != other_key_count)
4985 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4986 AV * const other_av = MUTABLE_AV(SvRV(d));
4987 const SSize_t other_len = av_tindex(other_av) + 1;
4989 HV *hv = MUTABLE_HV(SvRV(e));
4991 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4992 for (i = 0; i < other_len; ++i) {
4993 SV ** const svp = av_fetch(other_av, i, FALSE);
4994 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4995 if (svp) { /* ??? When can this not happen? */
4996 if (hv_exists_ent(hv, *svp, 0))
5002 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
5003 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
5006 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
5008 HV *hv = MUTABLE_HV(SvRV(e));
5010 (void) hv_iterinit(hv);
5011 while ( (he = hv_iternext(hv)) ) {
5012 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
5014 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
5016 (void) hv_iterinit(hv);
5017 destroy_matcher(matcher);
5022 destroy_matcher(matcher);
5028 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
5029 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
5036 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
5037 if (object_on_left) {
5038 goto sm_any_array; /* Treat objects like scalars */
5040 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5041 AV * const other_av = MUTABLE_AV(SvRV(e));
5042 const SSize_t other_len = av_tindex(other_av) + 1;
5045 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
5046 for (i = 0; i < other_len; ++i) {
5047 SV ** const svp = av_fetch(other_av, i, FALSE);
5049 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
5050 if (svp) { /* ??? When can this not happen? */
5051 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
5057 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5058 AV *other_av = MUTABLE_AV(SvRV(d));
5059 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
5060 if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
5064 const SSize_t other_len = av_tindex(other_av);
5066 if (NULL == seen_this) {
5067 seen_this = newHV();
5068 (void) sv_2mortal(MUTABLE_SV(seen_this));
5070 if (NULL == seen_other) {
5071 seen_other = newHV();
5072 (void) sv_2mortal(MUTABLE_SV(seen_other));
5074 for(i = 0; i <= other_len; ++i) {
5075 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5076 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
5078 if (!this_elem || !other_elem) {
5079 if ((this_elem && SvOK(*this_elem))
5080 || (other_elem && SvOK(*other_elem)))
5083 else if (hv_exists_ent(seen_this,
5084 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
5085 hv_exists_ent(seen_other,
5086 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
5088 if (*this_elem != *other_elem)
5092 (void)hv_store_ent(seen_this,
5093 sv_2mortal(newSViv(PTR2IV(*this_elem))),
5095 (void)hv_store_ent(seen_other,
5096 sv_2mortal(newSViv(PTR2IV(*other_elem))),
5102 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
5103 (void) do_smartmatch(seen_this, seen_other, 0);
5105 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
5114 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
5115 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
5118 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
5119 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5122 for(i = 0; i <= this_len; ++i) {
5123 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5124 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
5126 if (svp && matcher_matches_sv(matcher, *svp)) {
5128 destroy_matcher(matcher);
5133 destroy_matcher(matcher);
5137 else if (!SvOK(d)) {
5138 /* undef ~~ array */
5139 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5142 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
5143 for (i = 0; i <= this_len; ++i) {
5144 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5145 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
5146 if (!svp || !SvOK(*svp))
5155 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5157 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
5158 for (i = 0; i <= this_len; ++i) {
5159 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5166 /* infinite recursion isn't supposed to happen here */
5167 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
5168 (void) do_smartmatch(NULL, NULL, 1);
5170 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
5179 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
5180 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5181 SV *t = d; d = e; e = t;
5182 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
5185 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5186 SV *t = d; d = e; e = t;
5187 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
5188 goto sm_regex_array;
5191 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
5194 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
5196 result = matcher_matches_sv(matcher, d);
5198 PUSHs(result ? &PL_sv_yes : &PL_sv_no);
5199 destroy_matcher(matcher);
5204 /* See if there is overload magic on left */
5205 else if (object_on_left && SvAMAGIC(d)) {
5207 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
5208 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
5211 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
5219 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
5222 else if (!SvOK(d)) {
5223 /* undef ~~ scalar ; we already know that the scalar is SvOK */
5224 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
5229 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
5230 DEBUG_M(if (SvNIOK(e))
5231 Perl_deb(aTHX_ " applying rule Any-Num\n");
5233 Perl_deb(aTHX_ " applying rule Num-numish\n");
5235 /* numeric comparison */
5238 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
5239 (void) Perl_pp_i_eq(aTHX);
5241 (void) Perl_pp_eq(aTHX);
5249 /* As a last resort, use string comparison */
5250 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
5253 return Perl_pp_seq(aTHX);
5260 const U8 gimme = GIMME_V;
5262 /* This is essentially an optimization: if the match
5263 fails, we don't want to push a context and then
5264 pop it again right away, so we skip straight
5265 to the op that follows the leavewhen.
5266 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5268 if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) {
5269 if (gimme == G_SCALAR)
5270 PUSHs(&PL_sv_undef);
5271 RETURNOP(cLOGOP->op_other->op_next);
5274 cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
5288 assert(CxTYPE(cx) == CXt_WHEN);
5289 gimme = cx->blk_gimme;
5291 cxix = dopoptogivenfor(cxstack_ix);
5293 /* diag_listed_as: Can't "when" outside a topicalizer */
5294 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5295 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5297 oldsp = PL_stack_base + cx->blk_oldsp;
5298 if (gimme == G_VOID)
5299 PL_stack_sp = oldsp;
5301 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5303 /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
5304 assert(cxix < cxstack_ix);
5307 cx = &cxstack[cxix];
5309 if (CxFOREACH(cx)) {
5310 /* emulate pp_next. Note that any stack(s) cleanup will be
5311 * done by the pp_unstack which op_nextop should point to */
5314 PL_curcop = cx->blk_oldcop;
5315 return cx->blk_loop.my_op->op_nextop;
5319 assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
5320 return cx->blk_givwhen.leave_op;
5330 cxix = dopoptowhen(cxstack_ix);
5332 DIE(aTHX_ "Can't \"continue\" outside a when block");
5334 if (cxix < cxstack_ix)
5338 assert(CxTYPE(cx) == CXt_WHEN);
5339 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5343 nextop = cx->blk_givwhen.leave_op->op_next;
5354 cxix = dopoptogivenfor(cxstack_ix);
5356 DIE(aTHX_ "Can't \"break\" outside a given block");
5358 cx = &cxstack[cxix];
5360 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5362 if (cxix < cxstack_ix)
5365 /* Restore the sp at the time we entered the given block */
5367 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5369 return cx->blk_givwhen.leave_op;
5373 S_doparseform(pTHX_ SV *sv)
5376 char *s = SvPV(sv, len);
5378 char *base = NULL; /* start of current field */
5379 I32 skipspaces = 0; /* number of contiguous spaces seen */
5380 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5381 bool repeat = FALSE; /* ~~ seen on this line */
5382 bool postspace = FALSE; /* a text field may need right padding */
5385 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5387 bool ischop; /* it's a ^ rather than a @ */
5388 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5389 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5393 PERL_ARGS_ASSERT_DOPARSEFORM;
5396 Perl_croak(aTHX_ "Null picture in formline");
5398 if (SvTYPE(sv) >= SVt_PVMG) {
5399 /* This might, of course, still return NULL. */
5400 mg = mg_find(sv, PERL_MAGIC_fm);
5402 sv_upgrade(sv, SVt_PVMG);
5406 /* still the same as previously-compiled string? */
5407 SV *old = mg->mg_obj;
5408 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5409 && len == SvCUR(old)
5410 && strnEQ(SvPVX(old), s, len)
5412 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5416 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5417 Safefree(mg->mg_ptr);
5423 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5424 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5427 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5428 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5432 /* estimate the buffer size needed */
5433 for (base = s; s <= send; s++) {
5434 if (*s == '\n' || *s == '@' || *s == '^')
5440 Newx(fops, maxops, U32);
5445 *fpc++ = FF_LINEMARK;
5446 noblank = repeat = FALSE;
5464 case ' ': case '\t':
5480 *fpc++ = FF_LITERAL;
5488 *fpc++ = (U32)skipspaces;
5492 *fpc++ = FF_NEWLINE;
5496 arg = fpc - linepc + 1;
5503 *fpc++ = FF_LINEMARK;
5504 noblank = repeat = FALSE;
5513 ischop = s[-1] == '^';
5519 arg = (s - base) - 1;
5521 *fpc++ = FF_LITERAL;
5527 if (*s == '*') { /* @* or ^* */
5529 *fpc++ = 2; /* skip the @* or ^* */
5531 *fpc++ = FF_LINESNGL;
5534 *fpc++ = FF_LINEGLOB;
5536 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5537 arg = ischop ? FORM_NUM_BLANK : 0;
5542 const char * const f = ++s;
5545 arg |= FORM_NUM_POINT + (s - f);
5547 *fpc++ = s - base; /* fieldsize for FETCH */
5548 *fpc++ = FF_DECIMAL;
5550 unchopnum |= ! ischop;
5552 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5553 arg = ischop ? FORM_NUM_BLANK : 0;
5555 s++; /* skip the '0' first */
5559 const char * const f = ++s;
5562 arg |= FORM_NUM_POINT + (s - f);
5564 *fpc++ = s - base; /* fieldsize for FETCH */
5565 *fpc++ = FF_0DECIMAL;
5567 unchopnum |= ! ischop;
5569 else { /* text field */
5571 bool ismore = FALSE;
5574 while (*++s == '>') ;
5575 prespace = FF_SPACE;
5577 else if (*s == '|') {
5578 while (*++s == '|') ;
5579 prespace = FF_HALFSPACE;
5584 while (*++s == '<') ;
5587 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5591 *fpc++ = s - base; /* fieldsize for FETCH */
5593 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5596 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5610 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5613 mg->mg_ptr = (char *) fops;
5614 mg->mg_len = arg * sizeof(U32);
5615 mg->mg_obj = sv_copy;
5616 mg->mg_flags |= MGf_REFCOUNTED;
5618 if (unchopnum && repeat)
5619 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5626 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5628 /* Can value be printed in fldsize chars, using %*.*f ? */
5632 int intsize = fldsize - (value < 0 ? 1 : 0);
5634 if (frcsize & FORM_NUM_POINT)
5636 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5639 while (intsize--) pwr *= 10.0;
5640 while (frcsize--) eps /= 10.0;
5643 if (value + eps >= pwr)
5646 if (value - eps <= -pwr)
5653 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5655 SV * const datasv = FILTER_DATA(idx);
5656 const int filter_has_file = IoLINES(datasv);
5657 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5658 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5663 char *prune_from = NULL;
5664 bool read_from_cache = FALSE;
5668 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5670 assert(maxlen >= 0);
5673 /* I was having segfault trouble under Linux 2.2.5 after a
5674 parse error occurred. (Had to hack around it with a test
5675 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5676 not sure where the trouble is yet. XXX */
5679 SV *const cache = datasv;
5682 const char *cache_p = SvPV(cache, cache_len);
5686 /* Running in block mode and we have some cached data already.
5688 if (cache_len >= umaxlen) {
5689 /* In fact, so much data we don't even need to call
5694 const char *const first_nl =
5695 (const char *)memchr(cache_p, '\n', cache_len);
5697 take = first_nl + 1 - cache_p;
5701 sv_catpvn(buf_sv, cache_p, take);
5702 sv_chop(cache, cache_p + take);
5703 /* Definitely not EOF */
5707 sv_catsv(buf_sv, cache);
5709 umaxlen -= cache_len;
5712 read_from_cache = TRUE;
5716 /* Filter API says that the filter appends to the contents of the buffer.
5717 Usually the buffer is "", so the details don't matter. But if it's not,
5718 then clearly what it contains is already filtered by this filter, so we
5719 don't want to pass it in a second time.
5720 I'm going to use a mortal in case the upstream filter croaks. */
5721 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5722 ? sv_newmortal() : buf_sv;
5723 SvUPGRADE(upstream, SVt_PV);
5725 if (filter_has_file) {
5726 status = FILTER_READ(idx+1, upstream, 0);
5729 if (filter_sub && status >= 0) {
5733 ENTER_with_name("call_filter_sub");
5738 DEFSV_set(upstream);
5742 PUSHs(filter_state);
5745 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5755 SV * const errsv = ERRSV;
5756 if (SvTRUE_NN(errsv))
5757 err = newSVsv(errsv);
5763 LEAVE_with_name("call_filter_sub");
5766 if (SvGMAGICAL(upstream)) {
5768 if (upstream == buf_sv) mg_free(buf_sv);
5770 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5771 if(!err && SvOK(upstream)) {
5772 got_p = SvPV_nomg(upstream, got_len);
5774 if (got_len > umaxlen) {
5775 prune_from = got_p + umaxlen;
5778 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5779 if (first_nl && first_nl + 1 < got_p + got_len) {
5780 /* There's a second line here... */
5781 prune_from = first_nl + 1;
5785 if (!err && prune_from) {
5786 /* Oh. Too long. Stuff some in our cache. */
5787 STRLEN cached_len = got_p + got_len - prune_from;
5788 SV *const cache = datasv;
5791 /* Cache should be empty. */
5792 assert(!SvCUR(cache));
5795 sv_setpvn(cache, prune_from, cached_len);
5796 /* If you ask for block mode, you may well split UTF-8 characters.
5797 "If it breaks, you get to keep both parts"
5798 (Your code is broken if you don't put them back together again
5799 before something notices.) */
5800 if (SvUTF8(upstream)) {
5803 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5805 /* Cannot just use sv_setpvn, as that could free the buffer
5806 before we have a chance to assign it. */
5807 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5808 got_len - cached_len);
5810 /* Can't yet be EOF */
5815 /* If they are at EOF but buf_sv has something in it, then they may never
5816 have touched the SV upstream, so it may be undefined. If we naively
5817 concatenate it then we get a warning about use of uninitialised value.
5819 if (!err && upstream != buf_sv &&
5821 sv_catsv_nomg(buf_sv, upstream);
5823 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5826 IoLINES(datasv) = 0;
5828 SvREFCNT_dec(filter_state);
5829 IoTOP_GV(datasv) = NULL;
5832 SvREFCNT_dec(filter_sub);
5833 IoBOTTOM_GV(datasv) = NULL;
5835 filter_del(S_run_user_filter);
5841 if (status == 0 && read_from_cache) {
5842 /* If we read some data from the cache (and by getting here it implies
5843 that we emptied the cache) then we aren't yet at EOF, and mustn't
5844 report that to our caller. */
5851 * ex: set ts=8 sts=4 sw=4 et: