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 dopoptosub(plop) dopoptosub_at(cxstack, (plop))
46 const PERL_CONTEXT *cx;
49 if (PL_op->op_private & OPpOFFBYONE) {
50 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
53 cxix = dopoptosub(cxstack_ix);
59 switch (cx->blk_gimme) {
78 PMOP *pm = (PMOP*)cLOGOP->op_other;
83 const regexp_engine *eng;
84 bool is_bare_re= FALSE;
86 if (PL_op->op_flags & OPf_STACKED) {
96 /* prevent recompiling under /o and ithreads. */
97 #if defined(USE_ITHREADS)
98 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
105 assert (re != (REGEXP*) &PL_sv_undef);
106 eng = re ? RX_ENGINE(re) : current_re_engine();
108 new_re = (eng->op_comp
110 : &Perl_re_op_compile
111 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
113 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
115 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
117 if (pm->op_pmflags & PMf_HAS_CV)
118 ReANY(new_re)->qr_anoncv
119 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
123 /* The match's LHS's get-magic might need to access this op's regexp
124 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
125 get-magic now before we replace the regexp. Hopefully this hack can
126 be replaced with the approach described at
127 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
129 if (pm->op_type == OP_MATCH) {
131 const bool was_tainted = TAINT_get;
132 if (pm->op_flags & OPf_STACKED)
134 else if (pm->op_targ)
135 lhs = PAD_SV(pm->op_targ);
138 /* Restore the previous value of PL_tainted (which may have been
139 modified by get-magic), to avoid incorrectly setting the
140 RXf_TAINTED flag with RX_TAINT_on further down. */
141 TAINT_set(was_tainted);
142 #ifdef NO_TAINT_SUPPORT
143 PERL_UNUSED_VAR(was_tainted);
146 tmp = reg_temp_copy(NULL, new_re);
147 ReREFCNT_dec(new_re);
153 PM_SETRE(pm, new_re);
157 assert(TAINTING_get || !TAINT_get);
159 SvTAINTED_on((SV*)new_re);
163 /* handle the empty pattern */
164 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) {
165 if (PL_curpm == PL_reg_curpm) {
166 if (PL_curpm_under && PL_curpm_under == PL_reg_curpm) {
167 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
172 #if !defined(USE_ITHREADS)
173 /* can't change the optree at runtime either */
174 /* PMf_KEEP is handled differently under threads to avoid these problems */
175 if (pm->op_pmflags & PMf_KEEP) {
176 cLOGOP->op_first->op_next = PL_op->op_next;
188 PERL_CONTEXT *cx = CX_CUR();
189 PMOP * const pm = (PMOP*) cLOGOP->op_other;
190 SV * const dstr = cx->sb_dstr;
193 char *orig = cx->sb_orig;
194 REGEXP * const rx = cx->sb_rx;
196 REGEXP *old = PM_GETRE(pm);
203 PM_SETRE(pm,ReREFCNT_inc(rx));
206 rxres_restore(&cx->sb_rxres, rx);
208 if (cx->sb_iters++) {
209 const SSize_t saviters = cx->sb_iters;
210 if (cx->sb_iters > cx->sb_maxiters)
211 DIE(aTHX_ "Substitution loop");
213 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
215 /* See "how taint works" above pp_subst() */
216 sv_catsv_nomg(dstr, POPs);
217 if (UNLIKELY(TAINT_get))
218 cx->sb_rxtainted |= SUBST_TAINT_REPL;
219 if (CxONCE(cx) || s < orig ||
220 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
221 (s == m), cx->sb_targ, NULL,
222 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
224 SV *targ = cx->sb_targ;
226 assert(cx->sb_strend >= s);
227 if(cx->sb_strend > s) {
228 if (DO_UTF8(dstr) && !SvUTF8(targ))
229 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
231 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
233 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
234 cx->sb_rxtainted |= SUBST_TAINT_PAT;
236 if (pm->op_pmflags & PMf_NONDESTRUCT) {
238 /* From here on down we're using the copy, and leaving the
239 original untouched. */
243 SV_CHECK_THINKFIRST_COW_DROP(targ);
244 if (isGV(targ)) Perl_croak_no_modify();
246 SvPV_set(targ, SvPVX(dstr));
247 SvCUR_set(targ, SvCUR(dstr));
248 SvLEN_set(targ, SvLEN(dstr));
251 SvPV_set(dstr, NULL);
254 mPUSHi(saviters - 1);
256 (void)SvPOK_only_UTF8(targ);
259 /* update the taint state of various various variables in
260 * preparation for final exit.
261 * See "how taint works" above pp_subst() */
263 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
264 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
265 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
267 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
269 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
270 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
272 SvTAINTED_on(TOPs); /* taint return value */
273 /* needed for mg_set below */
275 cBOOL(cx->sb_rxtainted &
276 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
279 /* sv_magic(), when adding magic (e.g.taint magic), also
280 * recalculates any pos() magic, converting any byte offset
281 * to utf8 offset. Make sure pos() is reset before this
282 * happens rather than using the now invalid value (since
283 * we've just replaced targ's pvx buffer with the
284 * potentially shorter dstr buffer). Normally (i.e. in
285 * non-taint cases), pos() gets removed a few lines later
286 * with the SvSETMAGIC().
290 mg = mg_find_mglob(targ);
292 MgBYTEPOS_set(mg, targ, SvPVX(targ), -1);
298 /* PL_tainted must be correctly set for this mg_set */
307 RETURNOP(pm->op_next);
308 NOT_REACHED; /* NOTREACHED */
310 cx->sb_iters = saviters;
312 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
315 assert(!RX_SUBOFFSET(rx));
316 cx->sb_orig = orig = RX_SUBBEG(rx);
318 cx->sb_strend = s + (cx->sb_strend - m);
320 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
322 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
323 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
325 sv_catpvn_nomg(dstr, s, m-s);
327 cx->sb_s = RX_OFFS(rx)[0].end + orig;
328 { /* Update the pos() information. */
330 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
333 /* the string being matched against may no longer be a string,
334 * e.g. $_=0; s/.../$_++/ge */
337 SvPV_force_nomg_nolen(sv);
339 if (!(mg = mg_find_mglob(sv))) {
340 mg = sv_magicext_mglob(sv);
342 MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
345 (void)ReREFCNT_inc(rx);
346 /* update the taint state of various various variables in preparation
347 * for calling the code block.
348 * See "how taint works" above pp_subst() */
350 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
351 cx->sb_rxtainted |= SUBST_TAINT_PAT;
353 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
354 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
355 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
357 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
359 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
360 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
361 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
362 ? cx->sb_dstr : cx->sb_targ);
365 rxres_save(&cx->sb_rxres, rx);
367 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
371 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
376 PERL_ARGS_ASSERT_RXRES_SAVE;
379 if (!p || p[1] < RX_NPARENS(rx)) {
381 i = 7 + (RX_NPARENS(rx)+1) * 2;
383 i = 6 + (RX_NPARENS(rx)+1) * 2;
392 /* what (if anything) to free on croak */
393 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
394 RX_MATCH_COPIED_off(rx);
395 *p++ = RX_NPARENS(rx);
398 *p++ = PTR2UV(RX_SAVED_COPY(rx));
399 RX_SAVED_COPY(rx) = NULL;
402 *p++ = PTR2UV(RX_SUBBEG(rx));
403 *p++ = (UV)RX_SUBLEN(rx);
404 *p++ = (UV)RX_SUBOFFSET(rx);
405 *p++ = (UV)RX_SUBCOFFSET(rx);
406 for (i = 0; i <= RX_NPARENS(rx); ++i) {
407 *p++ = (UV)RX_OFFS(rx)[i].start;
408 *p++ = (UV)RX_OFFS(rx)[i].end;
413 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
418 PERL_ARGS_ASSERT_RXRES_RESTORE;
421 RX_MATCH_COPY_FREE(rx);
422 RX_MATCH_COPIED_set(rx, *p);
424 RX_NPARENS(rx) = *p++;
427 if (RX_SAVED_COPY(rx))
428 SvREFCNT_dec (RX_SAVED_COPY(rx));
429 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
433 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
434 RX_SUBLEN(rx) = (I32)(*p++);
435 RX_SUBOFFSET(rx) = (I32)*p++;
436 RX_SUBCOFFSET(rx) = (I32)*p++;
437 for (i = 0; i <= RX_NPARENS(rx); ++i) {
438 RX_OFFS(rx)[i].start = (I32)(*p++);
439 RX_OFFS(rx)[i].end = (I32)(*p++);
444 S_rxres_free(pTHX_ void **rsp)
446 UV * const p = (UV*)*rsp;
448 PERL_ARGS_ASSERT_RXRES_FREE;
452 void *tmp = INT2PTR(char*,*p);
455 U32 i = 9 + p[1] * 2;
457 U32 i = 8 + p[1] * 2;
462 SvREFCNT_dec (INT2PTR(SV*,p[2]));
465 PoisonFree(p, i, sizeof(UV));
474 #define FORM_NUM_BLANK (1<<30)
475 #define FORM_NUM_POINT (1<<29)
479 dSP; dMARK; dORIGMARK;
480 SV * const tmpForm = *++MARK;
481 SV *formsv; /* contains text of original format */
482 U32 *fpc; /* format ops program counter */
483 char *t; /* current append position in target string */
484 const char *f; /* current position in format string */
486 SV *sv = NULL; /* current item */
487 const char *item = NULL;/* string value of current item */
488 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
489 I32 itembytes = 0; /* as itemsize, but length in bytes */
490 I32 fieldsize = 0; /* width of current field */
491 I32 lines = 0; /* number of lines that have been output */
492 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
493 const char *chophere = NULL; /* where to chop current item */
494 STRLEN linemark = 0; /* pos of start of line in output */
496 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
497 STRLEN len; /* length of current sv */
498 STRLEN linemax; /* estimate of output size in bytes */
499 bool item_is_utf8 = FALSE;
500 bool targ_is_utf8 = FALSE;
503 U8 *source; /* source of bytes to append */
504 STRLEN to_copy; /* how may bytes to append */
505 char trans; /* what chars to translate */
506 bool copied_form = FALSE; /* have we duplicated the form? */
508 mg = doparseform(tmpForm);
510 fpc = (U32*)mg->mg_ptr;
511 /* the actual string the format was compiled from.
512 * with overload etc, this may not match tmpForm */
516 SvPV_force(PL_formtarget, len);
517 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
518 SvTAINTED_on(PL_formtarget);
519 if (DO_UTF8(PL_formtarget))
521 /* this is an initial estimate of how much output buffer space
522 * to allocate. It may be exceeded later */
523 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
524 t = SvGROW(PL_formtarget, len + linemax + 1);
525 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
527 f = SvPV_const(formsv, len);
531 const char *name = "???";
534 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
535 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
536 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
537 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
538 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
540 case FF_CHECKNL: name = "CHECKNL"; break;
541 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
542 case FF_SPACE: name = "SPACE"; break;
543 case FF_HALFSPACE: name = "HALFSPACE"; break;
544 case FF_ITEM: name = "ITEM"; break;
545 case FF_CHOP: name = "CHOP"; break;
546 case FF_LINEGLOB: name = "LINEGLOB"; break;
547 case FF_NEWLINE: name = "NEWLINE"; break;
548 case FF_MORE: name = "MORE"; break;
549 case FF_LINEMARK: name = "LINEMARK"; break;
550 case FF_END: name = "END"; break;
551 case FF_0DECIMAL: name = "0DECIMAL"; break;
552 case FF_LINESNGL: name = "LINESNGL"; break;
555 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
557 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
560 case FF_LINEMARK: /* start (or end) of a line */
561 linemark = t - SvPVX(PL_formtarget);
566 case FF_LITERAL: /* append <arg> literal chars */
571 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
574 case FF_SKIP: /* skip <arg> chars in format */
578 case FF_FETCH: /* get next item and set field size to <arg> */
587 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
590 SvTAINTED_on(PL_formtarget);
593 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
595 const char *s = item = SvPV_const(sv, len);
596 const char *send = s + len;
599 item_is_utf8 = DO_UTF8(sv);
611 if (itemsize == fieldsize)
614 itembytes = s - item;
619 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
621 const char *s = item = SvPV_const(sv, len);
622 const char *send = s + len;
626 item_is_utf8 = DO_UTF8(sv);
628 /* look for a legal split position */
636 /* provisional split point */
640 /* we delay testing fieldsize until after we've
641 * processed the possible split char directly
642 * following the last field char; so if fieldsize=3
643 * and item="a b cdef", we consume "a b", not "a".
644 * Ditto further down.
646 if (size == fieldsize)
650 if (strchr(PL_chopset, *s)) {
651 /* provisional split point */
652 /* for a non-space split char, we include
653 * the split char; hence the '+1' */
657 if (size == fieldsize)
669 if (!chophere || s == send) {
673 itembytes = chophere - item;
678 case FF_SPACE: /* append padding space (diff of field, item size) */
679 arg = fieldsize - itemsize;
687 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
688 arg = fieldsize - itemsize;
697 case FF_ITEM: /* append a text item, while blanking ctrl chars */
703 case FF_CHOP: /* (for ^*) chop the current item */
704 if (sv != &PL_sv_no) {
705 const char *s = chophere;
707 ((sv == tmpForm || SvSMAGICAL(sv))
708 || (SvGMAGICAL(tmpForm) && !sv_only_taint_gmagic(tmpForm))) ) {
709 /* sv and tmpForm are either the same SV, or magic might allow modification
710 of tmpForm when sv is modified, so copy */
711 SV *newformsv = sv_mortalcopy(formsv);
714 f = SvPV_nolen(newformsv) + (f - SvPV_nolen(formsv));
715 Newx(new_compiled, mg->mg_len / sizeof(U32), U32);
716 memcpy(new_compiled, mg->mg_ptr, mg->mg_len);
717 SAVEFREEPV(new_compiled);
718 fpc = new_compiled + (fpc - (U32*)mg->mg_ptr);
730 /* tied, overloaded or similar strangeness.
731 * Do it the hard way */
732 sv_setpvn(sv, s, len - (s-item));
738 case FF_LINESNGL: /* process ^* */
742 case FF_LINEGLOB: /* process @* */
744 const bool oneline = fpc[-1] == FF_LINESNGL;
745 const char *s = item = SvPV_const(sv, len);
746 const char *const send = s + len;
748 item_is_utf8 = DO_UTF8(sv);
759 to_copy = s - item - 1;
773 /* append to_copy bytes from source to PL_formstring.
774 * item_is_utf8 implies source is utf8.
775 * if trans, translate certain characters during the copy */
780 SvCUR_set(PL_formtarget,
781 t - SvPVX_const(PL_formtarget));
783 if (targ_is_utf8 && !item_is_utf8) {
784 source = tmp = bytes_to_utf8(source, &to_copy);
787 if (item_is_utf8 && !targ_is_utf8) {
789 /* Upgrade targ to UTF8, and then we reduce it to
790 a problem we have a simple solution for.
791 Don't need get magic. */
792 sv_utf8_upgrade_nomg(PL_formtarget);
794 /* re-calculate linemark */
795 s = (U8*)SvPVX(PL_formtarget);
796 /* the bytes we initially allocated to append the
797 * whole line may have been gobbled up during the
798 * upgrade, so allocate a whole new line's worth
802 s += UTF8_SAFE_SKIP(s,
803 (U8 *) SvEND(PL_formtarget));
804 linemark = s - (U8*)SvPVX(PL_formtarget);
806 /* Easy. They agree. */
807 assert (item_is_utf8 == targ_is_utf8);
810 /* @* and ^* are the only things that can exceed
811 * the linemax, so grow by the output size, plus
812 * a whole new form's worth in case of any further
814 grow = linemax + to_copy;
816 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
817 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
819 Copy(source, t, to_copy, char);
821 /* blank out ~ or control chars, depending on trans.
822 * works on bytes not chars, so relies on not
823 * matching utf8 continuation bytes */
825 U8 *send = s + to_copy;
828 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
835 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
841 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
844 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
847 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
850 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
852 /* If the field is marked with ^ and the value is undefined,
854 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
862 /* overflow evidence */
863 if (num_overflow(value, fieldsize, arg)) {
869 /* Formats aren't yet marked for locales, so assume "yes". */
871 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
873 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
874 STORE_LC_NUMERIC_SET_TO_NEEDED();
875 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
878 const char* qfmt = quadmath_format_single(fmt);
881 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
882 len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
884 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
889 /* we generate fmt ourselves so it is safe */
890 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
891 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
892 GCC_DIAG_RESTORE_STMT;
894 PERL_MY_SNPRINTF_POST_GUARD(len, max);
895 RESTORE_LC_NUMERIC();
900 case FF_NEWLINE: /* delete trailing spaces, then append \n */
902 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
907 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
910 if (arg) { /* repeat until fields exhausted? */
916 t = SvPVX(PL_formtarget) + linemark;
921 case FF_MORE: /* replace long end of string with '...' */
923 const char *s = chophere;
924 const char *send = item + len;
926 while (isSPACE(*s) && (s < send))
931 arg = fieldsize - itemsize;
938 if (strBEGINs(s1," ")) {
939 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
949 case FF_END: /* tidy up, then return */
951 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
953 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
955 SvUTF8_on(PL_formtarget);
956 FmLINES(PL_formtarget) += lines;
958 if (fpc[-1] == FF_BLANK)
959 RETURNOP(cLISTOP->op_first);
966 /* also used for: pp_mapstart() */
972 if (PL_stack_base + TOPMARK == SP) {
974 if (GIMME_V == G_SCALAR)
976 RETURNOP(PL_op->op_next->op_next);
978 PL_stack_sp = PL_stack_base + TOPMARK + 1;
979 Perl_pp_pushmark(aTHX); /* push dst */
980 Perl_pp_pushmark(aTHX); /* push src */
981 ENTER_with_name("grep"); /* enter outer scope */
985 ENTER_with_name("grep_item"); /* enter inner scope */
988 src = PL_stack_base[TOPMARK];
990 src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
997 if (PL_op->op_type == OP_MAPSTART)
998 Perl_pp_pushmark(aTHX); /* push top */
999 return ((LOGOP*)PL_op->op_next)->op_other;
1005 const U8 gimme = GIMME_V;
1006 I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
1012 /* first, move source pointer to the next item in the source list */
1013 ++PL_markstack_ptr[-1];
1015 /* if there are new items, push them into the destination list */
1016 if (items && gimme != G_VOID) {
1017 /* might need to make room back there first */
1018 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1019 /* XXX this implementation is very pessimal because the stack
1020 * is repeatedly extended for every set of items. Is possible
1021 * to do this without any stack extension or copying at all
1022 * by maintaining a separate list over which the map iterates
1023 * (like foreach does). --gsar */
1025 /* everything in the stack after the destination list moves
1026 * towards the end the stack by the amount of room needed */
1027 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1029 /* items to shift up (accounting for the moved source pointer) */
1030 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1032 /* This optimization is by Ben Tilly and it does
1033 * things differently from what Sarathy (gsar)
1034 * is describing. The downside of this optimization is
1035 * that leaves "holes" (uninitialized and hopefully unused areas)
1036 * to the Perl stack, but on the other hand this
1037 * shouldn't be a problem. If Sarathy's idea gets
1038 * implemented, this optimization should become
1039 * irrelevant. --jhi */
1041 shift = count; /* Avoid shifting too often --Ben Tilly */
1045 dst = (SP += shift);
1046 PL_markstack_ptr[-1] += shift;
1047 *PL_markstack_ptr += shift;
1051 /* copy the new items down to the destination list */
1052 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1053 if (gimme == G_ARRAY) {
1054 /* add returned items to the collection (making mortal copies
1055 * if necessary), then clear the current temps stack frame
1056 * *except* for those items. We do this splicing the items
1057 * into the start of the tmps frame (so some items may be on
1058 * the tmps stack twice), then moving PL_tmps_floor above
1059 * them, then freeing the frame. That way, the only tmps that
1060 * accumulate over iterations are the return values for map.
1061 * We have to do to this way so that everything gets correctly
1062 * freed if we die during the map.
1066 /* make space for the slice */
1067 EXTEND_MORTAL(items);
1068 tmpsbase = PL_tmps_floor + 1;
1069 Move(PL_tmps_stack + tmpsbase,
1070 PL_tmps_stack + tmpsbase + items,
1071 PL_tmps_ix - PL_tmps_floor,
1073 PL_tmps_ix += items;
1078 sv = sv_mortalcopy(sv);
1080 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1082 /* clear the stack frame except for the items */
1083 PL_tmps_floor += items;
1085 /* FREETMPS may have cleared the TEMP flag on some of the items */
1088 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1091 /* scalar context: we don't care about which values map returns
1092 * (we use undef here). And so we certainly don't want to do mortal
1093 * copies of meaningless values. */
1094 while (items-- > 0) {
1096 *dst-- = &PL_sv_undef;
1104 LEAVE_with_name("grep_item"); /* exit inner scope */
1107 if (PL_markstack_ptr[-1] > TOPMARK) {
1109 (void)POPMARK; /* pop top */
1110 LEAVE_with_name("grep"); /* exit outer scope */
1111 (void)POPMARK; /* pop src */
1112 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1113 (void)POPMARK; /* pop dst */
1114 SP = PL_stack_base + POPMARK; /* pop original mark */
1115 if (gimme == G_SCALAR) {
1119 else if (gimme == G_ARRAY)
1126 ENTER_with_name("grep_item"); /* enter inner scope */
1129 /* set $_ to the new source item */
1130 src = PL_stack_base[PL_markstack_ptr[-1]];
1131 if (SvPADTMP(src)) {
1132 src = sv_mortalcopy(src);
1137 RETURNOP(cLOGOP->op_other);
1146 if (GIMME_V == G_ARRAY)
1149 if (SvTRUE_NN(targ))
1150 return cLOGOP->op_other;
1159 if (GIMME_V == G_ARRAY) {
1160 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1164 SV * const targ = PAD_SV(PL_op->op_targ);
1167 if (PL_op->op_private & OPpFLIP_LINENUM) {
1168 if (GvIO(PL_last_in_gv)) {
1169 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1172 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1174 flip = SvIV(sv) == SvIV(GvSV(gv));
1177 flip = SvTRUE_NN(sv);
1180 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1181 if (PL_op->op_flags & OPf_SPECIAL) {
1189 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1198 /* This code tries to decide if "$left .. $right" should use the
1199 magical string increment, or if the range is numeric. Initially,
1200 an exception was made for *any* string beginning with "0" (see
1201 [#18165], AMS 20021031), but now that is only applied when the
1202 string's length is also >1 - see the rules now documented in
1205 #define RANGE_IS_NUMERIC(left,right) ( \
1206 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1207 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1208 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1209 looks_like_number(left)) && SvPOKp(left) \
1210 && !(*SvPVX_const(left) == '0' && SvCUR(left)>1 ) )) \
1211 && (!SvOK(right) || looks_like_number(right))))
1217 if (GIMME_V == G_ARRAY) {
1223 if (RANGE_IS_NUMERIC(left,right)) {
1225 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1226 (SvOK(right) && (SvIOK(right)
1227 ? SvIsUV(right) && SvUV(right) > IV_MAX
1228 : SvNV_nomg(right) > IV_MAX)))
1229 DIE(aTHX_ "Range iterator outside integer range");
1230 i = SvIV_nomg(left);
1231 j = SvIV_nomg(right);
1233 /* Dance carefully around signed max. */
1234 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1237 /* The wraparound of signed integers is undefined
1238 * behavior, but here we aim for count >=1, and
1239 * negative count is just wrong. */
1241 #if IVSIZE > Size_t_size
1248 Perl_croak(aTHX_ "Out of memory during list extend");
1255 SV * const sv = sv_2mortal(newSViv(i));
1257 if (n) /* avoid incrementing above IV_MAX */
1263 const char * const lpv = SvPV_nomg_const(left, llen);
1264 const char * const tmps = SvPV_nomg_const(right, len);
1266 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1267 if (DO_UTF8(right) && IN_UNI_8_BIT)
1268 len = sv_len_utf8_nomg(right);
1269 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1271 if (strEQ(SvPVX_const(sv),tmps))
1273 sv = sv_2mortal(newSVsv(sv));
1280 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1284 if (PL_op->op_private & OPpFLIP_LINENUM) {
1285 if (GvIO(PL_last_in_gv)) {
1286 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1289 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1290 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1294 flop = SvTRUE_NN(sv);
1298 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1299 sv_catpvs(targ, "E0");
1309 static const char * const context_name[] = {
1311 NULL, /* CXt_WHEN never actually needs "block" */
1312 NULL, /* CXt_BLOCK never actually needs "block" */
1313 NULL, /* CXt_GIVEN never actually needs "block" */
1314 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1315 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1316 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1317 NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1318 NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1326 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1330 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1332 for (i = cxstack_ix; i >= 0; i--) {
1333 const PERL_CONTEXT * const cx = &cxstack[i];
1334 switch (CxTYPE(cx)) {
1340 /* diag_listed_as: Exiting subroutine via %s */
1341 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1342 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1343 if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1346 case CXt_LOOP_PLAIN:
1347 case CXt_LOOP_LAZYIV:
1348 case CXt_LOOP_LAZYSV:
1352 STRLEN cx_label_len = 0;
1353 U32 cx_label_flags = 0;
1354 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1356 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1359 (const U8*)cx_label, cx_label_len,
1360 (const U8*)label, len) == 0)
1362 (const U8*)label, len,
1363 (const U8*)cx_label, cx_label_len) == 0)
1364 : (len == cx_label_len && ((cx_label == label)
1365 || memEQ(cx_label, label, len))) )) {
1366 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1367 (long)i, cx_label));
1370 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1381 Perl_dowantarray(pTHX)
1383 const U8 gimme = block_gimme();
1384 return (gimme == G_VOID) ? G_SCALAR : gimme;
1388 Perl_block_gimme(pTHX)
1390 const I32 cxix = dopoptosub(cxstack_ix);
1395 gimme = (cxstack[cxix].blk_gimme & G_WANT);
1397 Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1403 Perl_is_lvalue_sub(pTHX)
1405 const I32 cxix = dopoptosub(cxstack_ix);
1406 assert(cxix >= 0); /* We should only be called from inside subs */
1408 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1409 return CxLVAL(cxstack + cxix);
1414 /* only used by cx_pushsub() */
1416 Perl_was_lvalue_sub(pTHX)
1418 const I32 cxix = dopoptosub(cxstack_ix-1);
1419 assert(cxix >= 0); /* We should only be called from inside subs */
1421 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1422 return CxLVAL(cxstack + cxix);
1428 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1432 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1434 PERL_UNUSED_CONTEXT;
1437 for (i = startingblock; i >= 0; i--) {
1438 const PERL_CONTEXT * const cx = &cxstk[i];
1439 switch (CxTYPE(cx)) {
1443 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1444 * twice; the first for the normal foo() call, and the second
1445 * for a faked up re-entry into the sub to execute the
1446 * code block. Hide this faked entry from the world. */
1447 if (cx->cx_type & CXp_SUB_RE_FAKE)
1452 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1460 S_dopoptoeval(pTHX_ I32 startingblock)
1463 for (i = startingblock; i >= 0; i--) {
1464 const PERL_CONTEXT *cx = &cxstack[i];
1465 switch (CxTYPE(cx)) {
1469 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1477 S_dopoptoloop(pTHX_ I32 startingblock)
1480 for (i = startingblock; i >= 0; i--) {
1481 const PERL_CONTEXT * const cx = &cxstack[i];
1482 switch (CxTYPE(cx)) {
1488 /* diag_listed_as: Exiting subroutine via %s */
1489 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1490 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1491 if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1494 case CXt_LOOP_PLAIN:
1495 case CXt_LOOP_LAZYIV:
1496 case CXt_LOOP_LAZYSV:
1499 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1506 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1509 S_dopoptogivenfor(pTHX_ I32 startingblock)
1512 for (i = startingblock; i >= 0; i--) {
1513 const PERL_CONTEXT *cx = &cxstack[i];
1514 switch (CxTYPE(cx)) {
1518 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1520 case CXt_LOOP_PLAIN:
1521 assert(!(cx->cx_type & CXp_FOR_DEF));
1523 case CXt_LOOP_LAZYIV:
1524 case CXt_LOOP_LAZYSV:
1527 if (cx->cx_type & CXp_FOR_DEF) {
1528 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1537 S_dopoptowhen(pTHX_ I32 startingblock)
1540 for (i = startingblock; i >= 0; i--) {
1541 const PERL_CONTEXT *cx = &cxstack[i];
1542 switch (CxTYPE(cx)) {
1546 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1553 /* dounwind(): pop all contexts above (but not including) cxix.
1554 * Note that it clears the savestack frame associated with each popped
1555 * context entry, but doesn't free any temps.
1556 * It does a cx_popblock() of the last frame that it pops, and leaves
1557 * cxstack_ix equal to cxix.
1561 Perl_dounwind(pTHX_ I32 cxix)
1563 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1566 while (cxstack_ix > cxix) {
1567 PERL_CONTEXT *cx = CX_CUR();
1569 CX_DEBUG(cx, "UNWIND");
1570 /* Note: we don't need to restore the base context info till the end. */
1574 switch (CxTYPE(cx)) {
1577 /* CXt_SUBST is not a block context type, so skip the
1578 * cx_popblock(cx) below */
1579 if (cxstack_ix == cxix + 1) {
1590 case CXt_LOOP_PLAIN:
1591 case CXt_LOOP_LAZYIV:
1592 case CXt_LOOP_LAZYSV:
1605 /* these two don't have a POPFOO() */
1611 if (cxstack_ix == cxix + 1) {
1620 Perl_qerror(pTHX_ SV *err)
1622 PERL_ARGS_ASSERT_QERROR;
1625 if (PL_in_eval & EVAL_KEEPERR) {
1626 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1630 sv_catsv(ERRSV, err);
1633 sv_catsv(PL_errors, err);
1635 Perl_warn(aTHX_ "%" SVf, SVfARG(err));
1637 ++PL_parser->error_count;
1642 /* pop a CXt_EVAL context and in addition, if it was a require then
1644 * 0: do nothing extra;
1645 * 1: undef $INC{$name}; croak "$name did not return a true value";
1646 * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1650 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1652 SV *namesv = NULL; /* init to avoid dumb compiler warning */
1656 do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1658 /* keep namesv alive after cx_popeval() */
1659 namesv = cx->blk_eval.old_namesv;
1660 cx->blk_eval.old_namesv = NULL;
1669 HV *inc_hv = GvHVn(PL_incgv);
1670 I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv);
1671 const char *key = SvPVX_const(namesv);
1674 (void)hv_delete(inc_hv, key, klen, G_DISCARD);
1675 fmt = "%" SVf " did not return a true value";
1679 (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0);
1680 fmt = "%" SVf "Compilation failed in require";
1682 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1685 Perl_croak(aTHX_ fmt, SVfARG(errsv));
1690 /* die_unwind(): this is the final destination for the various croak()
1691 * functions. If we're in an eval, unwind the context and other stacks
1692 * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1693 * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1694 * to is a require the exception will be rethrown, as requires don't
1695 * actually trap exceptions.
1699 Perl_die_unwind(pTHX_ SV *msv)
1702 U8 in_eval = PL_in_eval;
1703 PERL_ARGS_ASSERT_DIE_UNWIND;
1708 /* We need to keep this SV alive through all the stack unwinding
1709 * and FREETMPSing below, while ensuing that it doesn't leak
1710 * if we call out to something which then dies (e.g. sub STORE{die}
1711 * when unlocalising a tied var). So we do a dance with
1712 * mortalising and SAVEFREEing.
1714 sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1717 * Historically, perl used to set ERRSV ($@) early in the die
1718 * process and rely on it not getting clobbered during unwinding.
1719 * That sucked, because it was liable to get clobbered, so the
1720 * setting of ERRSV used to emit the exception from eval{} has
1721 * been moved to much later, after unwinding (see just before
1722 * JMPENV_JUMP below). However, some modules were relying on the
1723 * early setting, by examining $@ during unwinding to use it as
1724 * a flag indicating whether the current unwinding was caused by
1725 * an exception. It was never a reliable flag for that purpose,
1726 * being totally open to false positives even without actual
1727 * clobberage, but was useful enough for production code to
1728 * semantically rely on it.
1730 * We'd like to have a proper introspective interface that
1731 * explicitly describes the reason for whatever unwinding
1732 * operations are currently in progress, so that those modules
1733 * work reliably and $@ isn't further overloaded. But we don't
1734 * have one yet. In its absence, as a stopgap measure, ERRSV is
1735 * now *additionally* set here, before unwinding, to serve as the
1736 * (unreliable) flag that it used to.
1738 * This behaviour is temporary, and should be removed when a
1739 * proper way to detect exceptional unwinding has been developed.
1740 * As of 2010-12, the authors of modules relying on the hack
1741 * are aware of the issue, because the modules failed on
1742 * perls 5.13.{1..7} which had late setting of $@ without this
1743 * early-setting hack.
1745 if (!(in_eval & EVAL_KEEPERR)) {
1746 /* remove any read-only/magic from the SV, so we don't
1747 get infinite recursion when setting ERRSV */
1749 sv_setsv_flags(ERRSV, exceptsv,
1750 (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
1753 if (in_eval & EVAL_KEEPERR) {
1754 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1758 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1759 && PL_curstackinfo->si_prev)
1769 JMPENV *restartjmpenv;
1772 if (cxix < cxstack_ix)
1776 assert(CxTYPE(cx) == CXt_EVAL);
1778 /* return false to the caller of eval */
1779 oldsp = PL_stack_base + cx->blk_oldsp;
1780 gimme = cx->blk_gimme;
1781 if (gimme == G_SCALAR)
1782 *++oldsp = &PL_sv_undef;
1783 PL_stack_sp = oldsp;
1785 restartjmpenv = cx->blk_eval.cur_top_env;
1786 restartop = cx->blk_eval.retop;
1788 /* We need a FREETMPS here to avoid late-called destructors
1789 * clobbering $@ *after* we set it below, e.g.
1790 * sub DESTROY { eval { die "X" } }
1791 * eval { my $x = bless []; die $x = 0, "Y" };
1793 * Here the clearing of the $x ref mortalises the anon array,
1794 * which needs to be freed *before* $& is set to "Y",
1795 * otherwise it gets overwritten with "X".
1797 * However, the FREETMPS will clobber exceptsv, so preserve it
1798 * on the savestack for now.
1800 SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv));
1802 /* now we're about to pop the savestack, so re-mortalise it */
1803 sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1805 /* Note that unlike pp_entereval, pp_require isn't supposed to
1806 * trap errors. So if we're a require, after we pop the
1807 * CXt_EVAL that pp_require pushed, rethrow the error with
1808 * croak(exceptsv). This is all handled by the call below when
1811 S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
1813 if (!(in_eval & EVAL_KEEPERR)) {
1815 sv_setsv(ERRSV, exceptsv);
1817 PL_restartjmpenv = restartjmpenv;
1818 PL_restartop = restartop;
1820 NOT_REACHED; /* NOTREACHED */
1824 write_to_stderr(exceptsv);
1826 NOT_REACHED; /* NOTREACHED */
1832 if (SvTRUE_NN(left) != SvTRUE_NN(right))
1840 =head1 CV Manipulation Functions
1842 =for apidoc caller_cx
1844 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1845 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1846 information returned to Perl by C<caller>. Note that XSUBs don't get a
1847 stack frame, so C<caller_cx(0, NULL)> will return information for the
1848 immediately-surrounding Perl code.
1850 This function skips over the automatic calls to C<&DB::sub> made on the
1851 behalf of the debugger. If the stack frame requested was a sub called by
1852 C<DB::sub>, the return value will be the frame for the call to
1853 C<DB::sub>, since that has the correct line number/etc. for the call
1854 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1855 frame for the sub call itself.
1860 const PERL_CONTEXT *
1861 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1863 I32 cxix = dopoptosub(cxstack_ix);
1864 const PERL_CONTEXT *cx;
1865 const PERL_CONTEXT *ccstack = cxstack;
1866 const PERL_SI *top_si = PL_curstackinfo;
1869 /* we may be in a higher stacklevel, so dig down deeper */
1870 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1871 top_si = top_si->si_prev;
1872 ccstack = top_si->si_cxstack;
1873 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1877 /* caller() should not report the automatic calls to &DB::sub */
1878 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1879 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1883 cxix = dopoptosub_at(ccstack, cxix - 1);
1886 cx = &ccstack[cxix];
1887 if (dbcxp) *dbcxp = cx;
1889 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1890 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1891 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1892 field below is defined for any cx. */
1893 /* caller() should not report the automatic calls to &DB::sub */
1894 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1895 cx = &ccstack[dbcxix];
1904 const PERL_CONTEXT *cx;
1905 const PERL_CONTEXT *dbcx;
1907 const HEK *stash_hek;
1909 bool has_arg = MAXARG && TOPs;
1918 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1920 if (gimme != G_ARRAY) {
1927 CX_DEBUG(cx, "CALLER");
1928 assert(CopSTASH(cx->blk_oldcop));
1929 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1930 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1932 if (gimme != G_ARRAY) {
1935 PUSHs(&PL_sv_undef);
1938 sv_sethek(TARG, stash_hek);
1947 PUSHs(&PL_sv_undef);
1950 sv_sethek(TARG, stash_hek);
1953 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1954 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1955 cx->blk_sub.retop, TRUE);
1957 lcop = cx->blk_oldcop;
1958 mPUSHu(CopLINE(lcop));
1961 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1962 /* So is ccstack[dbcxix]. */
1963 if (CvHASGV(dbcx->blk_sub.cv)) {
1964 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1965 PUSHs(boolSV(CxHASARGS(cx)));
1968 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1969 PUSHs(boolSV(CxHASARGS(cx)));
1973 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1976 gimme = cx->blk_gimme;
1977 if (gimme == G_VOID)
1978 PUSHs(&PL_sv_undef);
1980 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1981 if (CxTYPE(cx) == CXt_EVAL) {
1983 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1984 SV *cur_text = cx->blk_eval.cur_text;
1985 if (SvCUR(cur_text) >= 2) {
1986 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1987 SvUTF8(cur_text)|SVs_TEMP));
1990 /* I think this is will always be "", but be sure */
1991 PUSHs(sv_2mortal(newSVsv(cur_text)));
1997 else if (cx->blk_eval.old_namesv) {
1998 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
2001 /* eval BLOCK (try blocks have old_namesv == 0) */
2003 PUSHs(&PL_sv_undef);
2004 PUSHs(&PL_sv_undef);
2008 PUSHs(&PL_sv_undef);
2009 PUSHs(&PL_sv_undef);
2011 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
2012 && CopSTASH_eq(PL_curcop, PL_debstash))
2014 /* slot 0 of the pad contains the original @_ */
2015 AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
2016 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2017 cx->blk_sub.olddepth+1]))[0]);
2018 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
2020 Perl_init_dbargs(aTHX);
2022 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
2023 av_extend(PL_dbargs, AvFILLp(ary) + off);
2024 if (AvFILLp(ary) + 1 + off)
2025 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
2026 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
2028 mPUSHi(CopHINTS_get(cx->blk_oldcop));
2031 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
2033 if (old_warnings == pWARN_NONE)
2034 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
2035 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
2036 mask = &PL_sv_undef ;
2037 else if (old_warnings == pWARN_ALL ||
2038 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
2039 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
2042 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
2046 PUSHs(cx->blk_oldcop->cop_hints_hash ?
2047 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2057 if (MAXARG < 1 || (!TOPs && !POPs)) {
2059 tmps = NULL, len = 0;
2062 tmps = SvPVx_const(POPs, len);
2063 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
2068 /* like pp_nextstate, but used instead when the debugger is active */
2072 PL_curcop = (COP*)PL_op;
2073 TAINT_NOT; /* Each statement is presumed innocent */
2074 PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
2079 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2080 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2084 const U8 gimme = G_ARRAY;
2085 GV * const gv = PL_DBgv;
2088 if (gv && isGV_with_GP(gv))
2091 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2092 DIE(aTHX_ "No DB::DB routine defined");
2094 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2095 /* don't do recursive DB::DB call */
2105 (void)(*CvXSUB(cv))(aTHX_ cv);
2111 cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
2112 cx_pushsub(cx, cv, PL_op->op_next, 0);
2113 /* OP_DBSTATE's op_private holds hint bits rather than
2114 * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2115 * any CxLVAL() flags that have now been mis-calculated */
2122 if (CvDEPTH(cv) >= 2)
2123 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2124 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2125 RETURNOP(CvSTART(cv));
2137 (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2149 assert(CxTYPE(cx) == CXt_BLOCK);
2151 if (PL_op->op_flags & OPf_SPECIAL)
2152 /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */
2153 cx->blk_oldpm = PL_curpm;
2155 oldsp = PL_stack_base + cx->blk_oldsp;
2156 gimme = cx->blk_gimme;
2158 if (gimme == G_VOID)
2159 PL_stack_sp = oldsp;
2161 leave_adjust_stacks(oldsp, oldsp, gimme,
2162 PL_op->op_private & OPpLVALUE ? 3 : 1);
2172 S_outside_integer(pTHX_ SV *sv)
2175 const NV nv = SvNV_nomg(sv);
2176 if (Perl_isinfnan(nv))
2178 #ifdef NV_PRESERVES_UV
2179 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2182 if (nv <= (NV)IV_MIN)
2185 ((nv > (NV)UV_MAX ||
2186 SvUV_nomg(sv) > (UV)IV_MAX)))
2197 const U8 gimme = GIMME_V;
2198 void *itervarp; /* GV or pad slot of the iteration variable */
2199 SV *itersave; /* the old var in the iterator var slot */
2202 if (PL_op->op_targ) { /* "my" variable */
2203 itervarp = &PAD_SVl(PL_op->op_targ);
2204 itersave = *(SV**)itervarp;
2206 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2207 /* the SV currently in the pad slot is never live during
2208 * iteration (the slot is always aliased to one of the items)
2209 * so it's always stale */
2210 SvPADSTALE_on(itersave);
2212 SvREFCNT_inc_simple_void_NN(itersave);
2213 cxflags = CXp_FOR_PAD;
2216 SV * const sv = POPs;
2217 itervarp = (void *)sv;
2218 if (LIKELY(isGV(sv))) { /* symbol table variable */
2219 itersave = GvSV(sv);
2220 SvREFCNT_inc_simple_void(itersave);
2221 cxflags = CXp_FOR_GV;
2222 if (PL_op->op_private & OPpITER_DEF)
2223 cxflags |= CXp_FOR_DEF;
2225 else { /* LV ref: for \$foo (...) */
2226 assert(SvTYPE(sv) == SVt_PVMG);
2227 assert(SvMAGIC(sv));
2228 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2230 cxflags = CXp_FOR_LVREF;
2233 /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2234 assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2236 /* Note that this context is initially set as CXt_NULL. Further on
2237 * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2238 * there mustn't be anything in the blk_loop substruct that requires
2239 * freeing or undoing, in case we die in the meantime. And vice-versa.
2241 cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2242 cx_pushloop_for(cx, itervarp, itersave);
2244 if (PL_op->op_flags & OPf_STACKED) {
2245 /* OPf_STACKED implies either a single array: for(@), with a
2246 * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2248 SV *maybe_ary = POPs;
2249 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2252 SV * const right = maybe_ary;
2253 if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2254 DIE(aTHX_ "Assigned value is not a reference");
2257 if (RANGE_IS_NUMERIC(sv,right)) {
2258 cx->cx_type |= CXt_LOOP_LAZYIV;
2259 if (S_outside_integer(aTHX_ sv) ||
2260 S_outside_integer(aTHX_ right))
2261 DIE(aTHX_ "Range iterator outside integer range");
2262 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2263 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2266 cx->cx_type |= CXt_LOOP_LAZYSV;
2267 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2268 cx->blk_loop.state_u.lazysv.end = right;
2269 SvREFCNT_inc_simple_void_NN(right);
2270 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2271 /* This will do the upgrade to SVt_PV, and warn if the value
2272 is uninitialised. */
2273 (void) SvPV_nolen_const(right);
2274 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2275 to replace !SvOK() with a pointer to "". */
2277 SvREFCNT_dec(right);
2278 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2282 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2283 /* for (@array) {} */
2284 cx->cx_type |= CXt_LOOP_ARY;
2285 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2286 SvREFCNT_inc_simple_void_NN(maybe_ary);
2287 cx->blk_loop.state_u.ary.ix =
2288 (PL_op->op_private & OPpITER_REVERSED) ?
2289 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2292 /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
2294 else { /* iterating over items on the stack */
2295 cx->cx_type |= CXt_LOOP_LIST;
2296 cx->blk_oldsp = SP - PL_stack_base;
2297 cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2298 cx->blk_loop.state_u.stack.ix =
2299 (PL_op->op_private & OPpITER_REVERSED)
2301 : cx->blk_loop.state_u.stack.basesp;
2302 /* pre-extend stack so pp_iter doesn't have to check every time
2303 * it pushes yes/no */
2313 const U8 gimme = GIMME_V;
2315 cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2316 cx_pushloop_plain(cx);
2329 assert(CxTYPE_is_LOOP(cx));
2330 oldsp = PL_stack_base + cx->blk_oldsp;
2331 base = CxTYPE(cx) == CXt_LOOP_LIST
2332 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2334 gimme = cx->blk_gimme;
2336 if (gimme == G_VOID)
2339 leave_adjust_stacks(oldsp, base, gimme,
2340 PL_op->op_private & OPpLVALUE ? 3 : 1);
2343 cx_poploop(cx); /* Stack values are safe: release loop vars ... */
2351 /* This duplicates most of pp_leavesub, but with additional code to handle
2352 * return args in lvalue context. It was forked from pp_leavesub to
2353 * avoid slowing down that function any further.
2355 * Any changes made to this function may need to be copied to pp_leavesub
2358 * also tail-called by pp_return
2369 assert(CxTYPE(cx) == CXt_SUB);
2371 if (CxMULTICALL(cx)) {
2372 /* entry zero of a stack is always PL_sv_undef, which
2373 * simplifies converting a '()' return into undef in scalar context */
2374 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2378 gimme = cx->blk_gimme;
2379 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2381 if (gimme == G_VOID)
2382 PL_stack_sp = oldsp;
2384 U8 lval = CxLVAL(cx);
2385 bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2386 const char *what = NULL;
2388 if (gimme == G_SCALAR) {
2390 /* check for bad return arg */
2391 if (oldsp < PL_stack_sp) {
2392 SV *sv = *PL_stack_sp;
2393 if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2395 SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2396 : "a readonly value" : "a temporary";
2401 /* sub:lvalue{} will take us here. */
2406 "Can't return %s from lvalue subroutine", what);
2410 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2412 if (lval & OPpDEREF) {
2413 /* lval_sub()->{...} and similar */
2417 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2423 assert(gimme == G_ARRAY);
2424 assert (!(lval & OPpDEREF));
2427 /* scan for bad return args */
2429 for (p = PL_stack_sp; p > oldsp; p--) {
2431 /* the PL_sv_undef exception is to allow things like
2432 * this to work, where PL_sv_undef acts as 'skip'
2433 * placeholder on the LHS of list assigns:
2434 * sub foo :lvalue { undef }
2435 * ($a, undef, foo(), $b) = 1..4;
2437 if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2439 /* Might be flattened array after $#array = */
2440 what = SvREADONLY(sv)
2441 ? "a readonly value" : "a temporary";
2447 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2452 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
2454 retop = cx->blk_sub.retop;
2465 const I32 cxix = dopoptosub(cxstack_ix);
2467 assert(cxstack_ix >= 0);
2468 if (cxix < cxstack_ix) {
2470 if (!( PL_curstackinfo->si_type == PERLSI_SORT
2471 || ( PL_curstackinfo->si_type == PERLSI_MULTICALL
2472 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2475 DIE(aTHX_ "Can't return outside a subroutine");
2477 * a sort block, which is a CXt_NULL not a CXt_SUB;
2478 * or a /(?{...})/ block.
2479 * Handle specially. */
2480 assert(CxTYPE(&cxstack[0]) == CXt_NULL
2481 || ( CxTYPE(&cxstack[0]) == CXt_SUB
2482 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2483 if (cxstack_ix > 0) {
2484 /* See comment below about context popping. Since we know
2485 * we're scalar and not lvalue, we can preserve the return
2486 * value in a simpler fashion than there. */
2488 assert(cxstack[0].blk_gimme == G_SCALAR);
2489 if ( (sp != PL_stack_base)
2490 && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2492 *SP = sv_mortalcopy(sv);
2495 /* caller responsible for popping cxstack[0] */
2499 /* There are contexts that need popping. Doing this may free the
2500 * return value(s), so preserve them first: e.g. popping the plain
2501 * loop here would free $x:
2502 * sub f { { my $x = 1; return $x } }
2503 * We may also need to shift the args down; for example,
2504 * for (1,2) { return 3,4 }
2505 * leaves 1,2,3,4 on the stack. Both these actions will be done by
2506 * leave_adjust_stacks(), along with freeing any temps. Note that
2507 * whoever we tail-call (e.g. pp_leaveeval) will also call
2508 * leave_adjust_stacks(); however, the second call is likely to
2509 * just see a bunch of SvTEMPs with a ref count of 1, and so just
2510 * pass them through, rather than copying them again. So this
2511 * isn't as inefficient as it sounds.
2513 cx = &cxstack[cxix];
2515 if (cx->blk_gimme != G_VOID)
2516 leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2518 CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2522 cx = &cxstack[cxix]; /* CX stack may have been realloced */
2525 /* Like in the branch above, we need to handle any extra junk on
2526 * the stack. But because we're not also popping extra contexts, we
2527 * don't have to worry about prematurely freeing args. So we just
2528 * need to do the bare minimum to handle junk, and leave the main
2529 * arg processing in the function we tail call, e.g. pp_leavesub.
2530 * In list context we have to splice out the junk; in scalar
2531 * context we can leave as-is (pp_leavesub will later return the
2532 * top stack element). But for an empty arg list, e.g.
2533 * for (1,2) { return }
2534 * we need to set sp = oldsp so that pp_leavesub knows to push
2535 * &PL_sv_undef onto the stack.
2538 cx = &cxstack[cxix];
2539 oldsp = PL_stack_base + cx->blk_oldsp;
2540 if (oldsp != MARK) {
2541 SSize_t nargs = SP - MARK;
2543 if (cx->blk_gimme == G_ARRAY) {
2544 /* shift return args to base of call stack frame */
2545 Move(MARK + 1, oldsp + 1, nargs, SV*);
2546 PL_stack_sp = oldsp + nargs;
2550 PL_stack_sp = oldsp;
2554 /* fall through to a normal exit */
2555 switch (CxTYPE(cx)) {
2557 return CxTRYBLOCK(cx)
2558 ? Perl_pp_leavetry(aTHX)
2559 : Perl_pp_leaveeval(aTHX);
2561 return CvLVALUE(cx->blk_sub.cv)
2562 ? Perl_pp_leavesublv(aTHX)
2563 : Perl_pp_leavesub(aTHX);
2565 return Perl_pp_leavewrite(aTHX);
2567 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2571 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2573 static PERL_CONTEXT *
2577 if (PL_op->op_flags & OPf_SPECIAL) {
2578 cxix = dopoptoloop(cxstack_ix);
2580 /* diag_listed_as: Can't "last" outside a loop block */
2581 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2587 const char * const label =
2588 PL_op->op_flags & OPf_STACKED
2589 ? SvPV(TOPs,label_len)
2590 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2591 const U32 label_flags =
2592 PL_op->op_flags & OPf_STACKED
2594 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2596 cxix = dopoptolabel(label, label_len, label_flags);
2598 /* diag_listed_as: Label not found for "last %s" */
2599 Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"",
2601 SVfARG(PL_op->op_flags & OPf_STACKED
2602 && !SvGMAGICAL(TOPp1s)
2604 : newSVpvn_flags(label,
2606 label_flags | SVs_TEMP)));
2608 if (cxix < cxstack_ix)
2610 return &cxstack[cxix];
2619 cx = S_unwind_loop(aTHX);
2621 assert(CxTYPE_is_LOOP(cx));
2622 PL_stack_sp = PL_stack_base
2623 + (CxTYPE(cx) == CXt_LOOP_LIST
2624 ? cx->blk_loop.state_u.stack.basesp
2630 /* Stack values are safe: */
2632 cx_poploop(cx); /* release loop vars ... */
2634 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2644 /* if not a bare 'next' in the main scope, search for it */
2646 if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
2647 cx = S_unwind_loop(aTHX);
2650 PL_curcop = cx->blk_oldcop;
2652 return (cx)->blk_loop.my_op->op_nextop;
2657 PERL_CONTEXT *cx = S_unwind_loop(aTHX);
2658 OP* redo_op = cx->blk_loop.my_op->op_redoop;
2660 if (redo_op->op_type == OP_ENTER) {
2661 /* pop one less context to avoid $x being freed in while (my $x..) */
2664 assert(CxTYPE(cx) == CXt_BLOCK);
2665 redo_op = redo_op->op_next;
2671 PL_curcop = cx->blk_oldcop;
2676 #define UNENTERABLE (OP *)1
2677 #define GOTO_DEPTH 64
2680 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2683 static const char* const too_deep = "Target of goto is too deeply nested";
2685 PERL_ARGS_ASSERT_DOFINDLABEL;
2688 Perl_croak(aTHX_ "%s", too_deep);
2689 if (o->op_type == OP_LEAVE ||
2690 o->op_type == OP_SCOPE ||
2691 o->op_type == OP_LEAVELOOP ||
2692 o->op_type == OP_LEAVESUB ||
2693 o->op_type == OP_LEAVETRY ||
2694 o->op_type == OP_LEAVEGIVEN)
2696 *ops++ = cUNOPo->op_first;
2698 else if (oplimit - opstack < GOTO_DEPTH) {
2699 if (o->op_flags & OPf_KIDS
2700 && cUNOPo->op_first->op_type == OP_PUSHMARK) {
2701 *ops++ = UNENTERABLE;
2703 else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type]
2704 && OP_CLASS(o) != OA_LOGOP
2705 && o->op_type != OP_LINESEQ
2706 && o->op_type != OP_SREFGEN
2707 && o->op_type != OP_ENTEREVAL
2708 && o->op_type != OP_GLOB
2709 && o->op_type != OP_RV2CV) {
2710 OP * const kid = cUNOPo->op_first;
2711 if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid))
2712 *ops++ = UNENTERABLE;
2716 Perl_croak(aTHX_ "%s", too_deep);
2718 if (o->op_flags & OPf_KIDS) {
2720 OP * const kid1 = cUNOPo->op_first;
2721 /* First try all the kids at this level, since that's likeliest. */
2722 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2723 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2724 STRLEN kid_label_len;
2725 U32 kid_label_flags;
2726 const char *kid_label = CopLABEL_len_flags(kCOP,
2727 &kid_label_len, &kid_label_flags);
2729 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2732 (const U8*)kid_label, kid_label_len,
2733 (const U8*)label, len) == 0)
2735 (const U8*)label, len,
2736 (const U8*)kid_label, kid_label_len) == 0)
2737 : ( len == kid_label_len && ((kid_label == label)
2738 || memEQ(kid_label, label, len)))))
2742 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2743 bool first_kid_of_binary = FALSE;
2744 if (kid == PL_lastgotoprobe)
2746 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2749 else if (ops[-1] != UNENTERABLE
2750 && (ops[-1]->op_type == OP_NEXTSTATE ||
2751 ops[-1]->op_type == OP_DBSTATE))
2756 if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) {
2757 first_kid_of_binary = TRUE;
2760 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2762 if (first_kid_of_binary)
2763 *ops++ = UNENTERABLE;
2772 S_check_op_type(pTHX_ OP * const o)
2774 /* Eventually we may want to stack the needed arguments
2775 * for each op. For now, we punt on the hard ones. */
2776 /* XXX This comment seems to me like wishful thinking. --sprout */
2777 if (o == UNENTERABLE)
2779 "Can't \"goto\" into a binary or list expression");
2780 if (o->op_type == OP_ENTERITER)
2782 "Can't \"goto\" into the middle of a foreach loop");
2783 if (o->op_type == OP_ENTERGIVEN)
2785 "Can't \"goto\" into a \"given\" block");
2788 /* also used for: pp_dump() */
2796 OP *enterops[GOTO_DEPTH];
2797 const char *label = NULL;
2798 STRLEN label_len = 0;
2799 U32 label_flags = 0;
2800 const bool do_dump = (PL_op->op_type == OP_DUMP);
2801 static const char* const must_have_label = "goto must have label";
2803 if (PL_op->op_flags & OPf_STACKED) {
2804 /* goto EXPR or goto &foo */
2806 SV * const sv = POPs;
2809 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2810 /* This egregious kludge implements goto &subroutine */
2813 CV *cv = MUTABLE_CV(SvRV(sv));
2814 AV *arg = GvAV(PL_defgv);
2816 while (!CvROOT(cv) && !CvXSUB(cv)) {
2817 const GV * const gv = CvGV(cv);
2821 /* autoloaded stub? */
2822 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2824 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2826 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2827 if (autogv && (cv = GvCV(autogv)))
2829 tmpstr = sv_newmortal();
2830 gv_efullname3(tmpstr, gv, NULL);
2831 DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
2833 DIE(aTHX_ "Goto undefined subroutine");
2836 cxix = dopoptosub(cxstack_ix);
2838 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2840 cx = &cxstack[cxix];
2841 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2842 if (CxTYPE(cx) == CXt_EVAL) {
2844 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2845 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2847 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2848 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2850 else if (CxMULTICALL(cx))
2851 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2853 /* First do some returnish stuff. */
2855 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2857 if (cxix < cxstack_ix) {
2864 /* protect @_ during save stack unwind. */
2866 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
2868 assert(PL_scopestack_ix == cx->blk_oldscopesp);
2871 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2872 /* this is part of cx_popsub_args() */
2873 AV* av = MUTABLE_AV(PAD_SVl(0));
2874 assert(AvARRAY(MUTABLE_AV(
2875 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2876 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2878 /* we are going to donate the current @_ from the old sub
2879 * to the new sub. This first part of the donation puts a
2880 * new empty AV in the pad[0] slot of the old sub,
2881 * unless pad[0] and @_ differ (e.g. if the old sub did
2882 * local *_ = []); in which case clear the old pad[0]
2883 * array in the usual way */
2884 if (av == arg || AvREAL(av))
2885 clear_defarray(av, av == arg);
2886 else CLEAR_ARGARRAY(av);
2889 /* don't restore PL_comppad here. It won't be needed if the
2890 * sub we're going to is non-XS, but restoring it early then
2891 * croaking (e.g. the "Goto undefined subroutine" below)
2892 * means the CX block gets processed again in dounwind,
2893 * but this time with the wrong PL_comppad */
2895 /* A destructor called during LEAVE_SCOPE could have undefined
2896 * our precious cv. See bug #99850. */
2897 if (!CvROOT(cv) && !CvXSUB(cv)) {
2898 const GV * const gv = CvGV(cv);
2900 SV * const tmpstr = sv_newmortal();
2901 gv_efullname3(tmpstr, gv, NULL);
2902 DIE(aTHX_ "Goto undefined subroutine &%" SVf,
2905 DIE(aTHX_ "Goto undefined subroutine");
2908 if (CxTYPE(cx) == CXt_SUB) {
2909 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2910 SvREFCNT_dec_NN(cx->blk_sub.cv);
2913 /* Now do some callish stuff. */
2915 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2916 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2921 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2923 /* put GvAV(defgv) back onto stack */
2925 EXTEND(SP, items+1); /* @_ could have been extended. */
2930 bool r = cBOOL(AvREAL(arg));
2931 for (index=0; index<items; index++)
2935 SV ** const svp = av_fetch(arg, index, 0);
2936 sv = svp ? *svp : NULL;
2938 else sv = AvARRAY(arg)[index];
2940 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2941 : sv_2mortal(newSVavdefelem(arg, index, 1));
2945 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2946 /* Restore old @_ */
2947 CX_POP_SAVEARRAY(cx);
2950 retop = cx->blk_sub.retop;
2951 PL_comppad = cx->blk_sub.prevcomppad;
2952 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2954 /* XS subs don't have a CXt_SUB, so pop it;
2955 * this is a cx_popblock(), less all the stuff we already did
2956 * for cx_topblock() earlier */
2957 PL_curcop = cx->blk_oldcop;
2960 /* Push a mark for the start of arglist */
2963 (void)(*CvXSUB(cv))(aTHX_ cv);
2968 PADLIST * const padlist = CvPADLIST(cv);
2970 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2972 /* partial unrolled cx_pushsub(): */
2974 cx->blk_sub.cv = cv;
2975 cx->blk_sub.olddepth = CvDEPTH(cv);
2978 SvREFCNT_inc_simple_void_NN(cv);
2979 if (CvDEPTH(cv) > 1) {
2980 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2981 sub_crush_depth(cv);
2982 pad_push(padlist, CvDEPTH(cv));
2984 PL_curcop = cx->blk_oldcop;
2985 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2988 /* second half of donating @_ from the old sub to the
2989 * new sub: abandon the original pad[0] AV in the
2990 * new sub, and replace it with the donated @_.
2991 * pad[0] takes ownership of the extra refcount
2992 * we gave arg earlier */
2994 SvREFCNT_dec(PAD_SVl(0));
2995 PAD_SVl(0) = (SV *)arg;
2996 SvREFCNT_inc_simple_void_NN(arg);
2999 /* GvAV(PL_defgv) might have been modified on scope
3000 exit, so point it at arg again. */
3001 if (arg != GvAV(PL_defgv)) {
3002 AV * const av = GvAV(PL_defgv);
3003 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
3008 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
3009 Perl_get_db_sub(aTHX_ NULL, cv);
3011 CV * const gotocv = get_cvs("DB::goto", 0);
3013 PUSHMARK( PL_stack_sp );
3014 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
3019 retop = CvSTART(cv);
3020 goto putback_return;
3025 label = SvPV_nomg_const(sv, label_len);
3026 label_flags = SvUTF8(sv);
3029 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
3030 /* goto LABEL or dump LABEL */
3031 label = cPVOP->op_pv;
3032 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
3033 label_len = strlen(label);
3035 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
3040 OP *gotoprobe = NULL;
3041 bool leaving_eval = FALSE;
3042 bool in_block = FALSE;
3043 bool pseudo_block = FALSE;
3044 PERL_CONTEXT *last_eval_cx = NULL;
3048 PL_lastgotoprobe = NULL;
3050 for (ix = cxstack_ix; ix >= 0; ix--) {
3052 switch (CxTYPE(cx)) {
3054 leaving_eval = TRUE;
3055 if (!CxTRYBLOCK(cx)) {
3056 gotoprobe = (last_eval_cx ?
3057 last_eval_cx->blk_eval.old_eval_root :
3062 /* else fall through */
3063 case CXt_LOOP_PLAIN:
3064 case CXt_LOOP_LAZYIV:
3065 case CXt_LOOP_LAZYSV:
3070 gotoprobe = OpSIBLING(cx->blk_oldcop);
3076 gotoprobe = OpSIBLING(cx->blk_oldcop);
3079 gotoprobe = PL_main_root;
3082 gotoprobe = CvROOT(cx->blk_sub.cv);
3083 pseudo_block = cBOOL(CxMULTICALL(cx));
3087 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3090 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3091 CxTYPE(cx), (long) ix);
3092 gotoprobe = PL_main_root;
3098 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3099 enterops, enterops + GOTO_DEPTH);
3102 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3103 sibl1->op_type == OP_UNSTACK &&
3104 (sibl2 = OpSIBLING(sibl1)))
3106 retop = dofindlabel(sibl2,
3107 label, label_len, label_flags, enterops,
3108 enterops + GOTO_DEPTH);
3114 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3115 PL_lastgotoprobe = gotoprobe;
3118 DIE(aTHX_ "Can't find label %" UTF8f,
3119 UTF8fARG(label_flags, label_len, label));
3121 /* if we're leaving an eval, check before we pop any frames
3122 that we're not going to punt, otherwise the error
3125 if (leaving_eval && *enterops && enterops[1]) {
3127 for (i = 1; enterops[i]; i++)
3128 S_check_op_type(aTHX_ enterops[i]);
3131 if (*enterops && enterops[1]) {
3132 I32 i = enterops[1] != UNENTERABLE
3133 && enterops[1]->op_type == OP_ENTER && in_block
3137 deprecate("\"goto\" to jump into a construct");
3140 /* pop unwanted frames */
3142 if (ix < cxstack_ix) {
3144 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3150 /* push wanted frames */
3152 if (*enterops && enterops[1]) {
3153 OP * const oldop = PL_op;
3154 ix = enterops[1] != UNENTERABLE
3155 && enterops[1]->op_type == OP_ENTER && in_block
3158 for (; enterops[ix]; ix++) {
3159 PL_op = enterops[ix];
3160 S_check_op_type(aTHX_ PL_op);
3161 DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n",
3163 PL_op->op_ppaddr(aTHX);
3171 if (!retop) retop = PL_main_start;
3173 PL_restartop = retop;
3174 PL_do_undump = TRUE;
3178 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3179 PL_do_undump = FALSE;
3197 anum = 0; (void)POPs;
3203 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3206 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3209 PL_exit_flags |= PERL_EXIT_EXPECTED;
3211 PUSHs(&PL_sv_undef);
3218 S_save_lines(pTHX_ AV *array, SV *sv)
3220 const char *s = SvPVX_const(sv);
3221 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3224 PERL_ARGS_ASSERT_SAVE_LINES;
3226 while (s && s < send) {
3228 SV * const tmpstr = newSV_type(SVt_PVMG);
3230 t = (const char *)memchr(s, '\n', send - s);
3236 sv_setpvn(tmpstr, s, t - s);
3237 av_store(array, line++, tmpstr);
3245 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3247 0 is used as continue inside eval,
3249 3 is used for a die caught by an inner eval - continue inner loop
3251 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3252 establish a local jmpenv to handle exception traps.
3257 S_docatch(pTHX_ Perl_ppaddr_t firstpp)
3260 OP * const oldop = PL_op;
3263 assert(CATCH_GET == TRUE);
3268 PL_op = firstpp(aTHX);
3273 /* die caught by an inner eval - continue inner loop */
3274 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3275 PL_restartjmpenv = NULL;
3276 PL_op = PL_restartop;
3285 NOT_REACHED; /* NOTREACHED */
3294 =for apidoc find_runcv
3296 Locate the CV corresponding to the currently executing sub or eval.
3297 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3298 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3299 entered. (This allows debuggers to eval in the scope of the breakpoint
3300 rather than in the scope of the debugger itself.)
3306 Perl_find_runcv(pTHX_ U32 *db_seqp)
3308 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3311 /* If this becomes part of the API, it might need a better name. */
3313 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3320 PL_curcop == &PL_compiling
3322 : PL_curcop->cop_seq;
3324 for (si = PL_curstackinfo; si; si = si->si_prev) {
3326 for (ix = si->si_cxix; ix >= 0; ix--) {
3327 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3329 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3330 cv = cx->blk_sub.cv;
3331 /* skip DB:: code */
3332 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3333 *db_seqp = cx->blk_oldcop->cop_seq;
3336 if (cx->cx_type & CXp_SUB_RE)
3339 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3340 cv = cx->blk_eval.cv;
3343 case FIND_RUNCV_padid_eq:
3345 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3348 case FIND_RUNCV_level_eq:
3349 if (level++ != arg) continue;
3357 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3361 /* Run yyparse() in a setjmp wrapper. Returns:
3362 * 0: yyparse() successful
3363 * 1: yyparse() failed
3367 S_try_yyparse(pTHX_ int gramtype)
3372 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3376 ret = yyparse(gramtype) ? 1 : 0;
3383 NOT_REACHED; /* NOTREACHED */
3390 /* Compile a require/do or an eval ''.
3392 * outside is the lexically enclosing CV (if any) that invoked us.
3393 * seq is the current COP scope value.
3394 * hh is the saved hints hash, if any.
3396 * Returns a bool indicating whether the compile was successful; if so,
3397 * PL_eval_start contains the first op of the compiled code; otherwise,
3400 * This function is called from two places: pp_require and pp_entereval.
3401 * These can be distinguished by whether PL_op is entereval.
3405 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3408 OP * const saveop = PL_op;
3409 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3410 COP * const oldcurcop = PL_curcop;
3411 bool in_require = (saveop->op_type == OP_REQUIRE);
3415 PL_in_eval = (in_require
3416 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3418 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3419 ? EVAL_RE_REPARSING : 0)));
3423 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3425 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3426 CX_CUR()->blk_eval.cv = evalcv;
3427 CX_CUR()->blk_gimme = gimme;
3429 CvOUTSIDE_SEQ(evalcv) = seq;
3430 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3432 /* set up a scratch pad */
3434 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3435 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3438 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3440 /* make sure we compile in the right package */
3442 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3443 SAVEGENERICSV(PL_curstash);
3444 PL_curstash = (HV *)CopSTASH(PL_curcop);
3445 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3447 SvREFCNT_inc_simple_void(PL_curstash);
3448 save_item(PL_curstname);
3449 sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash));
3452 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3453 SAVESPTR(PL_beginav);
3454 PL_beginav = newAV();
3455 SAVEFREESV(PL_beginav);
3456 SAVESPTR(PL_unitcheckav);
3457 PL_unitcheckav = newAV();
3458 SAVEFREESV(PL_unitcheckav);
3461 ENTER_with_name("evalcomp");
3462 SAVESPTR(PL_compcv);
3465 /* try to compile it */
3467 PL_eval_root = NULL;
3468 PL_curcop = &PL_compiling;
3469 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3470 PL_in_eval |= EVAL_KEEPERR;
3477 hv_clear(GvHV(PL_hintgv));
3480 PL_hints = saveop->op_private & OPpEVAL_COPHH
3481 ? oldcurcop->cop_hints : (U32)saveop->op_targ;
3483 /* making 'use re eval' not be in scope when compiling the
3484 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3485 * infinite recursion when S_has_runtime_code() gives a false
3486 * positive: the second time round, HINT_RE_EVAL isn't set so we
3487 * don't bother calling S_has_runtime_code() */
3488 if (PL_in_eval & EVAL_RE_REPARSING)
3489 PL_hints &= ~HINT_RE_EVAL;
3492 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3493 SvREFCNT_dec(GvHV(PL_hintgv));
3494 GvHV(PL_hintgv) = hh;
3497 SAVECOMPILEWARNINGS();
3499 if (PL_dowarn & G_WARN_ALL_ON)
3500 PL_compiling.cop_warnings = pWARN_ALL ;
3501 else if (PL_dowarn & G_WARN_ALL_OFF)
3502 PL_compiling.cop_warnings = pWARN_NONE ;
3504 PL_compiling.cop_warnings = pWARN_STD ;
3507 PL_compiling.cop_warnings =
3508 DUP_WARNINGS(oldcurcop->cop_warnings);
3509 cophh_free(CopHINTHASH_get(&PL_compiling));
3510 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3511 /* The label, if present, is the first entry on the chain. So rather
3512 than writing a blank label in front of it (which involves an
3513 allocation), just use the next entry in the chain. */
3514 PL_compiling.cop_hints_hash
3515 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3516 /* Check the assumption that this removed the label. */
3517 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3520 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3523 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3525 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3526 * so honour CATCH_GET and trap it here if necessary */
3529 /* compile the code */
3530 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3532 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3537 /* note that if yystatus == 3, then the require/eval died during
3538 * compilation, so the EVAL CX block has already been popped, and
3539 * various vars restored */
3540 if (yystatus != 3) {
3542 op_free(PL_eval_root);
3543 PL_eval_root = NULL;
3545 SP = PL_stack_base + POPMARK; /* pop original mark */
3547 assert(CxTYPE(cx) == CXt_EVAL);
3548 /* pop the CXt_EVAL, and if was a require, croak */
3549 S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
3552 /* die_unwind() re-croaks when in require, having popped the
3553 * require EVAL context. So we should never catch a require
3555 assert(!in_require);
3558 if (!*(SvPV_nolen_const(errsv)))
3559 sv_setpvs(errsv, "Compilation error");
3561 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3566 /* Compilation successful. Now clean up */
3568 LEAVE_with_name("evalcomp");
3570 CopLINE_set(&PL_compiling, 0);
3571 SAVEFREEOP(PL_eval_root);
3572 cv_forget_slab(evalcv);
3574 DEBUG_x(dump_eval());
3576 /* Register with debugger: */
3577 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3578 CV * const cv = get_cvs("DB::postponed", 0);
3582 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3584 call_sv(MUTABLE_SV(cv), G_DISCARD);
3588 if (PL_unitcheckav) {
3589 OP *es = PL_eval_start;
3590 call_list(PL_scopestack_ix, PL_unitcheckav);
3594 CvDEPTH(evalcv) = 1;
3595 SP = PL_stack_base + POPMARK; /* pop original mark */
3596 PL_op = saveop; /* The caller may need it. */
3597 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3603 /* Return NULL if the file doesn't exist or isn't a file;
3604 * else return PerlIO_openn().
3608 S_check_type_and_open(pTHX_ SV *name)
3613 const char *p = SvPV_const(name, len);
3616 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3618 /* checking here captures a reasonable error message when
3619 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3620 * user gets a confusing message about looking for the .pmc file
3621 * rather than for the .pm file so do the check in S_doopen_pm when
3622 * PMC is on instead of here. S_doopen_pm calls this func.
3623 * This check prevents a \0 in @INC causing problems.
3625 #ifdef PERL_DISABLE_PMC
3626 if (!IS_SAFE_PATHNAME(p, len, "require"))
3630 /* on Win32 stat is expensive (it does an open() and close() twice and
3631 a couple other IO calls), the open will fail with a dir on its own with
3632 errno EACCES, so only do a stat to separate a dir from a real EACCES
3633 caused by user perms */
3635 st_rc = PerlLIO_stat(p, &st);
3641 if(S_ISBLK(st.st_mode)) {
3645 else if(S_ISDIR(st.st_mode)) {
3654 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3656 /* EACCES stops the INC search early in pp_require to implement
3657 feature RT #113422 */
3658 if(!retio && errno == EACCES) { /* exists but probably a directory */
3660 st_rc = PerlLIO_stat(p, &st);
3662 if(S_ISDIR(st.st_mode))
3664 else if(S_ISBLK(st.st_mode))
3675 /* doopen_pm(): return the equivalent of PerlIO_openn() on the given name,
3676 * but first check for bad names (\0) and non-files.
3677 * Also if the filename ends in .pm and unless PERL_DISABLE_PMC,
3678 * try loading Foo.pmc first.
3680 #ifndef PERL_DISABLE_PMC
3682 S_doopen_pm(pTHX_ SV *name)
3685 const char *p = SvPV_const(name, namelen);
3687 PERL_ARGS_ASSERT_DOOPEN_PM;
3689 /* check the name before trying for the .pmc name to avoid the
3690 * warning referring to the .pmc which the user probably doesn't
3691 * know or care about
3693 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3696 if (memENDPs(p, namelen, ".pm")) {
3697 SV *const pmcsv = sv_newmortal();
3700 SvSetSV_nosteal(pmcsv,name);
3701 sv_catpvs(pmcsv, "c");
3703 pmcio = check_type_and_open(pmcsv);
3707 return check_type_and_open(name);
3710 # define doopen_pm(name) check_type_and_open(name)
3711 #endif /* !PERL_DISABLE_PMC */
3713 /* require doesn't search in @INC for absolute names, or when the name is
3714 explicitly relative the current directory: i.e. ./, ../ */
3715 PERL_STATIC_INLINE bool
3716 S_path_is_searchable(const char *name)
3718 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3720 if (PERL_FILE_IS_ABSOLUTE(name)
3722 || (*name == '.' && ((name[1] == '/' ||
3723 (name[1] == '.' && name[2] == '/'))
3724 || (name[1] == '\\' ||
3725 ( name[1] == '.' && name[2] == '\\')))
3728 || (*name == '.' && (name[1] == '/' ||
3729 (name[1] == '.' && name[2] == '/')))
3740 /* implement 'require 5.010001' */
3743 S_require_version(pTHX_ SV *sv)
3747 sv = sv_2mortal(new_version(sv));
3748 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3749 upg_version(PL_patchlevel, TRUE);
3750 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3751 if ( vcmp(sv,PL_patchlevel) <= 0 )
3752 DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
3753 SVfARG(sv_2mortal(vnormal(sv))),
3754 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3758 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3761 SV * const req = SvRV(sv);
3762 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3764 /* get the left hand term */
3765 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3767 first = SvIV(*av_fetch(lav,0,0));
3768 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3769 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3770 || av_tindex(lav) > 1 /* FP with > 3 digits */
3771 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3773 DIE(aTHX_ "Perl %" SVf " required--this is only "
3774 "%" SVf ", stopped",
3775 SVfARG(sv_2mortal(vnormal(req))),
3776 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3779 else { /* probably 'use 5.10' or 'use 5.8' */
3783 if (av_tindex(lav)>=1)
3784 second = SvIV(*av_fetch(lav,1,0));
3786 second /= second >= 600 ? 100 : 10;
3787 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3788 (int)first, (int)second);
3789 upg_version(hintsv, TRUE);
3791 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)"
3792 "--this is only %" SVf ", stopped",
3793 SVfARG(sv_2mortal(vnormal(req))),
3794 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3795 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3804 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
3805 * The first form will have already been converted at compile time to
3806 * the second form */
3809 S_require_file(pTHX_ SV *sv)
3819 int vms_unixname = 0;
3822 /* tryname is the actual pathname (with @INC prefix) which was loaded.
3823 * It's stored as a value in %INC, and used for error messages */
3824 const char *tryname = NULL;
3825 SV *namesv = NULL; /* SV equivalent of tryname */
3826 const U8 gimme = GIMME_V;
3827 int filter_has_file = 0;
3828 PerlIO *tryrsfp = NULL;
3829 SV *filter_cache = NULL;
3830 SV *filter_state = NULL;
3831 SV *filter_sub = NULL;
3835 bool path_searchable;
3836 I32 old_savestack_ix;
3837 const bool op_is_require = PL_op->op_type == OP_REQUIRE;
3838 const char *const op_name = op_is_require ? "require" : "do";
3839 SV ** svp_cached = NULL;
3841 assert(op_is_require || PL_op->op_type == OP_DOFILE);
3844 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3845 name = SvPV_nomg_const(sv, len);
3846 if (!(name && len > 0 && *name))
3847 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3850 /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */
3851 if (op_is_require) {
3852 /* can optimize to only perform one single lookup */
3853 svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0);
3854 if ( svp_cached && *svp_cached != &PL_sv_undef ) RETPUSHYES;
3858 if (!IS_SAFE_PATHNAME(name, len, op_name)) {
3859 if (!op_is_require) {
3863 DIE(aTHX_ "Can't locate %s: %s",
3864 pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
3865 NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3868 TAINT_PROPER(op_name);
3870 path_searchable = path_is_searchable(name);
3873 /* The key in the %ENV hash is in the syntax of file passed as the argument
3874 * usually this is in UNIX format, but sometimes in VMS format, which
3875 * can result in a module being pulled in more than once.
3876 * To prevent this, the key must be stored in UNIX format if the VMS
3877 * name can be translated to UNIX.
3881 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3883 unixlen = strlen(unixname);
3889 /* if not VMS or VMS name can not be translated to UNIX, pass it
3892 unixname = (char *) name;
3895 if (op_is_require) {
3896 /* reuse the previous hv_fetch result if possible */
3897 SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3899 if (*svp != &PL_sv_undef)
3902 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3903 "Compilation failed in require", unixname);
3906 /*XXX OPf_KIDS should always be true? -dapm 4/2017 */
3907 if (PL_op->op_flags & OPf_KIDS) {
3908 SVOP * const kid = (SVOP*)cUNOP->op_first;
3910 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3911 /* Make sure that a bareword module name (e.g. ::Foo::Bar)
3912 * doesn't map to a naughty pathname like /Foo/Bar.pm.
3913 * Note that the parser will normally detect such errors
3914 * at compile time before we reach here, but
3915 * Perl_load_module() can fake up an identical optree
3916 * without going near the parser, and being able to put
3917 * anything as the bareword. So we include a duplicate set
3918 * of checks here at runtime.
3920 const STRLEN package_len = len - 3;
3921 const char slashdot[2] = {'/', '.'};
3923 const char backslashdot[2] = {'\\', '.'};
3926 /* Disallow *purported* barewords that map to absolute
3927 filenames, filenames relative to the current or parent
3928 directory, or (*nix) hidden filenames. Also sanity check
3929 that the generated filename ends .pm */
3930 if (!path_searchable || len < 3 || name[0] == '.'
3931 || !memEQs(name + package_len, len - package_len, ".pm"))
3932 DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv);
3933 if (memchr(name, 0, package_len)) {
3934 /* diag_listed_as: Bareword in require contains "%s" */
3935 DIE(aTHX_ "Bareword in require contains \"\\0\"");
3937 if (ninstr(name, name + package_len, slashdot,
3938 slashdot + sizeof(slashdot))) {
3939 /* diag_listed_as: Bareword in require contains "%s" */
3940 DIE(aTHX_ "Bareword in require contains \"/.\"");
3943 if (ninstr(name, name + package_len, backslashdot,
3944 backslashdot + sizeof(backslashdot))) {
3945 /* diag_listed_as: Bareword in require contains "%s" */
3946 DIE(aTHX_ "Bareword in require contains \"\\.\"");
3953 PERL_DTRACE_PROBE_FILE_LOADING(unixname);
3955 /* Try to locate and open a file, possibly using @INC */
3957 /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load
3958 * the file directly rather than via @INC ... */
3959 if (!path_searchable) {
3960 /* At this point, name is SvPVX(sv) */
3962 tryrsfp = doopen_pm(sv);
3965 /* ... but if we fail, still search @INC for code references;
3966 * these are applied even on on-searchable paths (except
3967 * if we got EACESS).
3969 * For searchable paths, just search @INC normally
3971 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3972 AV * const ar = GvAVn(PL_incgv);
3979 namesv = newSV_type(SVt_PV);
3980 for (i = 0; i <= AvFILL(ar); i++) {
3981 SV * const dirsv = *av_fetch(ar, i, TRUE);
3989 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3990 && !SvOBJECT(SvRV(loader)))
3992 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3996 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
3997 PTR2UV(SvRV(dirsv)), name);
3998 tryname = SvPVX_const(namesv);
4001 if (SvPADTMP(nsv)) {
4002 nsv = sv_newmortal();
4003 SvSetSV_nosteal(nsv,sv);
4006 ENTER_with_name("call_INC");
4014 if (SvGMAGICAL(loader)) {
4015 SV *l = sv_newmortal();
4016 sv_setsv_nomg(l, loader);
4019 if (sv_isobject(loader))
4020 count = call_method("INC", G_ARRAY);
4022 count = call_sv(loader, G_ARRAY);
4032 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
4033 && !isGV_with_GP(SvRV(arg))) {
4034 filter_cache = SvRV(arg);
4041 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
4045 if (isGV_with_GP(arg)) {
4046 IO * const io = GvIO((const GV *)arg);
4051 tryrsfp = IoIFP(io);
4052 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
4053 PerlIO_close(IoOFP(io));
4064 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
4066 SvREFCNT_inc_simple_void_NN(filter_sub);
4069 filter_state = SP[i];
4070 SvREFCNT_inc_simple_void(filter_state);
4074 if (!tryrsfp && (filter_cache || filter_sub)) {
4075 tryrsfp = PerlIO_open(BIT_BUCKET,
4081 /* FREETMPS may free our filter_cache */
4082 SvREFCNT_inc_simple_void(filter_cache);
4086 LEAVE_with_name("call_INC");
4088 /* Now re-mortalize it. */
4089 sv_2mortal(filter_cache);
4091 /* Adjust file name if the hook has set an %INC entry.
4092 This needs to happen after the FREETMPS above. */
4093 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
4095 tryname = SvPV_nolen_const(*svp);
4102 filter_has_file = 0;
4103 filter_cache = NULL;
4105 SvREFCNT_dec_NN(filter_state);
4106 filter_state = NULL;
4109 SvREFCNT_dec_NN(filter_sub);
4113 else if (path_searchable) {
4114 /* match against a plain @INC element (non-searchable
4115 * paths are only matched against refs in @INC) */
4120 dir = SvPV_nomg_const(dirsv, dirlen);
4126 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
4130 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4133 sv_setpv(namesv, unixdir);
4134 sv_catpv(namesv, unixname);
4135 #elif defined(__SYMBIAN32__)
4136 if (PL_origfilename[0] &&
4137 PL_origfilename[1] == ':' &&
4138 !(dir[0] && dir[1] == ':'))
4139 Perl_sv_setpvf(aTHX_ namesv,
4144 Perl_sv_setpvf(aTHX_ namesv,
4148 /* The equivalent of
4149 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4150 but without the need to parse the format string, or
4151 call strlen on either pointer, and with the correct
4152 allocation up front. */
4154 char *tmp = SvGROW(namesv, dirlen + len + 2);
4156 memcpy(tmp, dir, dirlen);
4159 /* Avoid '<dir>//<file>' */
4160 if (!dirlen || *(tmp-1) != '/') {
4163 /* So SvCUR_set reports the correct length below */
4167 /* name came from an SV, so it will have a '\0' at the
4168 end that we can copy as part of this memcpy(). */
4169 memcpy(tmp, name, len + 1);
4171 SvCUR_set(namesv, dirlen + len + 1);
4175 TAINT_PROPER(op_name);
4176 tryname = SvPVX_const(namesv);
4177 tryrsfp = doopen_pm(namesv);
4179 if (tryname[0] == '.' && tryname[1] == '/') {
4181 while (*++tryname == '/') {}
4185 else if (errno == EMFILE || errno == EACCES) {
4186 /* no point in trying other paths if out of handles;
4187 * on the other hand, if we couldn't open one of the
4188 * files, then going on with the search could lead to
4189 * unexpected results; see perl #113422
4198 /* at this point we've ether opened a file (tryrsfp) or set errno */
4200 saved_errno = errno; /* sv_2mortal can realloc things */
4203 /* we failed; croak if require() or return undef if do() */
4204 if (op_is_require) {
4205 if(saved_errno == EMFILE || saved_errno == EACCES) {
4206 /* diag_listed_as: Can't locate %s */
4207 DIE(aTHX_ "Can't locate %s: %s: %s",
4208 name, tryname, Strerror(saved_errno));
4210 if (path_searchable) { /* did we lookup @INC? */
4211 AV * const ar = GvAVn(PL_incgv);
4213 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4214 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4215 for (i = 0; i <= AvFILL(ar); i++) {
4216 sv_catpvs(inc, " ");
4217 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4219 if (memENDPs(name, len, ".pm")) {
4220 const char *e = name + len - (sizeof(".pm") - 1);
4222 bool utf8 = cBOOL(SvUTF8(sv));
4224 /* if the filename, when converted from "Foo/Bar.pm"
4225 * form back to Foo::Bar form, makes a valid
4226 * package name (i.e. parseable by C<require
4227 * Foo::Bar>), then emit a hint.
4229 * this loop is modelled after the one in
4233 if (utf8 && isIDFIRST_utf8_safe(c, e)) {
4235 while (c < e && isIDCONT_utf8_safe(
4236 (const U8*) c, (const U8*) e))
4239 else if (isWORDCHAR_A(*c)) {
4240 while (c < e && isWORDCHAR_A(*c))
4249 if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
4250 sv_catpvs(msg, " (you may need to install the ");
4251 for (c = name; c < e; c++) {
4253 sv_catpvs(msg, "::");
4256 sv_catpvn(msg, c, 1);
4259 sv_catpvs(msg, " module)");
4262 else if (memENDs(name, len, ".h")) {
4263 sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4265 else if (memENDs(name, len, ".ph")) {
4266 sv_catpvs(msg, " (did you run h2ph?)");
4269 /* diag_listed_as: Can't locate %s */
4271 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4275 DIE(aTHX_ "Can't locate %s", name);
4278 #ifdef DEFAULT_INC_EXCLUDES_DOT
4282 /* the complication is to match the logic from doopen_pm() so
4283 * we don't treat do "sda1" as a previously successful "do".
4285 bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED)
4286 && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode)
4287 && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL;
4293 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4294 "do \"%s\" failed, '.' is no longer in @INC; "
4295 "did you mean do \"./%s\"?",
4304 SETERRNO(0, SS_NORMAL);
4306 /* Update %INC. Assume success here to prevent recursive requirement. */
4307 /* name is never assigned to again, so len is still strlen(name) */
4308 /* Check whether a hook in @INC has already filled %INC */
4310 (void)hv_store(GvHVn(PL_incgv),
4311 unixname, unixlen, newSVpv(tryname,0),0);
4313 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4315 (void)hv_store(GvHVn(PL_incgv),
4316 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4319 /* Now parse the file */
4321 old_savestack_ix = PL_savestack_ix;
4322 SAVECOPFILE_FREE(&PL_compiling);
4323 CopFILE_set(&PL_compiling, tryname);
4324 lex_start(NULL, tryrsfp, 0);
4326 if (filter_sub || filter_cache) {
4327 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4328 than hanging another SV from it. In turn, filter_add() optionally
4329 takes the SV to use as the filter (or creates a new SV if passed
4330 NULL), so simply pass in whatever value filter_cache has. */
4331 SV * const fc = filter_cache ? newSV(0) : NULL;
4333 if (fc) sv_copypv(fc, filter_cache);
4334 datasv = filter_add(S_run_user_filter, fc);
4335 IoLINES(datasv) = filter_has_file;
4336 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4337 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4340 /* switch to eval mode */
4342 cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4343 cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4345 SAVECOPLINE(&PL_compiling);
4346 CopLINE_set(&PL_compiling, 0);
4350 if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4353 op = PL_op->op_next;
4355 PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4361 /* also used for: pp_dofile() */
4365 RUN_PP_CATCHABLY(Perl_pp_require);
4372 return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4373 ? S_require_version(aTHX_ sv)
4374 : S_require_file(aTHX_ sv);
4379 /* This is a op added to hold the hints hash for
4380 pp_entereval. The hash can be modified by the code
4381 being eval'ed, so we return a copy instead. */
4386 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4398 char tbuf[TYPE_DIGITS(long) + 12];
4406 I32 old_savestack_ix;
4408 RUN_PP_CATCHABLY(Perl_pp_entereval);
4411 was = PL_breakable_sub_gen;
4412 saved_delete = FALSE;
4416 bytes = PL_op->op_private & OPpEVAL_BYTES;
4418 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4419 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4421 else if (PL_hints & HINT_LOCALIZE_HH || (
4422 PL_op->op_private & OPpEVAL_COPHH
4423 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4425 saved_hh = cop_hints_2hv(PL_curcop, 0);
4426 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4430 /* make sure we've got a plain PV (no overload etc) before testing
4431 * for taint. Making a copy here is probably overkill, but better
4432 * safe than sorry */
4434 const char * const p = SvPV_const(sv, len);
4436 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4437 lex_flags |= LEX_START_COPIED;
4439 if (bytes && SvUTF8(sv))
4440 SvPVbyte_force(sv, len);
4442 else if (bytes && SvUTF8(sv)) {
4443 /* Don't modify someone else's scalar */
4446 (void)sv_2mortal(sv);
4447 SvPVbyte_force(sv,len);
4448 lex_flags |= LEX_START_COPIED;
4451 TAINT_IF(SvTAINTED(sv));
4452 TAINT_PROPER("eval");
4454 old_savestack_ix = PL_savestack_ix;
4456 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4457 ? LEX_IGNORE_UTF8_HINTS
4458 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4462 /* switch to eval mode */
4464 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4465 SV * const temp_sv = sv_newmortal();
4466 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]",
4467 (unsigned long)++PL_evalseq,
4468 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4469 tmpbuf = SvPVX(temp_sv);
4470 len = SvCUR(temp_sv);
4473 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4474 SAVECOPFILE_FREE(&PL_compiling);
4475 CopFILE_set(&PL_compiling, tmpbuf+2);
4476 SAVECOPLINE(&PL_compiling);
4477 CopLINE_set(&PL_compiling, 1);
4478 /* special case: an eval '' executed within the DB package gets lexically
4479 * placed in the first non-DB CV rather than the current CV - this
4480 * allows the debugger to execute code, find lexicals etc, in the
4481 * scope of the code being debugged. Passing &seq gets find_runcv
4482 * to do the dirty work for us */
4483 runcv = find_runcv(&seq);
4486 cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
4487 cx_pusheval(cx, PL_op->op_next, NULL);
4489 /* prepare to compile string */
4491 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4492 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4494 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4495 deleting the eval's FILEGV from the stash before gv_check() runs
4496 (i.e. before run-time proper). To work around the coredump that
4497 ensues, we always turn GvMULTI_on for any globals that were
4498 introduced within evals. See force_ident(). GSAR 96-10-12 */
4499 char *const safestr = savepvn(tmpbuf, len);
4500 SAVEDELETE(PL_defstash, safestr, len);
4501 saved_delete = TRUE;
4506 if (doeval_compile(gimme, runcv, seq, saved_hh)) {
4507 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4508 ? PERLDB_LINE_OR_SAVESRC
4509 : PERLDB_SAVESRC_NOSUBS) {
4510 /* Retain the filegv we created. */
4511 } else if (!saved_delete) {
4512 char *const safestr = savepvn(tmpbuf, len);
4513 SAVEDELETE(PL_defstash, safestr, len);
4515 return PL_eval_start;
4517 /* We have already left the scope set up earlier thanks to the LEAVE
4518 in doeval_compile(). */
4519 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4520 ? PERLDB_LINE_OR_SAVESRC
4521 : PERLDB_SAVESRC_INVALID) {
4522 /* Retain the filegv we created. */
4523 } else if (!saved_delete) {
4524 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4526 return PL_op->op_next;
4531 /* also tail-called by pp_return */
4546 assert(CxTYPE(cx) == CXt_EVAL);
4548 oldsp = PL_stack_base + cx->blk_oldsp;
4549 gimme = cx->blk_gimme;
4551 /* did require return a false value? */
4552 failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE
4553 && !(gimme == G_SCALAR
4554 ? SvTRUE_NN(*PL_stack_sp)
4555 : PL_stack_sp > oldsp);
4557 if (gimme == G_VOID) {
4558 PL_stack_sp = oldsp;
4559 /* free now to avoid late-called destructors clobbering $@ */
4563 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4565 /* the cx_popeval does a leavescope, which frees the optree associated
4566 * with eval, which if it frees the nextstate associated with
4567 * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
4568 * regex when running under 'use re Debug' because it needs PL_curcop
4569 * to get the current hints. So restore it early.
4571 PL_curcop = cx->blk_oldcop;
4573 /* grab this value before cx_popeval restores the old PL_in_eval */
4574 keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4575 retop = cx->blk_eval.retop;
4576 evalcv = cx->blk_eval.cv;
4578 assert(CvDEPTH(evalcv) == 1);
4580 CvDEPTH(evalcv) = 0;
4582 /* pop the CXt_EVAL, and if a require failed, croak */
4583 S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
4591 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4592 close to the related Perl_create_eval_scope. */
4594 Perl_delete_eval_scope(pTHX)
4605 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4606 also needed by Perl_fold_constants. */
4608 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
4611 const U8 gimme = GIMME_V;
4613 cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
4614 PL_stack_sp, PL_savestack_ix);
4615 cx_pusheval(cx, retop, NULL);
4617 PL_in_eval = EVAL_INEVAL;
4618 if (flags & G_KEEPERR)
4619 PL_in_eval |= EVAL_KEEPERR;
4622 if (flags & G_FAKINGEVAL) {
4623 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4629 RUN_PP_CATCHABLY(Perl_pp_entertry);
4632 create_eval_scope(cLOGOP->op_other->op_next, 0);
4633 return PL_op->op_next;
4637 /* also tail-called by pp_return */
4649 assert(CxTYPE(cx) == CXt_EVAL);
4650 oldsp = PL_stack_base + cx->blk_oldsp;
4651 gimme = cx->blk_gimme;
4653 if (gimme == G_VOID) {
4654 PL_stack_sp = oldsp;
4655 /* free now to avoid late-called destructors clobbering $@ */
4659 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4663 retop = cx->blk_eval.retop;
4674 const U8 gimme = GIMME_V;
4678 assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4679 GvSV(PL_defgv) = SvREFCNT_inc(newsv);
4681 cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
4682 cx_pushgiven(cx, origsv);
4692 PERL_UNUSED_CONTEXT;
4695 assert(CxTYPE(cx) == CXt_GIVEN);
4696 oldsp = PL_stack_base + cx->blk_oldsp;
4697 gimme = cx->blk_gimme;
4699 if (gimme == G_VOID)
4700 PL_stack_sp = oldsp;
4702 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4712 /* Helper routines used by pp_smartmatch */
4714 S_make_matcher(pTHX_ REGEXP *re)
4716 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4718 PERL_ARGS_ASSERT_MAKE_MATCHER;
4720 PM_SETRE(matcher, ReREFCNT_inc(re));
4722 SAVEFREEOP((OP *) matcher);
4723 ENTER_with_name("matcher"); SAVETMPS;
4729 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4734 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4736 PL_op = (OP *) matcher;
4739 (void) Perl_pp_match(aTHX);
4741 result = SvTRUEx(POPs);
4748 S_destroy_matcher(pTHX_ PMOP *matcher)
4750 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4751 PERL_UNUSED_ARG(matcher);
4754 LEAVE_with_name("matcher");
4757 /* Do a smart match */
4760 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4761 return do_smartmatch(NULL, NULL, 0);
4764 /* This version of do_smartmatch() implements the
4765 * table of smart matches that is found in perlsyn.
4768 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4772 bool object_on_left = FALSE;
4773 SV *e = TOPs; /* e is for 'expression' */
4774 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4776 /* Take care only to invoke mg_get() once for each argument.
4777 * Currently we do this by copying the SV if it's magical. */
4779 if (!copied && SvGMAGICAL(d))
4780 d = sv_mortalcopy(d);
4787 e = sv_mortalcopy(e);
4789 /* First of all, handle overload magic of the rightmost argument */
4792 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4793 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4795 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4802 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4805 SP -= 2; /* Pop the values */
4810 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4817 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4818 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4819 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4821 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4822 object_on_left = TRUE;
4825 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4827 if (object_on_left) {
4828 goto sm_any_sub; /* Treat objects like scalars */
4830 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4831 /* Test sub truth for each key */
4833 bool andedresults = TRUE;
4834 HV *hv = (HV*) SvRV(d);
4835 I32 numkeys = hv_iterinit(hv);
4836 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4839 while ( (he = hv_iternext(hv)) ) {
4840 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4841 ENTER_with_name("smartmatch_hash_key_test");
4844 PUSHs(hv_iterkeysv(he));
4846 c = call_sv(e, G_SCALAR);
4849 andedresults = FALSE;
4851 andedresults = SvTRUEx(POPs) && andedresults;
4853 LEAVE_with_name("smartmatch_hash_key_test");
4860 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4861 /* Test sub truth for each element */
4863 bool andedresults = TRUE;
4864 AV *av = (AV*) SvRV(d);
4865 const I32 len = av_tindex(av);
4866 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4869 for (i = 0; i <= len; ++i) {
4870 SV * const * const svp = av_fetch(av, i, FALSE);
4871 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4872 ENTER_with_name("smartmatch_array_elem_test");
4878 c = call_sv(e, G_SCALAR);
4881 andedresults = FALSE;
4883 andedresults = SvTRUEx(POPs) && andedresults;
4885 LEAVE_with_name("smartmatch_array_elem_test");
4894 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4895 ENTER_with_name("smartmatch_coderef");
4900 c = call_sv(e, G_SCALAR);
4904 else if (SvTEMP(TOPs))
4905 SvREFCNT_inc_void(TOPs);
4907 LEAVE_with_name("smartmatch_coderef");
4912 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4913 if (object_on_left) {
4914 goto sm_any_hash; /* Treat objects like scalars */
4916 else if (!SvOK(d)) {
4917 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4920 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4921 /* Check that the key-sets are identical */
4923 HV *other_hv = MUTABLE_HV(SvRV(d));
4926 U32 this_key_count = 0,
4927 other_key_count = 0;
4928 HV *hv = MUTABLE_HV(SvRV(e));
4930 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4931 /* Tied hashes don't know how many keys they have. */
4932 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4933 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4937 HV * const temp = other_hv;
4943 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4947 /* The hashes have the same number of keys, so it suffices
4948 to check that one is a subset of the other. */
4949 (void) hv_iterinit(hv);
4950 while ( (he = hv_iternext(hv)) ) {
4951 SV *key = hv_iterkeysv(he);
4953 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4956 if(!hv_exists_ent(other_hv, key, 0)) {
4957 (void) hv_iterinit(hv); /* reset iterator */
4963 (void) hv_iterinit(other_hv);
4964 while ( hv_iternext(other_hv) )
4968 other_key_count = HvUSEDKEYS(other_hv);
4970 if (this_key_count != other_key_count)
4975 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4976 AV * const other_av = MUTABLE_AV(SvRV(d));
4977 const SSize_t other_len = av_tindex(other_av) + 1;
4979 HV *hv = MUTABLE_HV(SvRV(e));
4981 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4982 for (i = 0; i < other_len; ++i) {
4983 SV ** const svp = av_fetch(other_av, i, FALSE);
4984 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4985 if (svp) { /* ??? When can this not happen? */
4986 if (hv_exists_ent(hv, *svp, 0))
4992 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4993 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4996 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4998 HV *hv = MUTABLE_HV(SvRV(e));
5000 (void) hv_iterinit(hv);
5001 while ( (he = hv_iternext(hv)) ) {
5002 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
5004 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
5006 (void) hv_iterinit(hv);
5007 destroy_matcher(matcher);
5012 destroy_matcher(matcher);
5018 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
5019 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
5026 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
5027 if (object_on_left) {
5028 goto sm_any_array; /* Treat objects like scalars */
5030 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5031 AV * const other_av = MUTABLE_AV(SvRV(e));
5032 const SSize_t other_len = av_tindex(other_av) + 1;
5035 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
5036 for (i = 0; i < other_len; ++i) {
5037 SV ** const svp = av_fetch(other_av, i, FALSE);
5039 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
5040 if (svp) { /* ??? When can this not happen? */
5041 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
5047 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5048 AV *other_av = MUTABLE_AV(SvRV(d));
5049 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
5050 if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
5054 const SSize_t other_len = av_tindex(other_av);
5056 if (NULL == seen_this) {
5057 seen_this = newHV();
5058 (void) sv_2mortal(MUTABLE_SV(seen_this));
5060 if (NULL == seen_other) {
5061 seen_other = newHV();
5062 (void) sv_2mortal(MUTABLE_SV(seen_other));
5064 for(i = 0; i <= other_len; ++i) {
5065 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5066 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
5068 if (!this_elem || !other_elem) {
5069 if ((this_elem && SvOK(*this_elem))
5070 || (other_elem && SvOK(*other_elem)))
5073 else if (hv_exists_ent(seen_this,
5074 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
5075 hv_exists_ent(seen_other,
5076 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
5078 if (*this_elem != *other_elem)
5082 (void)hv_store_ent(seen_this,
5083 sv_2mortal(newSViv(PTR2IV(*this_elem))),
5085 (void)hv_store_ent(seen_other,
5086 sv_2mortal(newSViv(PTR2IV(*other_elem))),
5092 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
5093 (void) do_smartmatch(seen_this, seen_other, 0);
5095 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
5104 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
5105 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
5108 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
5109 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5112 for(i = 0; i <= this_len; ++i) {
5113 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5114 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
5116 if (svp && matcher_matches_sv(matcher, *svp)) {
5118 destroy_matcher(matcher);
5123 destroy_matcher(matcher);
5127 else if (!SvOK(d)) {
5128 /* undef ~~ array */
5129 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5132 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
5133 for (i = 0; i <= this_len; ++i) {
5134 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5135 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
5136 if (!svp || !SvOK(*svp))
5145 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5147 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
5148 for (i = 0; i <= this_len; ++i) {
5149 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5156 /* infinite recursion isn't supposed to happen here */
5157 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
5158 (void) do_smartmatch(NULL, NULL, 1);
5160 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
5169 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
5170 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5171 SV *t = d; d = e; e = t;
5172 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
5175 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5176 SV *t = d; d = e; e = t;
5177 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
5178 goto sm_regex_array;
5181 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
5184 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
5186 result = matcher_matches_sv(matcher, d);
5188 PUSHs(result ? &PL_sv_yes : &PL_sv_no);
5189 destroy_matcher(matcher);
5194 /* See if there is overload magic on left */
5195 else if (object_on_left && SvAMAGIC(d)) {
5197 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
5198 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
5201 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
5209 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
5212 else if (!SvOK(d)) {
5213 /* undef ~~ scalar ; we already know that the scalar is SvOK */
5214 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
5219 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
5220 DEBUG_M(if (SvNIOK(e))
5221 Perl_deb(aTHX_ " applying rule Any-Num\n");
5223 Perl_deb(aTHX_ " applying rule Num-numish\n");
5225 /* numeric comparison */
5228 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
5229 (void) Perl_pp_i_eq(aTHX);
5231 (void) Perl_pp_eq(aTHX);
5239 /* As a last resort, use string comparison */
5240 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
5243 return Perl_pp_seq(aTHX);
5250 const U8 gimme = GIMME_V;
5252 /* This is essentially an optimization: if the match
5253 fails, we don't want to push a context and then
5254 pop it again right away, so we skip straight
5255 to the op that follows the leavewhen.
5256 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5258 if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) {
5259 if (gimme == G_SCALAR)
5260 PUSHs(&PL_sv_undef);
5261 RETURNOP(cLOGOP->op_other->op_next);
5264 cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
5278 assert(CxTYPE(cx) == CXt_WHEN);
5279 gimme = cx->blk_gimme;
5281 cxix = dopoptogivenfor(cxstack_ix);
5283 /* diag_listed_as: Can't "when" outside a topicalizer */
5284 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5285 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5287 oldsp = PL_stack_base + cx->blk_oldsp;
5288 if (gimme == G_VOID)
5289 PL_stack_sp = oldsp;
5291 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5293 /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
5294 assert(cxix < cxstack_ix);
5297 cx = &cxstack[cxix];
5299 if (CxFOREACH(cx)) {
5300 /* emulate pp_next. Note that any stack(s) cleanup will be
5301 * done by the pp_unstack which op_nextop should point to */
5304 PL_curcop = cx->blk_oldcop;
5305 return cx->blk_loop.my_op->op_nextop;
5309 assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
5310 return cx->blk_givwhen.leave_op;
5320 cxix = dopoptowhen(cxstack_ix);
5322 DIE(aTHX_ "Can't \"continue\" outside a when block");
5324 if (cxix < cxstack_ix)
5328 assert(CxTYPE(cx) == CXt_WHEN);
5329 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5333 nextop = cx->blk_givwhen.leave_op->op_next;
5344 cxix = dopoptogivenfor(cxstack_ix);
5346 DIE(aTHX_ "Can't \"break\" outside a given block");
5348 cx = &cxstack[cxix];
5350 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5352 if (cxix < cxstack_ix)
5355 /* Restore the sp at the time we entered the given block */
5357 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5359 return cx->blk_givwhen.leave_op;
5363 S_doparseform(pTHX_ SV *sv)
5366 char *s = SvPV(sv, len);
5368 char *base = NULL; /* start of current field */
5369 I32 skipspaces = 0; /* number of contiguous spaces seen */
5370 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5371 bool repeat = FALSE; /* ~~ seen on this line */
5372 bool postspace = FALSE; /* a text field may need right padding */
5375 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5377 bool ischop; /* it's a ^ rather than a @ */
5378 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5379 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5383 PERL_ARGS_ASSERT_DOPARSEFORM;
5386 Perl_croak(aTHX_ "Null picture in formline");
5388 if (SvTYPE(sv) >= SVt_PVMG) {
5389 /* This might, of course, still return NULL. */
5390 mg = mg_find(sv, PERL_MAGIC_fm);
5392 sv_upgrade(sv, SVt_PVMG);
5396 /* still the same as previously-compiled string? */
5397 SV *old = mg->mg_obj;
5398 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5399 && len == SvCUR(old)
5400 && strnEQ(SvPVX(old), s, len)
5402 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5406 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5407 Safefree(mg->mg_ptr);
5413 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5414 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5417 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5418 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5422 /* estimate the buffer size needed */
5423 for (base = s; s <= send; s++) {
5424 if (*s == '\n' || *s == '@' || *s == '^')
5430 Newx(fops, maxops, U32);
5435 *fpc++ = FF_LINEMARK;
5436 noblank = repeat = FALSE;
5454 case ' ': case '\t':
5470 *fpc++ = FF_LITERAL;
5478 *fpc++ = (U32)skipspaces;
5482 *fpc++ = FF_NEWLINE;
5486 arg = fpc - linepc + 1;
5493 *fpc++ = FF_LINEMARK;
5494 noblank = repeat = FALSE;
5503 ischop = s[-1] == '^';
5509 arg = (s - base) - 1;
5511 *fpc++ = FF_LITERAL;
5517 if (*s == '*') { /* @* or ^* */
5519 *fpc++ = 2; /* skip the @* or ^* */
5521 *fpc++ = FF_LINESNGL;
5524 *fpc++ = FF_LINEGLOB;
5526 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5527 arg = ischop ? FORM_NUM_BLANK : 0;
5532 const char * const f = ++s;
5535 arg |= FORM_NUM_POINT + (s - f);
5537 *fpc++ = s - base; /* fieldsize for FETCH */
5538 *fpc++ = FF_DECIMAL;
5540 unchopnum |= ! ischop;
5542 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5543 arg = ischop ? FORM_NUM_BLANK : 0;
5545 s++; /* skip the '0' first */
5549 const char * const f = ++s;
5552 arg |= FORM_NUM_POINT + (s - f);
5554 *fpc++ = s - base; /* fieldsize for FETCH */
5555 *fpc++ = FF_0DECIMAL;
5557 unchopnum |= ! ischop;
5559 else { /* text field */
5561 bool ismore = FALSE;
5564 while (*++s == '>') ;
5565 prespace = FF_SPACE;
5567 else if (*s == '|') {
5568 while (*++s == '|') ;
5569 prespace = FF_HALFSPACE;
5574 while (*++s == '<') ;
5577 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5581 *fpc++ = s - base; /* fieldsize for FETCH */
5583 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5586 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5600 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5603 mg->mg_ptr = (char *) fops;
5604 mg->mg_len = arg * sizeof(U32);
5605 mg->mg_obj = sv_copy;
5606 mg->mg_flags |= MGf_REFCOUNTED;
5608 if (unchopnum && repeat)
5609 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5616 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5618 /* Can value be printed in fldsize chars, using %*.*f ? */
5622 int intsize = fldsize - (value < 0 ? 1 : 0);
5624 if (frcsize & FORM_NUM_POINT)
5626 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5629 while (intsize--) pwr *= 10.0;
5630 while (frcsize--) eps /= 10.0;
5633 if (value + eps >= pwr)
5636 if (value - eps <= -pwr)
5643 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5645 SV * const datasv = FILTER_DATA(idx);
5646 const int filter_has_file = IoLINES(datasv);
5647 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5648 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5653 char *prune_from = NULL;
5654 bool read_from_cache = FALSE;
5658 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5660 assert(maxlen >= 0);
5663 /* I was having segfault trouble under Linux 2.2.5 after a
5664 parse error occurred. (Had to hack around it with a test
5665 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5666 not sure where the trouble is yet. XXX */
5669 SV *const cache = datasv;
5672 const char *cache_p = SvPV(cache, cache_len);
5676 /* Running in block mode and we have some cached data already.
5678 if (cache_len >= umaxlen) {
5679 /* In fact, so much data we don't even need to call
5684 const char *const first_nl =
5685 (const char *)memchr(cache_p, '\n', cache_len);
5687 take = first_nl + 1 - cache_p;
5691 sv_catpvn(buf_sv, cache_p, take);
5692 sv_chop(cache, cache_p + take);
5693 /* Definitely not EOF */
5697 sv_catsv(buf_sv, cache);
5699 umaxlen -= cache_len;
5702 read_from_cache = TRUE;
5706 /* Filter API says that the filter appends to the contents of the buffer.
5707 Usually the buffer is "", so the details don't matter. But if it's not,
5708 then clearly what it contains is already filtered by this filter, so we
5709 don't want to pass it in a second time.
5710 I'm going to use a mortal in case the upstream filter croaks. */
5711 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5712 ? sv_newmortal() : buf_sv;
5713 SvUPGRADE(upstream, SVt_PV);
5715 if (filter_has_file) {
5716 status = FILTER_READ(idx+1, upstream, 0);
5719 if (filter_sub && status >= 0) {
5723 ENTER_with_name("call_filter_sub");
5728 DEFSV_set(upstream);
5732 PUSHs(filter_state);
5735 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5745 SV * const errsv = ERRSV;
5746 if (SvTRUE_NN(errsv))
5747 err = newSVsv(errsv);
5753 LEAVE_with_name("call_filter_sub");
5756 if (SvGMAGICAL(upstream)) {
5758 if (upstream == buf_sv) mg_free(buf_sv);
5760 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5761 if(!err && SvOK(upstream)) {
5762 got_p = SvPV_nomg(upstream, got_len);
5764 if (got_len > umaxlen) {
5765 prune_from = got_p + umaxlen;
5768 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5769 if (first_nl && first_nl + 1 < got_p + got_len) {
5770 /* There's a second line here... */
5771 prune_from = first_nl + 1;
5775 if (!err && prune_from) {
5776 /* Oh. Too long. Stuff some in our cache. */
5777 STRLEN cached_len = got_p + got_len - prune_from;
5778 SV *const cache = datasv;
5781 /* Cache should be empty. */
5782 assert(!SvCUR(cache));
5785 sv_setpvn(cache, prune_from, cached_len);
5786 /* If you ask for block mode, you may well split UTF-8 characters.
5787 "If it breaks, you get to keep both parts"
5788 (Your code is broken if you don't put them back together again
5789 before something notices.) */
5790 if (SvUTF8(upstream)) {
5793 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5795 /* Cannot just use sv_setpvn, as that could free the buffer
5796 before we have a chance to assign it. */
5797 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5798 got_len - cached_len);
5800 /* Can't yet be EOF */
5805 /* If they are at EOF but buf_sv has something in it, then they may never
5806 have touched the SV upstream, so it may be undefined. If we naively
5807 concatenate it then we get a warning about use of uninitialised value.
5809 if (!err && upstream != buf_sv &&
5811 sv_catsv_nomg(buf_sv, upstream);
5813 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5816 IoLINES(datasv) = 0;
5818 SvREFCNT_dec(filter_state);
5819 IoTOP_GV(datasv) = NULL;
5822 SvREFCNT_dec(filter_sub);
5823 IoBOTTOM_GV(datasv) = NULL;
5825 filter_del(S_run_user_filter);
5831 if (status == 0 && read_from_cache) {
5832 /* If we read some data from the cache (and by getting here it implies
5833 that we emptied the cache) then we aren't yet at EOF, and mustn't
5834 report that to our caller. */
5841 * ex: set ts=8 sts=4 sw=4 et: