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) {
167 if (PL_curpm_under == PL_reg_curpm) {
168 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
178 #if !defined(USE_ITHREADS)
179 /* can't change the optree at runtime either */
180 /* PMf_KEEP is handled differently under threads to avoid these problems */
181 if (pm->op_pmflags & PMf_KEEP) {
182 cLOGOP->op_first->op_next = PL_op->op_next;
194 PERL_CONTEXT *cx = CX_CUR();
195 PMOP * const pm = (PMOP*) cLOGOP->op_other;
196 SV * const dstr = cx->sb_dstr;
199 char *orig = cx->sb_orig;
200 REGEXP * const rx = cx->sb_rx;
202 REGEXP *old = PM_GETRE(pm);
209 PM_SETRE(pm,ReREFCNT_inc(rx));
212 rxres_restore(&cx->sb_rxres, rx);
214 if (cx->sb_iters++) {
215 const SSize_t saviters = cx->sb_iters;
216 if (cx->sb_iters > cx->sb_maxiters)
217 DIE(aTHX_ "Substitution loop");
219 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
221 /* See "how taint works" above pp_subst() */
223 cx->sb_rxtainted |= SUBST_TAINT_REPL;
224 sv_catsv_nomg(dstr, POPs);
225 if (CxONCE(cx) || s < orig ||
226 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
227 (s == m), cx->sb_targ, NULL,
228 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
230 SV *targ = cx->sb_targ;
232 assert(cx->sb_strend >= s);
233 if(cx->sb_strend > s) {
234 if (DO_UTF8(dstr) && !SvUTF8(targ))
235 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
237 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
239 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
240 cx->sb_rxtainted |= SUBST_TAINT_PAT;
242 if (pm->op_pmflags & PMf_NONDESTRUCT) {
244 /* From here on down we're using the copy, and leaving the
245 original untouched. */
249 SV_CHECK_THINKFIRST_COW_DROP(targ);
250 if (isGV(targ)) Perl_croak_no_modify();
252 SvPV_set(targ, SvPVX(dstr));
253 SvCUR_set(targ, SvCUR(dstr));
254 SvLEN_set(targ, SvLEN(dstr));
257 SvPV_set(dstr, NULL);
260 mPUSHi(saviters - 1);
262 (void)SvPOK_only_UTF8(targ);
265 /* update the taint state of various various variables in
266 * preparation for final exit.
267 * See "how taint works" above pp_subst() */
269 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
270 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
271 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
273 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
275 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
276 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
278 SvTAINTED_on(TOPs); /* taint return value */
279 /* needed for mg_set below */
281 cBOOL(cx->sb_rxtainted &
282 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
286 /* PL_tainted must be correctly set for this mg_set */
295 RETURNOP(pm->op_next);
296 NOT_REACHED; /* NOTREACHED */
298 cx->sb_iters = saviters;
300 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
303 assert(!RX_SUBOFFSET(rx));
304 cx->sb_orig = orig = RX_SUBBEG(rx);
306 cx->sb_strend = s + (cx->sb_strend - m);
308 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
310 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
311 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
313 sv_catpvn_nomg(dstr, s, m-s);
315 cx->sb_s = RX_OFFS(rx)[0].end + orig;
316 { /* Update the pos() information. */
318 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
321 /* the string being matched against may no longer be a string,
322 * e.g. $_=0; s/.../$_++/ge */
325 SvPV_force_nomg_nolen(sv);
327 if (!(mg = mg_find_mglob(sv))) {
328 mg = sv_magicext_mglob(sv);
330 MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
333 (void)ReREFCNT_inc(rx);
334 /* update the taint state of various various variables in preparation
335 * for calling the code block.
336 * See "how taint works" above pp_subst() */
338 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
339 cx->sb_rxtainted |= SUBST_TAINT_PAT;
341 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
342 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
343 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
345 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
347 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
348 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
349 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
350 ? cx->sb_dstr : cx->sb_targ);
353 rxres_save(&cx->sb_rxres, rx);
355 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
359 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
364 PERL_ARGS_ASSERT_RXRES_SAVE;
367 if (!p || p[1] < RX_NPARENS(rx)) {
369 i = 7 + (RX_NPARENS(rx)+1) * 2;
371 i = 6 + (RX_NPARENS(rx)+1) * 2;
380 /* what (if anything) to free on croak */
381 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
382 RX_MATCH_COPIED_off(rx);
383 *p++ = RX_NPARENS(rx);
386 *p++ = PTR2UV(RX_SAVED_COPY(rx));
387 RX_SAVED_COPY(rx) = NULL;
390 *p++ = PTR2UV(RX_SUBBEG(rx));
391 *p++ = (UV)RX_SUBLEN(rx);
392 *p++ = (UV)RX_SUBOFFSET(rx);
393 *p++ = (UV)RX_SUBCOFFSET(rx);
394 for (i = 0; i <= RX_NPARENS(rx); ++i) {
395 *p++ = (UV)RX_OFFS(rx)[i].start;
396 *p++ = (UV)RX_OFFS(rx)[i].end;
401 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
406 PERL_ARGS_ASSERT_RXRES_RESTORE;
409 RX_MATCH_COPY_FREE(rx);
410 RX_MATCH_COPIED_set(rx, *p);
412 RX_NPARENS(rx) = *p++;
415 if (RX_SAVED_COPY(rx))
416 SvREFCNT_dec (RX_SAVED_COPY(rx));
417 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
421 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
422 RX_SUBLEN(rx) = (I32)(*p++);
423 RX_SUBOFFSET(rx) = (I32)*p++;
424 RX_SUBCOFFSET(rx) = (I32)*p++;
425 for (i = 0; i <= RX_NPARENS(rx); ++i) {
426 RX_OFFS(rx)[i].start = (I32)(*p++);
427 RX_OFFS(rx)[i].end = (I32)(*p++);
432 S_rxres_free(pTHX_ void **rsp)
434 UV * const p = (UV*)*rsp;
436 PERL_ARGS_ASSERT_RXRES_FREE;
440 void *tmp = INT2PTR(char*,*p);
443 U32 i = 9 + p[1] * 2;
445 U32 i = 8 + p[1] * 2;
450 SvREFCNT_dec (INT2PTR(SV*,p[2]));
453 PoisonFree(p, i, sizeof(UV));
462 #define FORM_NUM_BLANK (1<<30)
463 #define FORM_NUM_POINT (1<<29)
467 dSP; dMARK; dORIGMARK;
468 SV * const tmpForm = *++MARK;
469 SV *formsv; /* contains text of original format */
470 U32 *fpc; /* format ops program counter */
471 char *t; /* current append position in target string */
472 const char *f; /* current position in format string */
474 SV *sv = NULL; /* current item */
475 const char *item = NULL;/* string value of current item */
476 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
477 I32 itembytes = 0; /* as itemsize, but length in bytes */
478 I32 fieldsize = 0; /* width of current field */
479 I32 lines = 0; /* number of lines that have been output */
480 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
481 const char *chophere = NULL; /* where to chop current item */
482 STRLEN linemark = 0; /* pos of start of line in output */
484 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
485 STRLEN len; /* length of current sv */
486 STRLEN linemax; /* estimate of output size in bytes */
487 bool item_is_utf8 = FALSE;
488 bool targ_is_utf8 = FALSE;
491 U8 *source; /* source of bytes to append */
492 STRLEN to_copy; /* how may bytes to append */
493 char trans; /* what chars to translate */
494 bool copied_form = FALSE; /* have we duplicated the form? */
496 mg = doparseform(tmpForm);
498 fpc = (U32*)mg->mg_ptr;
499 /* the actual string the format was compiled from.
500 * with overload etc, this may not match tmpForm */
504 SvPV_force(PL_formtarget, len);
505 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
506 SvTAINTED_on(PL_formtarget);
507 if (DO_UTF8(PL_formtarget))
509 /* this is an initial estimate of how much output buffer space
510 * to allocate. It may be exceeded later */
511 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
512 t = SvGROW(PL_formtarget, len + linemax + 1);
513 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
515 f = SvPV_const(formsv, len);
519 const char *name = "???";
522 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
523 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
524 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
525 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
526 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
528 case FF_CHECKNL: name = "CHECKNL"; break;
529 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
530 case FF_SPACE: name = "SPACE"; break;
531 case FF_HALFSPACE: name = "HALFSPACE"; break;
532 case FF_ITEM: name = "ITEM"; break;
533 case FF_CHOP: name = "CHOP"; break;
534 case FF_LINEGLOB: name = "LINEGLOB"; break;
535 case FF_NEWLINE: name = "NEWLINE"; break;
536 case FF_MORE: name = "MORE"; break;
537 case FF_LINEMARK: name = "LINEMARK"; break;
538 case FF_END: name = "END"; break;
539 case FF_0DECIMAL: name = "0DECIMAL"; break;
540 case FF_LINESNGL: name = "LINESNGL"; break;
543 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
545 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
548 case FF_LINEMARK: /* start (or end) of a line */
549 linemark = t - SvPVX(PL_formtarget);
554 case FF_LITERAL: /* append <arg> literal chars */
559 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
562 case FF_SKIP: /* skip <arg> chars in format */
566 case FF_FETCH: /* get next item and set field size to <arg> */
575 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
578 SvTAINTED_on(PL_formtarget);
581 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
583 const char *s = item = SvPV_const(sv, len);
584 const char *send = s + len;
587 item_is_utf8 = DO_UTF8(sv);
599 if (itemsize == fieldsize)
602 itembytes = s - item;
607 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
609 const char *s = item = SvPV_const(sv, len);
610 const char *send = s + len;
614 item_is_utf8 = DO_UTF8(sv);
616 /* look for a legal split position */
624 /* provisional split point */
628 /* we delay testing fieldsize until after we've
629 * processed the possible split char directly
630 * following the last field char; so if fieldsize=3
631 * and item="a b cdef", we consume "a b", not "a".
632 * Ditto further down.
634 if (size == fieldsize)
638 if (strchr(PL_chopset, *s)) {
639 /* provisional split point */
640 /* for a non-space split char, we include
641 * the split char; hence the '+1' */
645 if (size == fieldsize)
657 if (!chophere || s == send) {
661 itembytes = chophere - item;
666 case FF_SPACE: /* append padding space (diff of field, item size) */
667 arg = fieldsize - itemsize;
675 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
676 arg = fieldsize - itemsize;
685 case FF_ITEM: /* append a text item, while blanking ctrl chars */
691 case FF_CHOP: /* (for ^*) chop the current item */
692 if (sv != &PL_sv_no) {
693 const char *s = chophere;
695 ((sv == tmpForm || SvSMAGICAL(sv))
696 || (SvGMAGICAL(tmpForm) && !sv_only_taint_gmagic(tmpForm))) ) {
697 /* sv and tmpForm are either the same SV, or magic might allow modification
698 of tmpForm when sv is modified, so copy */
699 SV *newformsv = sv_mortalcopy(formsv);
702 f = SvPV_nolen(newformsv) + (f - SvPV_nolen(formsv));
703 Newx(new_compiled, mg->mg_len / sizeof(U32), U32);
704 memcpy(new_compiled, mg->mg_ptr, mg->mg_len);
705 SAVEFREEPV(new_compiled);
706 fpc = new_compiled + (fpc - (U32*)mg->mg_ptr);
718 /* tied, overloaded or similar strangeness.
719 * Do it the hard way */
720 sv_setpvn(sv, s, len - (s-item));
725 case FF_LINESNGL: /* process ^* */
729 case FF_LINEGLOB: /* process @* */
731 const bool oneline = fpc[-1] == FF_LINESNGL;
732 const char *s = item = SvPV_const(sv, len);
733 const char *const send = s + len;
735 item_is_utf8 = DO_UTF8(sv);
746 to_copy = s - item - 1;
760 /* append to_copy bytes from source to PL_formstring.
761 * item_is_utf8 implies source is utf8.
762 * if trans, translate certain characters during the copy */
767 SvCUR_set(PL_formtarget,
768 t - SvPVX_const(PL_formtarget));
770 if (targ_is_utf8 && !item_is_utf8) {
771 source = tmp = bytes_to_utf8(source, &to_copy);
774 if (item_is_utf8 && !targ_is_utf8) {
776 /* Upgrade targ to UTF8, and then we reduce it to
777 a problem we have a simple solution for.
778 Don't need get magic. */
779 sv_utf8_upgrade_nomg(PL_formtarget);
781 /* re-calculate linemark */
782 s = (U8*)SvPVX(PL_formtarget);
783 /* the bytes we initially allocated to append the
784 * whole line may have been gobbled up during the
785 * upgrade, so allocate a whole new line's worth
790 linemark = s - (U8*)SvPVX(PL_formtarget);
792 /* Easy. They agree. */
793 assert (item_is_utf8 == targ_is_utf8);
796 /* @* and ^* are the only things that can exceed
797 * the linemax, so grow by the output size, plus
798 * a whole new form's worth in case of any further
800 grow = linemax + to_copy;
802 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
803 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
805 Copy(source, t, to_copy, char);
807 /* blank out ~ or control chars, depending on trans.
808 * works on bytes not chars, so relies on not
809 * matching utf8 continuation bytes */
811 U8 *send = s + to_copy;
814 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
821 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
827 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
830 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
833 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
836 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
838 /* If the field is marked with ^ and the value is undefined,
840 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
848 /* overflow evidence */
849 if (num_overflow(value, fieldsize, arg)) {
855 /* Formats aren't yet marked for locales, so assume "yes". */
857 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
859 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
860 STORE_LC_NUMERIC_SET_TO_NEEDED();
861 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
864 const char* qfmt = quadmath_format_single(fmt);
867 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
868 len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
870 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
875 /* we generate fmt ourselves so it is safe */
876 GCC_DIAG_IGNORE(-Wformat-nonliteral);
877 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
880 PERL_MY_SNPRINTF_POST_GUARD(len, max);
881 RESTORE_LC_NUMERIC();
886 case FF_NEWLINE: /* delete trailing spaces, then append \n */
888 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
893 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
896 if (arg) { /* repeat until fields exhausted? */
902 t = SvPVX(PL_formtarget) + linemark;
907 case FF_MORE: /* replace long end of string with '...' */
909 const char *s = chophere;
910 const char *send = item + len;
912 while (isSPACE(*s) && (s < send))
917 arg = fieldsize - itemsize;
924 if (strnEQ(s1," ",3)) {
925 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
935 case FF_END: /* tidy up, then return */
937 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
939 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
941 SvUTF8_on(PL_formtarget);
942 FmLINES(PL_formtarget) += lines;
944 if (fpc[-1] == FF_BLANK)
945 RETURNOP(cLISTOP->op_first);
952 /* also used for: pp_mapstart() */
958 if (PL_stack_base + TOPMARK == SP) {
960 if (GIMME_V == G_SCALAR)
962 RETURNOP(PL_op->op_next->op_next);
964 PL_stack_sp = PL_stack_base + TOPMARK + 1;
965 Perl_pp_pushmark(aTHX); /* push dst */
966 Perl_pp_pushmark(aTHX); /* push src */
967 ENTER_with_name("grep"); /* enter outer scope */
971 ENTER_with_name("grep_item"); /* enter inner scope */
974 src = PL_stack_base[TOPMARK];
976 src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
983 if (PL_op->op_type == OP_MAPSTART)
984 Perl_pp_pushmark(aTHX); /* push top */
985 return ((LOGOP*)PL_op->op_next)->op_other;
991 const U8 gimme = GIMME_V;
992 I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
998 /* first, move source pointer to the next item in the source list */
999 ++PL_markstack_ptr[-1];
1001 /* if there are new items, push them into the destination list */
1002 if (items && gimme != G_VOID) {
1003 /* might need to make room back there first */
1004 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1005 /* XXX this implementation is very pessimal because the stack
1006 * is repeatedly extended for every set of items. Is possible
1007 * to do this without any stack extension or copying at all
1008 * by maintaining a separate list over which the map iterates
1009 * (like foreach does). --gsar */
1011 /* everything in the stack after the destination list moves
1012 * towards the end the stack by the amount of room needed */
1013 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1015 /* items to shift up (accounting for the moved source pointer) */
1016 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1018 /* This optimization is by Ben Tilly and it does
1019 * things differently from what Sarathy (gsar)
1020 * is describing. The downside of this optimization is
1021 * that leaves "holes" (uninitialized and hopefully unused areas)
1022 * to the Perl stack, but on the other hand this
1023 * shouldn't be a problem. If Sarathy's idea gets
1024 * implemented, this optimization should become
1025 * irrelevant. --jhi */
1027 shift = count; /* Avoid shifting too often --Ben Tilly */
1031 dst = (SP += shift);
1032 PL_markstack_ptr[-1] += shift;
1033 *PL_markstack_ptr += shift;
1037 /* copy the new items down to the destination list */
1038 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1039 if (gimme == G_ARRAY) {
1040 /* add returned items to the collection (making mortal copies
1041 * if necessary), then clear the current temps stack frame
1042 * *except* for those items. We do this splicing the items
1043 * into the start of the tmps frame (so some items may be on
1044 * the tmps stack twice), then moving PL_tmps_floor above
1045 * them, then freeing the frame. That way, the only tmps that
1046 * accumulate over iterations are the return values for map.
1047 * We have to do to this way so that everything gets correctly
1048 * freed if we die during the map.
1052 /* make space for the slice */
1053 EXTEND_MORTAL(items);
1054 tmpsbase = PL_tmps_floor + 1;
1055 Move(PL_tmps_stack + tmpsbase,
1056 PL_tmps_stack + tmpsbase + items,
1057 PL_tmps_ix - PL_tmps_floor,
1059 PL_tmps_ix += items;
1064 sv = sv_mortalcopy(sv);
1066 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1068 /* clear the stack frame except for the items */
1069 PL_tmps_floor += items;
1071 /* FREETMPS may have cleared the TEMP flag on some of the items */
1074 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1077 /* scalar context: we don't care about which values map returns
1078 * (we use undef here). And so we certainly don't want to do mortal
1079 * copies of meaningless values. */
1080 while (items-- > 0) {
1082 *dst-- = &PL_sv_undef;
1090 LEAVE_with_name("grep_item"); /* exit inner scope */
1093 if (PL_markstack_ptr[-1] > TOPMARK) {
1095 (void)POPMARK; /* pop top */
1096 LEAVE_with_name("grep"); /* exit outer scope */
1097 (void)POPMARK; /* pop src */
1098 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1099 (void)POPMARK; /* pop dst */
1100 SP = PL_stack_base + POPMARK; /* pop original mark */
1101 if (gimme == G_SCALAR) {
1105 else if (gimme == G_ARRAY)
1112 ENTER_with_name("grep_item"); /* enter inner scope */
1115 /* set $_ to the new source item */
1116 src = PL_stack_base[PL_markstack_ptr[-1]];
1117 if (SvPADTMP(src)) {
1118 src = sv_mortalcopy(src);
1123 RETURNOP(cLOGOP->op_other);
1131 if (GIMME_V == G_ARRAY)
1133 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1134 return cLOGOP->op_other;
1143 if (GIMME_V == G_ARRAY) {
1144 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1148 SV * const targ = PAD_SV(PL_op->op_targ);
1151 if (PL_op->op_private & OPpFLIP_LINENUM) {
1152 if (GvIO(PL_last_in_gv)) {
1153 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1156 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1158 flip = SvIV(sv) == SvIV(GvSV(gv));
1164 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1165 if (PL_op->op_flags & OPf_SPECIAL) {
1173 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1182 /* This code tries to decide if "$left .. $right" should use the
1183 magical string increment, or if the range is numeric (we make
1184 an exception for .."0" [#18165]). AMS 20021031. */
1186 #define RANGE_IS_NUMERIC(left,right) ( \
1187 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1188 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1189 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1190 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1191 && (!SvOK(right) || looks_like_number(right))))
1197 if (GIMME_V == G_ARRAY) {
1203 if (RANGE_IS_NUMERIC(left,right)) {
1205 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1206 (SvOK(right) && (SvIOK(right)
1207 ? SvIsUV(right) && SvUV(right) > IV_MAX
1208 : SvNV_nomg(right) > IV_MAX)))
1209 DIE(aTHX_ "Range iterator outside integer range");
1210 i = SvIV_nomg(left);
1211 j = SvIV_nomg(right);
1213 /* Dance carefully around signed max. */
1214 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1217 /* The wraparound of signed integers is undefined
1218 * behavior, but here we aim for count >=1, and
1219 * negative count is just wrong. */
1221 #if IVSIZE > Size_t_size
1228 Perl_croak(aTHX_ "Out of memory during list extend");
1235 SV * const sv = sv_2mortal(newSViv(i));
1237 if (n) /* avoid incrementing above IV_MAX */
1243 const char * const lpv = SvPV_nomg_const(left, llen);
1244 const char * const tmps = SvPV_nomg_const(right, len);
1246 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1247 if (DO_UTF8(right) && IN_UNI_8_BIT)
1248 len = sv_len_utf8_nomg(right);
1249 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1251 if (strEQ(SvPVX_const(sv),tmps))
1253 sv = sv_2mortal(newSVsv(sv));
1260 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1264 if (PL_op->op_private & OPpFLIP_LINENUM) {
1265 if (GvIO(PL_last_in_gv)) {
1266 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1269 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1270 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1278 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1279 sv_catpvs(targ, "E0");
1289 static const char * const context_name[] = {
1291 NULL, /* CXt_WHEN never actually needs "block" */
1292 NULL, /* CXt_BLOCK never actually needs "block" */
1293 NULL, /* CXt_GIVEN never actually needs "block" */
1294 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1295 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1296 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1297 NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1298 NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1306 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1310 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1312 for (i = cxstack_ix; i >= 0; i--) {
1313 const PERL_CONTEXT * const cx = &cxstack[i];
1314 switch (CxTYPE(cx)) {
1320 /* diag_listed_as: Exiting subroutine via %s */
1321 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1322 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1323 if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1326 case CXt_LOOP_PLAIN:
1327 case CXt_LOOP_LAZYIV:
1328 case CXt_LOOP_LAZYSV:
1332 STRLEN cx_label_len = 0;
1333 U32 cx_label_flags = 0;
1334 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1336 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1339 (const U8*)cx_label, cx_label_len,
1340 (const U8*)label, len) == 0)
1342 (const U8*)label, len,
1343 (const U8*)cx_label, cx_label_len) == 0)
1344 : (len == cx_label_len && ((cx_label == label)
1345 || memEQ(cx_label, label, len))) )) {
1346 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1347 (long)i, cx_label));
1350 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1361 Perl_dowantarray(pTHX)
1363 const U8 gimme = block_gimme();
1364 return (gimme == G_VOID) ? G_SCALAR : gimme;
1368 Perl_block_gimme(pTHX)
1370 const I32 cxix = dopoptosub(cxstack_ix);
1375 gimme = (cxstack[cxix].blk_gimme & G_WANT);
1377 Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1383 Perl_is_lvalue_sub(pTHX)
1385 const I32 cxix = dopoptosub(cxstack_ix);
1386 assert(cxix >= 0); /* We should only be called from inside subs */
1388 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1389 return CxLVAL(cxstack + cxix);
1394 /* only used by cx_pushsub() */
1396 Perl_was_lvalue_sub(pTHX)
1398 const I32 cxix = dopoptosub(cxstack_ix-1);
1399 assert(cxix >= 0); /* We should only be called from inside subs */
1401 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1402 return CxLVAL(cxstack + cxix);
1408 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1412 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1414 PERL_UNUSED_CONTEXT;
1417 for (i = startingblock; i >= 0; i--) {
1418 const PERL_CONTEXT * const cx = &cxstk[i];
1419 switch (CxTYPE(cx)) {
1423 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1424 * twice; the first for the normal foo() call, and the second
1425 * for a faked up re-entry into the sub to execute the
1426 * code block. Hide this faked entry from the world. */
1427 if (cx->cx_type & CXp_SUB_RE_FAKE)
1432 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1440 S_dopoptoeval(pTHX_ I32 startingblock)
1443 for (i = startingblock; i >= 0; i--) {
1444 const PERL_CONTEXT *cx = &cxstack[i];
1445 switch (CxTYPE(cx)) {
1449 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1457 S_dopoptoloop(pTHX_ I32 startingblock)
1460 for (i = startingblock; i >= 0; i--) {
1461 const PERL_CONTEXT * const cx = &cxstack[i];
1462 switch (CxTYPE(cx)) {
1468 /* diag_listed_as: Exiting subroutine via %s */
1469 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1470 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1471 if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1474 case CXt_LOOP_PLAIN:
1475 case CXt_LOOP_LAZYIV:
1476 case CXt_LOOP_LAZYSV:
1479 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1486 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1489 S_dopoptogivenfor(pTHX_ I32 startingblock)
1492 for (i = startingblock; i >= 0; i--) {
1493 const PERL_CONTEXT *cx = &cxstack[i];
1494 switch (CxTYPE(cx)) {
1498 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1500 case CXt_LOOP_PLAIN:
1501 assert(!(cx->cx_type & CXp_FOR_DEF));
1503 case CXt_LOOP_LAZYIV:
1504 case CXt_LOOP_LAZYSV:
1507 if (cx->cx_type & CXp_FOR_DEF) {
1508 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1517 S_dopoptowhen(pTHX_ I32 startingblock)
1520 for (i = startingblock; i >= 0; i--) {
1521 const PERL_CONTEXT *cx = &cxstack[i];
1522 switch (CxTYPE(cx)) {
1526 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1533 /* dounwind(): pop all contexts above (but not including) cxix.
1534 * Note that it clears the savestack frame associated with each popped
1535 * context entry, but doesn't free any temps.
1536 * It does a cx_popblock() of the last frame that it pops, and leaves
1537 * cxstack_ix equal to cxix.
1541 Perl_dounwind(pTHX_ I32 cxix)
1543 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1546 while (cxstack_ix > cxix) {
1547 PERL_CONTEXT *cx = CX_CUR();
1549 CX_DEBUG(cx, "UNWIND");
1550 /* Note: we don't need to restore the base context info till the end. */
1554 switch (CxTYPE(cx)) {
1557 /* CXt_SUBST is not a block context type, so skip the
1558 * cx_popblock(cx) below */
1559 if (cxstack_ix == cxix + 1) {
1570 case CXt_LOOP_PLAIN:
1571 case CXt_LOOP_LAZYIV:
1572 case CXt_LOOP_LAZYSV:
1585 /* these two don't have a POPFOO() */
1591 if (cxstack_ix == cxix + 1) {
1600 Perl_qerror(pTHX_ SV *err)
1602 PERL_ARGS_ASSERT_QERROR;
1605 if (PL_in_eval & EVAL_KEEPERR) {
1606 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1610 sv_catsv(ERRSV, err);
1613 sv_catsv(PL_errors, err);
1615 Perl_warn(aTHX_ "%" SVf, SVfARG(err));
1617 ++PL_parser->error_count;
1622 /* pop a CXt_EVAL context and in addition, if it was a require then
1624 * 0: do nothing extra;
1625 * 1: undef $INC{$name}; croak "$name did not return a true value";
1626 * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1630 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1632 SV *namesv = NULL; /* init to avoid dumb compiler warning */
1636 do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1638 /* keep namesv alive after cx_popeval() */
1639 namesv = cx->blk_eval.old_namesv;
1640 cx->blk_eval.old_namesv = NULL;
1649 HV *inc_hv = GvHVn(PL_incgv);
1650 I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv);
1651 const char *key = SvPVX_const(namesv);
1654 (void)hv_delete(inc_hv, key, klen, G_DISCARD);
1655 fmt = "%" SVf " did not return a true value";
1659 (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0);
1660 fmt = "%" SVf "Compilation failed in require";
1662 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1665 Perl_croak(aTHX_ fmt, SVfARG(errsv));
1670 /* die_unwind(): this is the final destination for the various croak()
1671 * functions. If we're in an eval, unwind the context and other stacks
1672 * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1673 * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1674 * to is a require the exception will be rethrown, as requires don't
1675 * actually trap exceptions.
1679 Perl_die_unwind(pTHX_ SV *msv)
1682 U8 in_eval = PL_in_eval;
1683 PERL_ARGS_ASSERT_DIE_UNWIND;
1688 /* We need to keep this SV alive through all the stack unwinding
1689 * and FREETMPSing below, while ensuing that it doesn't leak
1690 * if we call out to something which then dies (e.g. sub STORE{die}
1691 * when unlocalising a tied var). So we do a dance with
1692 * mortalising and SAVEFREEing.
1694 sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1697 * Historically, perl used to set ERRSV ($@) early in the die
1698 * process and rely on it not getting clobbered during unwinding.
1699 * That sucked, because it was liable to get clobbered, so the
1700 * setting of ERRSV used to emit the exception from eval{} has
1701 * been moved to much later, after unwinding (see just before
1702 * JMPENV_JUMP below). However, some modules were relying on the
1703 * early setting, by examining $@ during unwinding to use it as
1704 * a flag indicating whether the current unwinding was caused by
1705 * an exception. It was never a reliable flag for that purpose,
1706 * being totally open to false positives even without actual
1707 * clobberage, but was useful enough for production code to
1708 * semantically rely on it.
1710 * We'd like to have a proper introspective interface that
1711 * explicitly describes the reason for whatever unwinding
1712 * operations are currently in progress, so that those modules
1713 * work reliably and $@ isn't further overloaded. But we don't
1714 * have one yet. In its absence, as a stopgap measure, ERRSV is
1715 * now *additionally* set here, before unwinding, to serve as the
1716 * (unreliable) flag that it used to.
1718 * This behaviour is temporary, and should be removed when a
1719 * proper way to detect exceptional unwinding has been developed.
1720 * As of 2010-12, the authors of modules relying on the hack
1721 * are aware of the issue, because the modules failed on
1722 * perls 5.13.{1..7} which had late setting of $@ without this
1723 * early-setting hack.
1725 if (!(in_eval & EVAL_KEEPERR))
1726 sv_setsv_flags(ERRSV, exceptsv,
1727 (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
1729 if (in_eval & EVAL_KEEPERR) {
1730 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1734 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1735 && PL_curstackinfo->si_prev)
1745 JMPENV *restartjmpenv;
1748 if (cxix < cxstack_ix)
1752 assert(CxTYPE(cx) == CXt_EVAL);
1754 /* return false to the caller of eval */
1755 oldsp = PL_stack_base + cx->blk_oldsp;
1756 gimme = cx->blk_gimme;
1757 if (gimme == G_SCALAR)
1758 *++oldsp = &PL_sv_undef;
1759 PL_stack_sp = oldsp;
1761 restartjmpenv = cx->blk_eval.cur_top_env;
1762 restartop = cx->blk_eval.retop;
1764 /* We need a FREETMPS here to avoid late-called destructors
1765 * clobbering $@ *after* we set it below, e.g.
1766 * sub DESTROY { eval { die "X" } }
1767 * eval { my $x = bless []; die $x = 0, "Y" };
1769 * Here the clearing of the $x ref mortalises the anon array,
1770 * which needs to be freed *before* $& is set to "Y",
1771 * otherwise it gets overwritten with "X".
1773 * However, the FREETMPS will clobber exceptsv, so preserve it
1774 * on the savestack for now.
1776 SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv));
1778 /* now we're about to pop the savestack, so re-mortalise it */
1779 sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1781 /* Note that unlike pp_entereval, pp_require isn't supposed to
1782 * trap errors. So if we're a require, after we pop the
1783 * CXt_EVAL that pp_require pushed, rethrow the error with
1784 * croak(exceptsv). This is all handled by the call below when
1787 S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
1789 if (!(in_eval & EVAL_KEEPERR))
1790 sv_setsv(ERRSV, exceptsv);
1791 PL_restartjmpenv = restartjmpenv;
1792 PL_restartop = restartop;
1794 NOT_REACHED; /* NOTREACHED */
1798 write_to_stderr(exceptsv);
1800 NOT_REACHED; /* NOTREACHED */
1806 if (SvTRUE(left) != SvTRUE(right))
1814 =head1 CV Manipulation Functions
1816 =for apidoc caller_cx
1818 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1819 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1820 information returned to Perl by C<caller>. Note that XSUBs don't get a
1821 stack frame, so C<caller_cx(0, NULL)> will return information for the
1822 immediately-surrounding Perl code.
1824 This function skips over the automatic calls to C<&DB::sub> made on the
1825 behalf of the debugger. If the stack frame requested was a sub called by
1826 C<DB::sub>, the return value will be the frame for the call to
1827 C<DB::sub>, since that has the correct line number/etc. for the call
1828 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1829 frame for the sub call itself.
1834 const PERL_CONTEXT *
1835 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1837 I32 cxix = dopoptosub(cxstack_ix);
1838 const PERL_CONTEXT *cx;
1839 const PERL_CONTEXT *ccstack = cxstack;
1840 const PERL_SI *top_si = PL_curstackinfo;
1843 /* we may be in a higher stacklevel, so dig down deeper */
1844 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1845 top_si = top_si->si_prev;
1846 ccstack = top_si->si_cxstack;
1847 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1851 /* caller() should not report the automatic calls to &DB::sub */
1852 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1853 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1857 cxix = dopoptosub_at(ccstack, cxix - 1);
1860 cx = &ccstack[cxix];
1861 if (dbcxp) *dbcxp = cx;
1863 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1864 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1865 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1866 field below is defined for any cx. */
1867 /* caller() should not report the automatic calls to &DB::sub */
1868 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1869 cx = &ccstack[dbcxix];
1878 const PERL_CONTEXT *cx;
1879 const PERL_CONTEXT *dbcx;
1881 const HEK *stash_hek;
1883 bool has_arg = MAXARG && TOPs;
1892 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1894 if (gimme != G_ARRAY) {
1901 CX_DEBUG(cx, "CALLER");
1902 assert(CopSTASH(cx->blk_oldcop));
1903 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1904 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1906 if (gimme != G_ARRAY) {
1909 PUSHs(&PL_sv_undef);
1912 sv_sethek(TARG, stash_hek);
1921 PUSHs(&PL_sv_undef);
1924 sv_sethek(TARG, stash_hek);
1927 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1928 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1929 cx->blk_sub.retop, TRUE);
1931 lcop = cx->blk_oldcop;
1932 mPUSHu(CopLINE(lcop));
1935 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1936 /* So is ccstack[dbcxix]. */
1937 if (CvHASGV(dbcx->blk_sub.cv)) {
1938 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1939 PUSHs(boolSV(CxHASARGS(cx)));
1942 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1943 PUSHs(boolSV(CxHASARGS(cx)));
1947 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1950 gimme = cx->blk_gimme;
1951 if (gimme == G_VOID)
1952 PUSHs(&PL_sv_undef);
1954 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1955 if (CxTYPE(cx) == CXt_EVAL) {
1957 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1958 SV *cur_text = cx->blk_eval.cur_text;
1959 if (SvCUR(cur_text) >= 2) {
1960 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1961 SvUTF8(cur_text)|SVs_TEMP));
1964 /* I think this is will always be "", but be sure */
1965 PUSHs(sv_2mortal(newSVsv(cur_text)));
1971 else if (cx->blk_eval.old_namesv) {
1972 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1975 /* eval BLOCK (try blocks have old_namesv == 0) */
1977 PUSHs(&PL_sv_undef);
1978 PUSHs(&PL_sv_undef);
1982 PUSHs(&PL_sv_undef);
1983 PUSHs(&PL_sv_undef);
1985 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1986 && CopSTASH_eq(PL_curcop, PL_debstash))
1988 /* slot 0 of the pad contains the original @_ */
1989 AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
1990 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1991 cx->blk_sub.olddepth+1]))[0]);
1992 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1994 Perl_init_dbargs(aTHX);
1996 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1997 av_extend(PL_dbargs, AvFILLp(ary) + off);
1998 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1999 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
2001 mPUSHi(CopHINTS_get(cx->blk_oldcop));
2004 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
2006 if (old_warnings == pWARN_NONE)
2007 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
2008 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
2009 mask = &PL_sv_undef ;
2010 else if (old_warnings == pWARN_ALL ||
2011 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
2012 /* Get the bit mask for $warnings::Bits{all}, because
2013 * it could have been extended by warnings::register */
2015 HV * const bits = get_hv("warnings::Bits", 0);
2016 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
2017 mask = newSVsv(*bits_all);
2020 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
2024 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
2028 PUSHs(cx->blk_oldcop->cop_hints_hash ?
2029 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2039 if (MAXARG < 1 || (!TOPs && !POPs))
2040 tmps = NULL, len = 0;
2042 tmps = SvPVx_const(POPs, len);
2043 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
2048 /* like pp_nextstate, but used instead when the debugger is active */
2052 PL_curcop = (COP*)PL_op;
2053 TAINT_NOT; /* Each statement is presumed innocent */
2054 PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
2059 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2060 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2064 const U8 gimme = G_ARRAY;
2065 GV * const gv = PL_DBgv;
2068 if (gv && isGV_with_GP(gv))
2071 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2072 DIE(aTHX_ "No DB::DB routine defined");
2074 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2075 /* don't do recursive DB::DB call */
2085 (void)(*CvXSUB(cv))(aTHX_ cv);
2091 cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
2092 cx_pushsub(cx, cv, PL_op->op_next, 0);
2093 /* OP_DBSTATE's op_private holds hint bits rather than
2094 * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2095 * any CxLVAL() flags that have now been mis-calculated */
2102 if (CvDEPTH(cv) >= 2)
2103 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2104 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2105 RETURNOP(CvSTART(cv));
2117 (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2129 assert(CxTYPE(cx) == CXt_BLOCK);
2131 if (PL_op->op_flags & OPf_SPECIAL)
2132 /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */
2133 cx->blk_oldpm = PL_curpm;
2135 oldsp = PL_stack_base + cx->blk_oldsp;
2136 gimme = cx->blk_gimme;
2138 if (gimme == G_VOID)
2139 PL_stack_sp = oldsp;
2141 leave_adjust_stacks(oldsp, oldsp, gimme,
2142 PL_op->op_private & OPpLVALUE ? 3 : 1);
2152 S_outside_integer(pTHX_ SV *sv)
2155 const NV nv = SvNV_nomg(sv);
2156 if (Perl_isinfnan(nv))
2158 #ifdef NV_PRESERVES_UV
2159 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2162 if (nv <= (NV)IV_MIN)
2165 ((nv > (NV)UV_MAX ||
2166 SvUV_nomg(sv) > (UV)IV_MAX)))
2177 const U8 gimme = GIMME_V;
2178 void *itervarp; /* GV or pad slot of the iteration variable */
2179 SV *itersave; /* the old var in the iterator var slot */
2182 if (PL_op->op_targ) { /* "my" variable */
2183 itervarp = &PAD_SVl(PL_op->op_targ);
2184 itersave = *(SV**)itervarp;
2186 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2187 /* the SV currently in the pad slot is never live during
2188 * iteration (the slot is always aliased to one of the items)
2189 * so it's always stale */
2190 SvPADSTALE_on(itersave);
2192 SvREFCNT_inc_simple_void_NN(itersave);
2193 cxflags = CXp_FOR_PAD;
2196 SV * const sv = POPs;
2197 itervarp = (void *)sv;
2198 if (LIKELY(isGV(sv))) { /* symbol table variable */
2199 itersave = GvSV(sv);
2200 SvREFCNT_inc_simple_void(itersave);
2201 cxflags = CXp_FOR_GV;
2202 if (PL_op->op_private & OPpITER_DEF)
2203 cxflags |= CXp_FOR_DEF;
2205 else { /* LV ref: for \$foo (...) */
2206 assert(SvTYPE(sv) == SVt_PVMG);
2207 assert(SvMAGIC(sv));
2208 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2210 cxflags = CXp_FOR_LVREF;
2213 /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2214 assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2216 /* Note that this context is initially set as CXt_NULL. Further on
2217 * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2218 * there mustn't be anything in the blk_loop substruct that requires
2219 * freeing or undoing, in case we die in the meantime. And vice-versa.
2221 cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2222 cx_pushloop_for(cx, itervarp, itersave);
2224 if (PL_op->op_flags & OPf_STACKED) {
2225 /* OPf_STACKED implies either a single array: for(@), with a
2226 * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2228 SV *maybe_ary = POPs;
2229 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2232 SV * const right = maybe_ary;
2233 if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2234 DIE(aTHX_ "Assigned value is not a reference");
2237 if (RANGE_IS_NUMERIC(sv,right)) {
2238 cx->cx_type |= CXt_LOOP_LAZYIV;
2239 if (S_outside_integer(aTHX_ sv) ||
2240 S_outside_integer(aTHX_ right))
2241 DIE(aTHX_ "Range iterator outside integer range");
2242 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2243 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2246 cx->cx_type |= CXt_LOOP_LAZYSV;
2247 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2248 cx->blk_loop.state_u.lazysv.end = right;
2249 SvREFCNT_inc_simple_void_NN(right);
2250 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2251 /* This will do the upgrade to SVt_PV, and warn if the value
2252 is uninitialised. */
2253 (void) SvPV_nolen_const(right);
2254 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2255 to replace !SvOK() with a pointer to "". */
2257 SvREFCNT_dec(right);
2258 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2262 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2263 /* for (@array) {} */
2264 cx->cx_type |= CXt_LOOP_ARY;
2265 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2266 SvREFCNT_inc_simple_void_NN(maybe_ary);
2267 cx->blk_loop.state_u.ary.ix =
2268 (PL_op->op_private & OPpITER_REVERSED) ?
2269 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2272 /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
2274 else { /* iterating over items on the stack */
2275 cx->cx_type |= CXt_LOOP_LIST;
2276 cx->blk_oldsp = SP - PL_stack_base;
2277 cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2278 cx->blk_loop.state_u.stack.ix =
2279 (PL_op->op_private & OPpITER_REVERSED)
2281 : cx->blk_loop.state_u.stack.basesp;
2282 /* pre-extend stack so pp_iter doesn't have to check every time
2283 * it pushes yes/no */
2293 const U8 gimme = GIMME_V;
2295 cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2296 cx_pushloop_plain(cx);
2309 assert(CxTYPE_is_LOOP(cx));
2310 oldsp = PL_stack_base + cx->blk_oldsp;
2311 base = CxTYPE(cx) == CXt_LOOP_LIST
2312 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2314 gimme = cx->blk_gimme;
2316 if (gimme == G_VOID)
2319 leave_adjust_stacks(oldsp, base, gimme,
2320 PL_op->op_private & OPpLVALUE ? 3 : 1);
2323 cx_poploop(cx); /* Stack values are safe: release loop vars ... */
2331 /* This duplicates most of pp_leavesub, but with additional code to handle
2332 * return args in lvalue context. It was forked from pp_leavesub to
2333 * avoid slowing down that function any further.
2335 * Any changes made to this function may need to be copied to pp_leavesub
2338 * also tail-called by pp_return
2349 assert(CxTYPE(cx) == CXt_SUB);
2351 if (CxMULTICALL(cx)) {
2352 /* entry zero of a stack is always PL_sv_undef, which
2353 * simplifies converting a '()' return into undef in scalar context */
2354 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2358 gimme = cx->blk_gimme;
2359 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2361 if (gimme == G_VOID)
2362 PL_stack_sp = oldsp;
2364 U8 lval = CxLVAL(cx);
2365 bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2366 const char *what = NULL;
2368 if (gimme == G_SCALAR) {
2370 /* check for bad return arg */
2371 if (oldsp < PL_stack_sp) {
2372 SV *sv = *PL_stack_sp;
2373 if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2375 SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2376 : "a readonly value" : "a temporary";
2381 /* sub:lvalue{} will take us here. */
2386 "Can't return %s from lvalue subroutine", what);
2390 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2392 if (lval & OPpDEREF) {
2393 /* lval_sub()->{...} and similar */
2397 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2403 assert(gimme == G_ARRAY);
2404 assert (!(lval & OPpDEREF));
2407 /* scan for bad return args */
2409 for (p = PL_stack_sp; p > oldsp; p--) {
2411 /* the PL_sv_undef exception is to allow things like
2412 * this to work, where PL_sv_undef acts as 'skip'
2413 * placeholder on the LHS of list assigns:
2414 * sub foo :lvalue { undef }
2415 * ($a, undef, foo(), $b) = 1..4;
2417 if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2419 /* Might be flattened array after $#array = */
2420 what = SvREADONLY(sv)
2421 ? "a readonly value" : "a temporary";
2427 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2432 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
2434 retop = cx->blk_sub.retop;
2445 const I32 cxix = dopoptosub(cxstack_ix);
2447 assert(cxstack_ix >= 0);
2448 if (cxix < cxstack_ix) {
2450 if (!( PL_curstackinfo->si_type == PERLSI_SORT
2451 || ( PL_curstackinfo->si_type == PERLSI_MULTICALL
2452 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2455 DIE(aTHX_ "Can't return outside a subroutine");
2457 * a sort block, which is a CXt_NULL not a CXt_SUB;
2458 * or a /(?{...})/ block.
2459 * Handle specially. */
2460 assert(CxTYPE(&cxstack[0]) == CXt_NULL
2461 || ( CxTYPE(&cxstack[0]) == CXt_SUB
2462 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2463 if (cxstack_ix > 0) {
2464 /* See comment below about context popping. Since we know
2465 * we're scalar and not lvalue, we can preserve the return
2466 * value in a simpler fashion than there. */
2468 assert(cxstack[0].blk_gimme == G_SCALAR);
2469 if ( (sp != PL_stack_base)
2470 && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2472 *SP = sv_mortalcopy(sv);
2475 /* caller responsible for popping cxstack[0] */
2479 /* There are contexts that need popping. Doing this may free the
2480 * return value(s), so preserve them first: e.g. popping the plain
2481 * loop here would free $x:
2482 * sub f { { my $x = 1; return $x } }
2483 * We may also need to shift the args down; for example,
2484 * for (1,2) { return 3,4 }
2485 * leaves 1,2,3,4 on the stack. Both these actions will be done by
2486 * leave_adjust_stacks(), along with freeing any temps. Note that
2487 * whoever we tail-call (e.g. pp_leaveeval) will also call
2488 * leave_adjust_stacks(); however, the second call is likely to
2489 * just see a bunch of SvTEMPs with a ref count of 1, and so just
2490 * pass them through, rather than copying them again. So this
2491 * isn't as inefficient as it sounds.
2493 cx = &cxstack[cxix];
2495 if (cx->blk_gimme != G_VOID)
2496 leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2498 CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2502 cx = &cxstack[cxix]; /* CX stack may have been realloced */
2505 /* Like in the branch above, we need to handle any extra junk on
2506 * the stack. But because we're not also popping extra contexts, we
2507 * don't have to worry about prematurely freeing args. So we just
2508 * need to do the bare minimum to handle junk, and leave the main
2509 * arg processing in the function we tail call, e.g. pp_leavesub.
2510 * In list context we have to splice out the junk; in scalar
2511 * context we can leave as-is (pp_leavesub will later return the
2512 * top stack element). But for an empty arg list, e.g.
2513 * for (1,2) { return }
2514 * we need to set sp = oldsp so that pp_leavesub knows to push
2515 * &PL_sv_undef onto the stack.
2518 cx = &cxstack[cxix];
2519 oldsp = PL_stack_base + cx->blk_oldsp;
2520 if (oldsp != MARK) {
2521 SSize_t nargs = SP - MARK;
2523 if (cx->blk_gimme == G_ARRAY) {
2524 /* shift return args to base of call stack frame */
2525 Move(MARK + 1, oldsp + 1, nargs, SV*);
2526 PL_stack_sp = oldsp + nargs;
2530 PL_stack_sp = oldsp;
2534 /* fall through to a normal exit */
2535 switch (CxTYPE(cx)) {
2537 return CxTRYBLOCK(cx)
2538 ? Perl_pp_leavetry(aTHX)
2539 : Perl_pp_leaveeval(aTHX);
2541 return CvLVALUE(cx->blk_sub.cv)
2542 ? Perl_pp_leavesublv(aTHX)
2543 : Perl_pp_leavesub(aTHX);
2545 return Perl_pp_leavewrite(aTHX);
2547 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2551 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2553 static PERL_CONTEXT *
2557 if (PL_op->op_flags & OPf_SPECIAL) {
2558 cxix = dopoptoloop(cxstack_ix);
2560 /* diag_listed_as: Can't "last" outside a loop block */
2561 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2567 const char * const label =
2568 PL_op->op_flags & OPf_STACKED
2569 ? SvPV(TOPs,label_len)
2570 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2571 const U32 label_flags =
2572 PL_op->op_flags & OPf_STACKED
2574 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2576 cxix = dopoptolabel(label, label_len, label_flags);
2578 /* diag_listed_as: Label not found for "last %s" */
2579 Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"",
2581 SVfARG(PL_op->op_flags & OPf_STACKED
2582 && !SvGMAGICAL(TOPp1s)
2584 : newSVpvn_flags(label,
2586 label_flags | SVs_TEMP)));
2588 if (cxix < cxstack_ix)
2590 return &cxstack[cxix];
2599 cx = S_unwind_loop(aTHX);
2601 assert(CxTYPE_is_LOOP(cx));
2602 PL_stack_sp = PL_stack_base
2603 + (CxTYPE(cx) == CXt_LOOP_LIST
2604 ? cx->blk_loop.state_u.stack.basesp
2610 /* Stack values are safe: */
2612 cx_poploop(cx); /* release loop vars ... */
2614 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2624 /* if not a bare 'next' in the main scope, search for it */
2626 if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
2627 cx = S_unwind_loop(aTHX);
2630 PL_curcop = cx->blk_oldcop;
2632 return (cx)->blk_loop.my_op->op_nextop;
2637 PERL_CONTEXT *cx = S_unwind_loop(aTHX);
2638 OP* redo_op = cx->blk_loop.my_op->op_redoop;
2640 if (redo_op->op_type == OP_ENTER) {
2641 /* pop one less context to avoid $x being freed in while (my $x..) */
2644 assert(CxTYPE(cx) == CXt_BLOCK);
2645 redo_op = redo_op->op_next;
2651 PL_curcop = cx->blk_oldcop;
2657 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2660 static const char* const too_deep = "Target of goto is too deeply nested";
2662 PERL_ARGS_ASSERT_DOFINDLABEL;
2665 Perl_croak(aTHX_ "%s", too_deep);
2666 if (o->op_type == OP_LEAVE ||
2667 o->op_type == OP_SCOPE ||
2668 o->op_type == OP_LEAVELOOP ||
2669 o->op_type == OP_LEAVESUB ||
2670 o->op_type == OP_LEAVETRY)
2672 *ops++ = cUNOPo->op_first;
2674 Perl_croak(aTHX_ "%s", too_deep);
2677 if (o->op_flags & OPf_KIDS) {
2679 /* First try all the kids at this level, since that's likeliest. */
2680 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2681 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2682 STRLEN kid_label_len;
2683 U32 kid_label_flags;
2684 const char *kid_label = CopLABEL_len_flags(kCOP,
2685 &kid_label_len, &kid_label_flags);
2687 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2690 (const U8*)kid_label, kid_label_len,
2691 (const U8*)label, len) == 0)
2693 (const U8*)label, len,
2694 (const U8*)kid_label, kid_label_len) == 0)
2695 : ( len == kid_label_len && ((kid_label == label)
2696 || memEQ(kid_label, label, len)))))
2700 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2701 if (kid == PL_lastgotoprobe)
2703 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2706 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2707 ops[-1]->op_type == OP_DBSTATE)
2712 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2721 /* also used for: pp_dump() */
2729 #define GOTO_DEPTH 64
2730 OP *enterops[GOTO_DEPTH];
2731 const char *label = NULL;
2732 STRLEN label_len = 0;
2733 U32 label_flags = 0;
2734 const bool do_dump = (PL_op->op_type == OP_DUMP);
2735 static const char* const must_have_label = "goto must have label";
2737 if (PL_op->op_flags & OPf_STACKED) {
2738 /* goto EXPR or goto &foo */
2740 SV * const sv = POPs;
2743 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2744 /* This egregious kludge implements goto &subroutine */
2747 CV *cv = MUTABLE_CV(SvRV(sv));
2748 AV *arg = GvAV(PL_defgv);
2750 while (!CvROOT(cv) && !CvXSUB(cv)) {
2751 const GV * const gv = CvGV(cv);
2755 /* autoloaded stub? */
2756 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2758 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2760 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2761 if (autogv && (cv = GvCV(autogv)))
2763 tmpstr = sv_newmortal();
2764 gv_efullname3(tmpstr, gv, NULL);
2765 DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
2767 DIE(aTHX_ "Goto undefined subroutine");
2770 cxix = dopoptosub(cxstack_ix);
2772 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2774 cx = &cxstack[cxix];
2775 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2776 if (CxTYPE(cx) == CXt_EVAL) {
2778 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2779 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2781 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2782 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2784 else if (CxMULTICALL(cx))
2785 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2787 /* First do some returnish stuff. */
2789 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2791 if (cxix < cxstack_ix) {
2798 /* protect @_ during save stack unwind. */
2800 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
2802 assert(PL_scopestack_ix == cx->blk_oldscopesp);
2805 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2806 /* this is part of cx_popsub_args() */
2807 AV* av = MUTABLE_AV(PAD_SVl(0));
2808 assert(AvARRAY(MUTABLE_AV(
2809 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2810 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2812 /* we are going to donate the current @_ from the old sub
2813 * to the new sub. This first part of the donation puts a
2814 * new empty AV in the pad[0] slot of the old sub,
2815 * unless pad[0] and @_ differ (e.g. if the old sub did
2816 * local *_ = []); in which case clear the old pad[0]
2817 * array in the usual way */
2818 if (av == arg || AvREAL(av))
2819 clear_defarray(av, av == arg);
2820 else CLEAR_ARGARRAY(av);
2823 /* don't restore PL_comppad here. It won't be needed if the
2824 * sub we're going to is non-XS, but restoring it early then
2825 * croaking (e.g. the "Goto undefined subroutine" below)
2826 * means the CX block gets processed again in dounwind,
2827 * but this time with the wrong PL_comppad */
2829 /* A destructor called during LEAVE_SCOPE could have undefined
2830 * our precious cv. See bug #99850. */
2831 if (!CvROOT(cv) && !CvXSUB(cv)) {
2832 const GV * const gv = CvGV(cv);
2834 SV * const tmpstr = sv_newmortal();
2835 gv_efullname3(tmpstr, gv, NULL);
2836 DIE(aTHX_ "Goto undefined subroutine &%" SVf,
2839 DIE(aTHX_ "Goto undefined subroutine");
2842 if (CxTYPE(cx) == CXt_SUB) {
2843 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2844 SvREFCNT_dec_NN(cx->blk_sub.cv);
2847 /* Now do some callish stuff. */
2849 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2850 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2855 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2857 /* put GvAV(defgv) back onto stack */
2859 EXTEND(SP, items+1); /* @_ could have been extended. */
2864 bool r = cBOOL(AvREAL(arg));
2865 for (index=0; index<items; index++)
2869 SV ** const svp = av_fetch(arg, index, 0);
2870 sv = svp ? *svp : NULL;
2872 else sv = AvARRAY(arg)[index];
2874 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2875 : sv_2mortal(newSVavdefelem(arg, index, 1));
2879 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2880 /* Restore old @_ */
2881 CX_POP_SAVEARRAY(cx);
2884 retop = cx->blk_sub.retop;
2885 PL_comppad = cx->blk_sub.prevcomppad;
2886 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2888 /* XS subs don't have a CXt_SUB, so pop it;
2889 * this is a cx_popblock(), less all the stuff we already did
2890 * for cx_topblock() earlier */
2891 PL_curcop = cx->blk_oldcop;
2894 /* Push a mark for the start of arglist */
2897 (void)(*CvXSUB(cv))(aTHX_ cv);
2902 PADLIST * const padlist = CvPADLIST(cv);
2904 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2906 /* partial unrolled cx_pushsub(): */
2908 cx->blk_sub.cv = cv;
2909 cx->blk_sub.olddepth = CvDEPTH(cv);
2912 SvREFCNT_inc_simple_void_NN(cv);
2913 if (CvDEPTH(cv) > 1) {
2914 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2915 sub_crush_depth(cv);
2916 pad_push(padlist, CvDEPTH(cv));
2918 PL_curcop = cx->blk_oldcop;
2919 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2922 /* second half of donating @_ from the old sub to the
2923 * new sub: abandon the original pad[0] AV in the
2924 * new sub, and replace it with the donated @_.
2925 * pad[0] takes ownership of the extra refcount
2926 * we gave arg earlier */
2928 SvREFCNT_dec(PAD_SVl(0));
2929 PAD_SVl(0) = (SV *)arg;
2930 SvREFCNT_inc_simple_void_NN(arg);
2933 /* GvAV(PL_defgv) might have been modified on scope
2934 exit, so point it at arg again. */
2935 if (arg != GvAV(PL_defgv)) {
2936 AV * const av = GvAV(PL_defgv);
2937 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2942 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2943 Perl_get_db_sub(aTHX_ NULL, cv);
2945 CV * const gotocv = get_cvs("DB::goto", 0);
2947 PUSHMARK( PL_stack_sp );
2948 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2953 retop = CvSTART(cv);
2954 goto putback_return;
2959 label = SvPV_nomg_const(sv, label_len);
2960 label_flags = SvUTF8(sv);
2963 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2964 /* goto LABEL or dump LABEL */
2965 label = cPVOP->op_pv;
2966 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2967 label_len = strlen(label);
2969 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2974 OP *gotoprobe = NULL;
2975 bool leaving_eval = FALSE;
2976 bool in_block = FALSE;
2977 bool pseudo_block = FALSE;
2978 PERL_CONTEXT *last_eval_cx = NULL;
2982 PL_lastgotoprobe = NULL;
2984 for (ix = cxstack_ix; ix >= 0; ix--) {
2986 switch (CxTYPE(cx)) {
2988 leaving_eval = TRUE;
2989 if (!CxTRYBLOCK(cx)) {
2990 gotoprobe = (last_eval_cx ?
2991 last_eval_cx->blk_eval.old_eval_root :
2996 /* else fall through */
2997 case CXt_LOOP_PLAIN:
2998 case CXt_LOOP_LAZYIV:
2999 case CXt_LOOP_LAZYSV:
3004 gotoprobe = OpSIBLING(cx->blk_oldcop);
3010 gotoprobe = OpSIBLING(cx->blk_oldcop);
3013 gotoprobe = PL_main_root;
3016 gotoprobe = CvROOT(cx->blk_sub.cv);
3017 pseudo_block = cBOOL(CxMULTICALL(cx));
3021 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3024 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3025 CxTYPE(cx), (long) ix);
3026 gotoprobe = PL_main_root;
3032 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3033 enterops, enterops + GOTO_DEPTH);
3036 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3037 sibl1->op_type == OP_UNSTACK &&
3038 (sibl2 = OpSIBLING(sibl1)))
3040 retop = dofindlabel(sibl2,
3041 label, label_len, label_flags, enterops,
3042 enterops + GOTO_DEPTH);
3048 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3049 PL_lastgotoprobe = gotoprobe;
3052 DIE(aTHX_ "Can't find label %" UTF8f,
3053 UTF8fARG(label_flags, label_len, label));
3055 /* if we're leaving an eval, check before we pop any frames
3056 that we're not going to punt, otherwise the error
3059 if (leaving_eval && *enterops && enterops[1]) {
3061 for (i = 1; enterops[i]; i++)
3062 if (enterops[i]->op_type == OP_ENTERITER)
3063 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3066 if (*enterops && enterops[1]) {
3067 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3069 deprecate("\"goto\" to jump into a construct");
3072 /* pop unwanted frames */
3074 if (ix < cxstack_ix) {
3076 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3082 /* push wanted frames */
3084 if (*enterops && enterops[1]) {
3085 OP * const oldop = PL_op;
3086 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3087 for (; enterops[ix]; ix++) {
3088 PL_op = enterops[ix];
3089 /* Eventually we may want to stack the needed arguments
3090 * for each op. For now, we punt on the hard ones. */
3091 if (PL_op->op_type == OP_ENTERITER)
3092 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3093 PL_op->op_ppaddr(aTHX);
3101 if (!retop) retop = PL_main_start;
3103 PL_restartop = retop;
3104 PL_do_undump = TRUE;
3108 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3109 PL_do_undump = FALSE;
3127 anum = 0; (void)POPs;
3133 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3136 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3139 PL_exit_flags |= PERL_EXIT_EXPECTED;
3141 PUSHs(&PL_sv_undef);
3148 S_save_lines(pTHX_ AV *array, SV *sv)
3150 const char *s = SvPVX_const(sv);
3151 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3154 PERL_ARGS_ASSERT_SAVE_LINES;
3156 while (s && s < send) {
3158 SV * const tmpstr = newSV_type(SVt_PVMG);
3160 t = (const char *)memchr(s, '\n', send - s);
3166 sv_setpvn(tmpstr, s, t - s);
3167 av_store(array, line++, tmpstr);
3175 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3177 0 is used as continue inside eval,
3179 3 is used for a die caught by an inner eval - continue inner loop
3181 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3182 establish a local jmpenv to handle exception traps.
3187 S_docatch(pTHX_ Perl_ppaddr_t firstpp)
3190 OP * const oldop = PL_op;
3193 assert(CATCH_GET == TRUE);
3198 PL_op = firstpp(aTHX);
3203 /* die caught by an inner eval - continue inner loop */
3204 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3205 PL_restartjmpenv = NULL;
3206 PL_op = PL_restartop;
3215 NOT_REACHED; /* NOTREACHED */
3224 =for apidoc find_runcv
3226 Locate the CV corresponding to the currently executing sub or eval.
3227 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3228 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3229 entered. (This allows debuggers to eval in the scope of the breakpoint
3230 rather than in the scope of the debugger itself.)
3236 Perl_find_runcv(pTHX_ U32 *db_seqp)
3238 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3241 /* If this becomes part of the API, it might need a better name. */
3243 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3250 PL_curcop == &PL_compiling
3252 : PL_curcop->cop_seq;
3254 for (si = PL_curstackinfo; si; si = si->si_prev) {
3256 for (ix = si->si_cxix; ix >= 0; ix--) {
3257 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3259 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3260 cv = cx->blk_sub.cv;
3261 /* skip DB:: code */
3262 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3263 *db_seqp = cx->blk_oldcop->cop_seq;
3266 if (cx->cx_type & CXp_SUB_RE)
3269 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3270 cv = cx->blk_eval.cv;
3273 case FIND_RUNCV_padid_eq:
3275 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3278 case FIND_RUNCV_level_eq:
3279 if (level++ != arg) continue;
3287 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3291 /* Run yyparse() in a setjmp wrapper. Returns:
3292 * 0: yyparse() successful
3293 * 1: yyparse() failed
3297 S_try_yyparse(pTHX_ int gramtype)
3302 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3306 ret = yyparse(gramtype) ? 1 : 0;
3313 NOT_REACHED; /* NOTREACHED */
3320 /* Compile a require/do or an eval ''.
3322 * outside is the lexically enclosing CV (if any) that invoked us.
3323 * seq is the current COP scope value.
3324 * hh is the saved hints hash, if any.
3326 * Returns a bool indicating whether the compile was successful; if so,
3327 * PL_eval_start contains the first op of the compiled code; otherwise,
3330 * This function is called from two places: pp_require and pp_entereval.
3331 * These can be distinguished by whether PL_op is entereval.
3335 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3338 OP * const saveop = PL_op;
3339 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3340 COP * const oldcurcop = PL_curcop;
3341 bool in_require = (saveop->op_type == OP_REQUIRE);
3345 PL_in_eval = (in_require
3346 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3348 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3349 ? EVAL_RE_REPARSING : 0)));
3353 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3355 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3356 CX_CUR()->blk_eval.cv = evalcv;
3357 CX_CUR()->blk_gimme = gimme;
3359 CvOUTSIDE_SEQ(evalcv) = seq;
3360 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3362 /* set up a scratch pad */
3364 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3365 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3368 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3370 /* make sure we compile in the right package */
3372 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3373 SAVEGENERICSV(PL_curstash);
3374 PL_curstash = (HV *)CopSTASH(PL_curcop);
3375 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3376 else SvREFCNT_inc_simple_void(PL_curstash);
3378 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3379 SAVESPTR(PL_beginav);
3380 PL_beginav = newAV();
3381 SAVEFREESV(PL_beginav);
3382 SAVESPTR(PL_unitcheckav);
3383 PL_unitcheckav = newAV();
3384 SAVEFREESV(PL_unitcheckav);
3387 ENTER_with_name("evalcomp");
3388 SAVESPTR(PL_compcv);
3391 /* try to compile it */
3393 PL_eval_root = NULL;
3394 PL_curcop = &PL_compiling;
3395 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3396 PL_in_eval |= EVAL_KEEPERR;
3403 hv_clear(GvHV(PL_hintgv));
3406 PL_hints = saveop->op_private & OPpEVAL_COPHH
3407 ? oldcurcop->cop_hints : (U32)saveop->op_targ;
3409 /* making 'use re eval' not be in scope when compiling the
3410 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3411 * infinite recursion when S_has_runtime_code() gives a false
3412 * positive: the second time round, HINT_RE_EVAL isn't set so we
3413 * don't bother calling S_has_runtime_code() */
3414 if (PL_in_eval & EVAL_RE_REPARSING)
3415 PL_hints &= ~HINT_RE_EVAL;
3418 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3419 SvREFCNT_dec(GvHV(PL_hintgv));
3420 GvHV(PL_hintgv) = hh;
3423 SAVECOMPILEWARNINGS();
3425 if (PL_dowarn & G_WARN_ALL_ON)
3426 PL_compiling.cop_warnings = pWARN_ALL ;
3427 else if (PL_dowarn & G_WARN_ALL_OFF)
3428 PL_compiling.cop_warnings = pWARN_NONE ;
3430 PL_compiling.cop_warnings = pWARN_STD ;
3433 PL_compiling.cop_warnings =
3434 DUP_WARNINGS(oldcurcop->cop_warnings);
3435 cophh_free(CopHINTHASH_get(&PL_compiling));
3436 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3437 /* The label, if present, is the first entry on the chain. So rather
3438 than writing a blank label in front of it (which involves an
3439 allocation), just use the next entry in the chain. */
3440 PL_compiling.cop_hints_hash
3441 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3442 /* Check the assumption that this removed the label. */
3443 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3446 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3449 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3451 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3452 * so honour CATCH_GET and trap it here if necessary */
3455 /* compile the code */
3456 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3458 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3463 /* note that if yystatus == 3, then the require/eval died during
3464 * compilation, so the EVAL CX block has already been popped, and
3465 * various vars restored */
3466 if (yystatus != 3) {
3468 op_free(PL_eval_root);
3469 PL_eval_root = NULL;
3471 SP = PL_stack_base + POPMARK; /* pop original mark */
3473 assert(CxTYPE(cx) == CXt_EVAL);
3474 /* pop the CXt_EVAL, and if was a require, croak */
3475 S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
3478 /* die_unwind() re-croaks when in require, having popped the
3479 * require EVAL context. So we should never catch a require
3481 assert(!in_require);
3484 if (!*(SvPV_nolen_const(errsv)))
3485 sv_setpvs(errsv, "Compilation error");
3487 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3492 /* Compilation successful. Now clean up */
3494 LEAVE_with_name("evalcomp");
3496 CopLINE_set(&PL_compiling, 0);
3497 SAVEFREEOP(PL_eval_root);
3498 cv_forget_slab(evalcv);
3500 DEBUG_x(dump_eval());
3502 /* Register with debugger: */
3503 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3504 CV * const cv = get_cvs("DB::postponed", 0);
3508 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3510 call_sv(MUTABLE_SV(cv), G_DISCARD);
3514 if (PL_unitcheckav) {
3515 OP *es = PL_eval_start;
3516 call_list(PL_scopestack_ix, PL_unitcheckav);
3520 CvDEPTH(evalcv) = 1;
3521 SP = PL_stack_base + POPMARK; /* pop original mark */
3522 PL_op = saveop; /* The caller may need it. */
3523 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3529 /* Return NULL if the file doesn't exist or isn't a file;
3530 * else return PerlIO_openn().
3534 S_check_type_and_open(pTHX_ SV *name)
3539 const char *p = SvPV_const(name, len);
3542 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3544 /* checking here captures a reasonable error message when
3545 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3546 * user gets a confusing message about looking for the .pmc file
3547 * rather than for the .pm file so do the check in S_doopen_pm when
3548 * PMC is on instead of here. S_doopen_pm calls this func.
3549 * This check prevents a \0 in @INC causing problems.
3551 #ifdef PERL_DISABLE_PMC
3552 if (!IS_SAFE_PATHNAME(p, len, "require"))
3556 /* on Win32 stat is expensive (it does an open() and close() twice and
3557 a couple other IO calls), the open will fail with a dir on its own with
3558 errno EACCES, so only do a stat to separate a dir from a real EACCES
3559 caused by user perms */
3561 /* we use the value of errno later to see how stat() or open() failed.
3562 * We don't want it set if the stat succeeded but we still failed,
3563 * such as if the name exists, but is a directory */
3566 st_rc = PerlLIO_stat(p, &st);
3568 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3573 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3575 /* EACCES stops the INC search early in pp_require to implement
3576 feature RT #113422 */
3577 if(!retio && errno == EACCES) { /* exists but probably a directory */
3579 st_rc = PerlLIO_stat(p, &st);
3581 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3592 /* doopen_pm(): return the equivalent of PerlIO_openn() on the given name,
3593 * but first check for bad names (\0) and non-files.
3594 * Also if the filename ends in .pm and unless PERL_DISABLE_PMC,
3595 * try loading Foo.pmc first.
3597 #ifndef PERL_DISABLE_PMC
3599 S_doopen_pm(pTHX_ SV *name)
3602 const char *p = SvPV_const(name, namelen);
3604 PERL_ARGS_ASSERT_DOOPEN_PM;
3606 /* check the name before trying for the .pmc name to avoid the
3607 * warning referring to the .pmc which the user probably doesn't
3608 * know or care about
3610 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3613 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3614 SV *const pmcsv = sv_newmortal();
3617 SvSetSV_nosteal(pmcsv,name);
3618 sv_catpvs(pmcsv, "c");
3620 pmcio = check_type_and_open(pmcsv);
3624 return check_type_and_open(name);
3627 # define doopen_pm(name) check_type_and_open(name)
3628 #endif /* !PERL_DISABLE_PMC */
3630 /* require doesn't search in @INC for absolute names, or when the name is
3631 explicitly relative the current directory: i.e. ./, ../ */
3632 PERL_STATIC_INLINE bool
3633 S_path_is_searchable(const char *name)
3635 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3637 if (PERL_FILE_IS_ABSOLUTE(name)
3639 || (*name == '.' && ((name[1] == '/' ||
3640 (name[1] == '.' && name[2] == '/'))
3641 || (name[1] == '\\' ||
3642 ( name[1] == '.' && name[2] == '\\')))
3645 || (*name == '.' && (name[1] == '/' ||
3646 (name[1] == '.' && name[2] == '/')))
3657 /* implement 'require 5.010001' */
3660 S_require_version(pTHX_ SV *sv)
3664 sv = sv_2mortal(new_version(sv));
3665 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3666 upg_version(PL_patchlevel, TRUE);
3667 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3668 if ( vcmp(sv,PL_patchlevel) <= 0 )
3669 DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
3670 SVfARG(sv_2mortal(vnormal(sv))),
3671 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3675 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3678 SV * const req = SvRV(sv);
3679 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3681 /* get the left hand term */
3682 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3684 first = SvIV(*av_fetch(lav,0,0));
3685 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3686 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3687 || av_tindex(lav) > 1 /* FP with > 3 digits */
3688 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3690 DIE(aTHX_ "Perl %" SVf " required--this is only "
3691 "%" SVf ", stopped",
3692 SVfARG(sv_2mortal(vnormal(req))),
3693 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3696 else { /* probably 'use 5.10' or 'use 5.8' */
3700 if (av_tindex(lav)>=1)
3701 second = SvIV(*av_fetch(lav,1,0));
3703 second /= second >= 600 ? 100 : 10;
3704 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3705 (int)first, (int)second);
3706 upg_version(hintsv, TRUE);
3708 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)"
3709 "--this is only %" SVf ", stopped",
3710 SVfARG(sv_2mortal(vnormal(req))),
3711 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3712 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3721 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
3722 * The first form will have already been converted at compile time to
3723 * the second form */
3726 S_require_file(pTHX_ SV *sv)
3736 int vms_unixname = 0;
3739 /* tryname is the actual pathname (with @INC prefix) which was loaded.
3740 * It's stored as a value in %INC, and used for error messages */
3741 const char *tryname = NULL;
3742 SV *namesv = NULL; /* SV equivalent of tryname */
3743 const U8 gimme = GIMME_V;
3744 int filter_has_file = 0;
3745 PerlIO *tryrsfp = NULL;
3746 SV *filter_cache = NULL;
3747 SV *filter_state = NULL;
3748 SV *filter_sub = NULL;
3752 bool path_searchable;
3753 I32 old_savestack_ix;
3754 const bool op_is_require = PL_op->op_type == OP_REQUIRE;
3755 const char *const op_name = op_is_require ? "require" : "do";
3757 assert(op_is_require || PL_op->op_type == OP_DOFILE);
3760 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3761 name = SvPV_nomg_const(sv, len);
3762 if (!(name && len > 0 && *name))
3763 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3765 if (!IS_SAFE_PATHNAME(name, len, op_name)) {
3766 if (!op_is_require) {
3770 DIE(aTHX_ "Can't locate %s: %s",
3771 pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
3772 NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3775 TAINT_PROPER(op_name);
3777 path_searchable = path_is_searchable(name);
3780 /* The key in the %ENV hash is in the syntax of file passed as the argument
3781 * usually this is in UNIX format, but sometimes in VMS format, which
3782 * can result in a module being pulled in more than once.
3783 * To prevent this, the key must be stored in UNIX format if the VMS
3784 * name can be translated to UNIX.
3788 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3790 unixlen = strlen(unixname);
3796 /* if not VMS or VMS name can not be translated to UNIX, pass it
3799 unixname = (char *) name;
3802 if (op_is_require) {
3803 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3804 unixname, unixlen, 0);
3806 if (*svp != &PL_sv_undef)
3809 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3810 "Compilation failed in require", unixname);
3813 /*XXX OPf_KIDS should always be true? -dapm 4/2017 */
3814 if (PL_op->op_flags & OPf_KIDS) {
3815 SVOP * const kid = (SVOP*)cUNOP->op_first;
3817 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3818 /* Make sure that a bareword module name (e.g. ::Foo::Bar)
3819 * doesn't map to a naughty pathname like /Foo/Bar.pm.
3820 * Note that the parser will normally detect such errors
3821 * at compile time before we reach here, but
3822 * Perl_load_module() can fake up an identical optree
3823 * without going near the parser, and being able to put
3824 * anything as the bareword. So we include a duplicate set
3825 * of checks here at runtime.
3827 const STRLEN package_len = len - 3;
3828 const char slashdot[2] = {'/', '.'};
3830 const char backslashdot[2] = {'\\', '.'};
3833 /* Disallow *purported* barewords that map to absolute
3834 filenames, filenames relative to the current or parent
3835 directory, or (*nix) hidden filenames. Also sanity check
3836 that the generated filename ends .pm */
3837 if (!path_searchable || len < 3 || name[0] == '.'
3838 || !memEQ(name + package_len, ".pm", 3))
3839 DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv);
3840 if (memchr(name, 0, package_len)) {
3841 /* diag_listed_as: Bareword in require contains "%s" */
3842 DIE(aTHX_ "Bareword in require contains \"\\0\"");
3844 if (ninstr(name, name + package_len, slashdot,
3845 slashdot + sizeof(slashdot))) {
3846 /* diag_listed_as: Bareword in require contains "%s" */
3847 DIE(aTHX_ "Bareword in require contains \"/.\"");
3850 if (ninstr(name, name + package_len, backslashdot,
3851 backslashdot + sizeof(backslashdot))) {
3852 /* diag_listed_as: Bareword in require contains "%s" */
3853 DIE(aTHX_ "Bareword in require contains \"\\.\"");
3860 PERL_DTRACE_PROBE_FILE_LOADING(unixname);
3862 /* Try to locate and open a file, possibly using @INC */
3864 /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load
3865 * the file directly rather than via @INC ... */
3866 if (!path_searchable) {
3867 /* At this point, name is SvPVX(sv) */
3869 tryrsfp = doopen_pm(sv);
3872 /* ... but if we fail, still search @INC for code references;
3873 * these are applied even on on-searchable paths (except
3874 * if we got EACESS).
3876 * For searchable paths, just search @INC normally
3878 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3879 AV * const ar = GvAVn(PL_incgv);
3886 namesv = newSV_type(SVt_PV);
3887 for (i = 0; i <= AvFILL(ar); i++) {
3888 SV * const dirsv = *av_fetch(ar, i, TRUE);
3896 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3897 && !SvOBJECT(SvRV(loader)))
3899 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3903 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
3904 PTR2UV(SvRV(dirsv)), name);
3905 tryname = SvPVX_const(namesv);
3908 if (SvPADTMP(nsv)) {
3909 nsv = sv_newmortal();
3910 SvSetSV_nosteal(nsv,sv);
3913 ENTER_with_name("call_INC");
3921 if (SvGMAGICAL(loader)) {
3922 SV *l = sv_newmortal();
3923 sv_setsv_nomg(l, loader);
3926 if (sv_isobject(loader))
3927 count = call_method("INC", G_ARRAY);
3929 count = call_sv(loader, G_ARRAY);
3939 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3940 && !isGV_with_GP(SvRV(arg))) {
3941 filter_cache = SvRV(arg);
3948 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3952 if (isGV_with_GP(arg)) {
3953 IO * const io = GvIO((const GV *)arg);
3958 tryrsfp = IoIFP(io);
3959 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3960 PerlIO_close(IoOFP(io));
3971 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3973 SvREFCNT_inc_simple_void_NN(filter_sub);
3976 filter_state = SP[i];
3977 SvREFCNT_inc_simple_void(filter_state);
3981 if (!tryrsfp && (filter_cache || filter_sub)) {
3982 tryrsfp = PerlIO_open(BIT_BUCKET,
3988 /* FREETMPS may free our filter_cache */
3989 SvREFCNT_inc_simple_void(filter_cache);
3993 LEAVE_with_name("call_INC");
3995 /* Now re-mortalize it. */
3996 sv_2mortal(filter_cache);
3998 /* Adjust file name if the hook has set an %INC entry.
3999 This needs to happen after the FREETMPS above. */
4000 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
4002 tryname = SvPV_nolen_const(*svp);
4009 filter_has_file = 0;
4010 filter_cache = NULL;
4012 SvREFCNT_dec_NN(filter_state);
4013 filter_state = NULL;
4016 SvREFCNT_dec_NN(filter_sub);
4020 else if (path_searchable) {
4021 /* match against a plain @INC element (non-searchable
4022 * paths are only matched against refs in @INC) */
4027 dir = SvPV_nomg_const(dirsv, dirlen);
4033 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
4037 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4040 sv_setpv(namesv, unixdir);
4041 sv_catpv(namesv, unixname);
4043 # ifdef __SYMBIAN32__
4044 if (PL_origfilename[0] &&
4045 PL_origfilename[1] == ':' &&
4046 !(dir[0] && dir[1] == ':'))
4047 Perl_sv_setpvf(aTHX_ namesv,
4052 Perl_sv_setpvf(aTHX_ namesv,
4056 /* The equivalent of
4057 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4058 but without the need to parse the format string, or
4059 call strlen on either pointer, and with the correct
4060 allocation up front. */
4062 char *tmp = SvGROW(namesv, dirlen + len + 2);
4064 memcpy(tmp, dir, dirlen);
4067 /* Avoid '<dir>//<file>' */
4068 if (!dirlen || *(tmp-1) != '/') {
4071 /* So SvCUR_set reports the correct length below */
4075 /* name came from an SV, so it will have a '\0' at the
4076 end that we can copy as part of this memcpy(). */
4077 memcpy(tmp, name, len + 1);
4079 SvCUR_set(namesv, dirlen + len + 1);
4084 TAINT_PROPER(op_name);
4085 tryname = SvPVX_const(namesv);
4086 tryrsfp = doopen_pm(namesv);
4088 if (tryname[0] == '.' && tryname[1] == '/') {
4090 while (*++tryname == '/') {}
4094 else if (errno == EMFILE || errno == EACCES) {
4095 /* no point in trying other paths if out of handles;
4096 * on the other hand, if we couldn't open one of the
4097 * files, then going on with the search could lead to
4098 * unexpected results; see perl #113422
4107 /* at this point we've ether opened a file (tryrsfp) or set errno */
4109 saved_errno = errno; /* sv_2mortal can realloc things */
4112 /* we failed; croak if require() or return undef if do() */
4113 if (op_is_require) {
4114 if(saved_errno == EMFILE || saved_errno == EACCES) {
4115 /* diag_listed_as: Can't locate %s */
4116 DIE(aTHX_ "Can't locate %s: %s: %s",
4117 name, tryname, Strerror(saved_errno));
4119 if (path_searchable) { /* did we lookup @INC? */
4120 AV * const ar = GvAVn(PL_incgv);
4122 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4123 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4124 const char *e = name + len - 3; /* possible .pm */
4125 for (i = 0; i <= AvFILL(ar); i++) {
4126 sv_catpvs(inc, " ");
4127 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4129 if (e > name && _memEQs(e, ".pm")) {
4131 bool utf8 = cBOOL(SvUTF8(sv));
4133 /* if the filename, when converted from "Foo/Bar.pm"
4134 * form back to Foo::Bar form, makes a valid
4135 * package name (i.e. parseable by C<require
4136 * Foo::Bar>), then emit a hint.
4138 * this loop is modelled after the one in
4142 if (utf8 && isIDFIRST_utf8_safe(c, e)) {
4144 while (c < e && isIDCONT_utf8_safe(
4145 (const U8*) c, (const U8*) e))
4148 else if (isWORDCHAR_A(*c)) {
4149 while (c < e && isWORDCHAR_A(*c))
4158 if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
4159 sv_catpv(msg, " (you may need to install the ");
4160 for (c = name; c < e; c++) {
4162 sv_catpvs(msg, "::");
4165 sv_catpvn(msg, c, 1);
4168 sv_catpv(msg, " module)");
4171 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4172 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4174 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4175 sv_catpv(msg, " (did you run h2ph?)");
4178 /* diag_listed_as: Can't locate %s */
4180 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4184 DIE(aTHX_ "Can't locate %s", name);
4187 #ifdef DEFAULT_INC_EXCLUDES_DOT
4191 /* the complication is to match the logic from doopen_pm() so
4192 * we don't treat do "sda1" as a previously successful "do".
4194 bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED)
4195 && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode)
4196 && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL;
4202 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4203 "do \"%s\" failed, '.' is no longer in @INC; "
4204 "did you mean do \"./%s\"?",
4213 SETERRNO(0, SS_NORMAL);
4215 /* Update %INC. Assume success here to prevent recursive requirement. */
4216 /* name is never assigned to again, so len is still strlen(name) */
4217 /* Check whether a hook in @INC has already filled %INC */
4219 (void)hv_store(GvHVn(PL_incgv),
4220 unixname, unixlen, newSVpv(tryname,0),0);
4222 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4224 (void)hv_store(GvHVn(PL_incgv),
4225 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4228 /* Now parse the file */
4230 old_savestack_ix = PL_savestack_ix;
4231 SAVECOPFILE_FREE(&PL_compiling);
4232 CopFILE_set(&PL_compiling, tryname);
4233 lex_start(NULL, tryrsfp, 0);
4235 if (filter_sub || filter_cache) {
4236 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4237 than hanging another SV from it. In turn, filter_add() optionally
4238 takes the SV to use as the filter (or creates a new SV if passed
4239 NULL), so simply pass in whatever value filter_cache has. */
4240 SV * const fc = filter_cache ? newSV(0) : NULL;
4242 if (fc) sv_copypv(fc, filter_cache);
4243 datasv = filter_add(S_run_user_filter, fc);
4244 IoLINES(datasv) = filter_has_file;
4245 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4246 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4249 /* switch to eval mode */
4251 cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4252 cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4254 SAVECOPLINE(&PL_compiling);
4255 CopLINE_set(&PL_compiling, 0);
4259 if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4262 op = PL_op->op_next;
4264 PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4270 /* also used for: pp_dofile() */
4274 RUN_PP_CATCHABLY(Perl_pp_require);
4281 return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4282 ? S_require_version(aTHX_ sv)
4283 : S_require_file(aTHX_ sv);
4288 /* This is a op added to hold the hints hash for
4289 pp_entereval. The hash can be modified by the code
4290 being eval'ed, so we return a copy instead. */
4295 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4307 char tbuf[TYPE_DIGITS(long) + 12];
4315 I32 old_savestack_ix;
4317 RUN_PP_CATCHABLY(Perl_pp_entereval);
4320 was = PL_breakable_sub_gen;
4321 saved_delete = FALSE;
4325 bytes = PL_op->op_private & OPpEVAL_BYTES;
4327 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4328 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4330 else if (PL_hints & HINT_LOCALIZE_HH || (
4331 PL_op->op_private & OPpEVAL_COPHH
4332 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4334 saved_hh = cop_hints_2hv(PL_curcop, 0);
4335 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4339 /* make sure we've got a plain PV (no overload etc) before testing
4340 * for taint. Making a copy here is probably overkill, but better
4341 * safe than sorry */
4343 const char * const p = SvPV_const(sv, len);
4345 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4346 lex_flags |= LEX_START_COPIED;
4348 if (bytes && SvUTF8(sv))
4349 SvPVbyte_force(sv, len);
4351 else if (bytes && SvUTF8(sv)) {
4352 /* Don't modify someone else's scalar */
4355 (void)sv_2mortal(sv);
4356 SvPVbyte_force(sv,len);
4357 lex_flags |= LEX_START_COPIED;
4360 TAINT_IF(SvTAINTED(sv));
4361 TAINT_PROPER("eval");
4363 old_savestack_ix = PL_savestack_ix;
4365 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4366 ? LEX_IGNORE_UTF8_HINTS
4367 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4371 /* switch to eval mode */
4373 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4374 SV * const temp_sv = sv_newmortal();
4375 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]",
4376 (unsigned long)++PL_evalseq,
4377 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4378 tmpbuf = SvPVX(temp_sv);
4379 len = SvCUR(temp_sv);
4382 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4383 SAVECOPFILE_FREE(&PL_compiling);
4384 CopFILE_set(&PL_compiling, tmpbuf+2);
4385 SAVECOPLINE(&PL_compiling);
4386 CopLINE_set(&PL_compiling, 1);
4387 /* special case: an eval '' executed within the DB package gets lexically
4388 * placed in the first non-DB CV rather than the current CV - this
4389 * allows the debugger to execute code, find lexicals etc, in the
4390 * scope of the code being debugged. Passing &seq gets find_runcv
4391 * to do the dirty work for us */
4392 runcv = find_runcv(&seq);
4395 cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
4396 cx_pusheval(cx, PL_op->op_next, NULL);
4398 /* prepare to compile string */
4400 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4401 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4403 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4404 deleting the eval's FILEGV from the stash before gv_check() runs
4405 (i.e. before run-time proper). To work around the coredump that
4406 ensues, we always turn GvMULTI_on for any globals that were
4407 introduced within evals. See force_ident(). GSAR 96-10-12 */
4408 char *const safestr = savepvn(tmpbuf, len);
4409 SAVEDELETE(PL_defstash, safestr, len);
4410 saved_delete = TRUE;
4415 if (doeval_compile(gimme, runcv, seq, saved_hh)) {
4416 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4417 ? PERLDB_LINE_OR_SAVESRC
4418 : PERLDB_SAVESRC_NOSUBS) {
4419 /* Retain the filegv we created. */
4420 } else if (!saved_delete) {
4421 char *const safestr = savepvn(tmpbuf, len);
4422 SAVEDELETE(PL_defstash, safestr, len);
4424 return PL_eval_start;
4426 /* We have already left the scope set up earlier thanks to the LEAVE
4427 in doeval_compile(). */
4428 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4429 ? PERLDB_LINE_OR_SAVESRC
4430 : PERLDB_SAVESRC_INVALID) {
4431 /* Retain the filegv we created. */
4432 } else if (!saved_delete) {
4433 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4435 return PL_op->op_next;
4440 /* also tail-called by pp_return */
4455 assert(CxTYPE(cx) == CXt_EVAL);
4457 oldsp = PL_stack_base + cx->blk_oldsp;
4458 gimme = cx->blk_gimme;
4460 /* did require return a false value? */
4461 failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE
4462 && !(gimme == G_SCALAR
4463 ? SvTRUE(*PL_stack_sp)
4464 : PL_stack_sp > oldsp);
4466 if (gimme == G_VOID) {
4467 PL_stack_sp = oldsp;
4468 /* free now to avoid late-called destructors clobbering $@ */
4472 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4474 /* the cx_popeval does a leavescope, which frees the optree associated
4475 * with eval, which if it frees the nextstate associated with
4476 * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
4477 * regex when running under 'use re Debug' because it needs PL_curcop
4478 * to get the current hints. So restore it early.
4480 PL_curcop = cx->blk_oldcop;
4482 /* grab this value before cx_popeval restores the old PL_in_eval */
4483 keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4484 retop = cx->blk_eval.retop;
4485 evalcv = cx->blk_eval.cv;
4487 assert(CvDEPTH(evalcv) == 1);
4489 CvDEPTH(evalcv) = 0;
4491 /* pop the CXt_EVAL, and if a require failed, croak */
4492 S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
4500 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4501 close to the related Perl_create_eval_scope. */
4503 Perl_delete_eval_scope(pTHX)
4514 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4515 also needed by Perl_fold_constants. */
4517 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
4520 const U8 gimme = GIMME_V;
4522 cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
4523 PL_stack_sp, PL_savestack_ix);
4524 cx_pusheval(cx, retop, NULL);
4526 PL_in_eval = EVAL_INEVAL;
4527 if (flags & G_KEEPERR)
4528 PL_in_eval |= EVAL_KEEPERR;
4531 if (flags & G_FAKINGEVAL) {
4532 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4538 RUN_PP_CATCHABLY(Perl_pp_entertry);
4541 create_eval_scope(cLOGOP->op_other->op_next, 0);
4542 return PL_op->op_next;
4546 /* also tail-called by pp_return */
4558 assert(CxTYPE(cx) == CXt_EVAL);
4559 oldsp = PL_stack_base + cx->blk_oldsp;
4560 gimme = cx->blk_gimme;
4562 if (gimme == G_VOID) {
4563 PL_stack_sp = oldsp;
4564 /* free now to avoid late-called destructors clobbering $@ */
4568 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4572 retop = cx->blk_eval.retop;
4583 const U8 gimme = GIMME_V;
4587 assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4588 GvSV(PL_defgv) = SvREFCNT_inc(newsv);
4590 cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
4591 cx_pushgiven(cx, origsv);
4601 PERL_UNUSED_CONTEXT;
4604 assert(CxTYPE(cx) == CXt_GIVEN);
4605 oldsp = PL_stack_base + cx->blk_oldsp;
4606 gimme = cx->blk_gimme;
4608 if (gimme == G_VOID)
4609 PL_stack_sp = oldsp;
4611 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4621 /* Helper routines used by pp_smartmatch */
4623 S_make_matcher(pTHX_ REGEXP *re)
4625 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4627 PERL_ARGS_ASSERT_MAKE_MATCHER;
4629 PM_SETRE(matcher, ReREFCNT_inc(re));
4631 SAVEFREEOP((OP *) matcher);
4632 ENTER_with_name("matcher"); SAVETMPS;
4638 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4643 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4645 PL_op = (OP *) matcher;
4648 (void) Perl_pp_match(aTHX);
4650 result = SvTRUEx(POPs);
4657 S_destroy_matcher(pTHX_ PMOP *matcher)
4659 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4660 PERL_UNUSED_ARG(matcher);
4663 LEAVE_with_name("matcher");
4666 /* Do a smart match */
4669 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4670 return do_smartmatch(NULL, NULL, 0);
4673 /* This version of do_smartmatch() implements the
4674 * table of smart matches that is found in perlsyn.
4677 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4681 bool object_on_left = FALSE;
4682 SV *e = TOPs; /* e is for 'expression' */
4683 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4685 /* Take care only to invoke mg_get() once for each argument.
4686 * Currently we do this by copying the SV if it's magical. */
4688 if (!copied && SvGMAGICAL(d))
4689 d = sv_mortalcopy(d);
4696 e = sv_mortalcopy(e);
4698 /* First of all, handle overload magic of the rightmost argument */
4701 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4702 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4704 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4711 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4714 SP -= 2; /* Pop the values */
4719 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4726 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4727 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4728 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4730 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4731 object_on_left = TRUE;
4734 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4736 if (object_on_left) {
4737 goto sm_any_sub; /* Treat objects like scalars */
4739 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4740 /* Test sub truth for each key */
4742 bool andedresults = TRUE;
4743 HV *hv = (HV*) SvRV(d);
4744 I32 numkeys = hv_iterinit(hv);
4745 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4748 while ( (he = hv_iternext(hv)) ) {
4749 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4750 ENTER_with_name("smartmatch_hash_key_test");
4753 PUSHs(hv_iterkeysv(he));
4755 c = call_sv(e, G_SCALAR);
4758 andedresults = FALSE;
4760 andedresults = SvTRUEx(POPs) && andedresults;
4762 LEAVE_with_name("smartmatch_hash_key_test");
4769 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4770 /* Test sub truth for each element */
4772 bool andedresults = TRUE;
4773 AV *av = (AV*) SvRV(d);
4774 const I32 len = av_tindex(av);
4775 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4778 for (i = 0; i <= len; ++i) {
4779 SV * const * const svp = av_fetch(av, i, FALSE);
4780 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4781 ENTER_with_name("smartmatch_array_elem_test");
4787 c = call_sv(e, G_SCALAR);
4790 andedresults = FALSE;
4792 andedresults = SvTRUEx(POPs) && andedresults;
4794 LEAVE_with_name("smartmatch_array_elem_test");
4803 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4804 ENTER_with_name("smartmatch_coderef");
4809 c = call_sv(e, G_SCALAR);
4813 else if (SvTEMP(TOPs))
4814 SvREFCNT_inc_void(TOPs);
4816 LEAVE_with_name("smartmatch_coderef");
4821 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4822 if (object_on_left) {
4823 goto sm_any_hash; /* Treat objects like scalars */
4825 else if (!SvOK(d)) {
4826 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4829 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4830 /* Check that the key-sets are identical */
4832 HV *other_hv = MUTABLE_HV(SvRV(d));
4835 U32 this_key_count = 0,
4836 other_key_count = 0;
4837 HV *hv = MUTABLE_HV(SvRV(e));
4839 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4840 /* Tied hashes don't know how many keys they have. */
4841 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4842 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4846 HV * const temp = other_hv;
4852 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4856 /* The hashes have the same number of keys, so it suffices
4857 to check that one is a subset of the other. */
4858 (void) hv_iterinit(hv);
4859 while ( (he = hv_iternext(hv)) ) {
4860 SV *key = hv_iterkeysv(he);
4862 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4865 if(!hv_exists_ent(other_hv, key, 0)) {
4866 (void) hv_iterinit(hv); /* reset iterator */
4872 (void) hv_iterinit(other_hv);
4873 while ( hv_iternext(other_hv) )
4877 other_key_count = HvUSEDKEYS(other_hv);
4879 if (this_key_count != other_key_count)
4884 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4885 AV * const other_av = MUTABLE_AV(SvRV(d));
4886 const SSize_t other_len = av_tindex(other_av) + 1;
4888 HV *hv = MUTABLE_HV(SvRV(e));
4890 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4891 for (i = 0; i < other_len; ++i) {
4892 SV ** const svp = av_fetch(other_av, i, FALSE);
4893 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4894 if (svp) { /* ??? When can this not happen? */
4895 if (hv_exists_ent(hv, *svp, 0))
4901 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4902 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4905 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4907 HV *hv = MUTABLE_HV(SvRV(e));
4909 (void) hv_iterinit(hv);
4910 while ( (he = hv_iternext(hv)) ) {
4911 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4913 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4915 (void) hv_iterinit(hv);
4916 destroy_matcher(matcher);
4921 destroy_matcher(matcher);
4927 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4928 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4935 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4936 if (object_on_left) {
4937 goto sm_any_array; /* Treat objects like scalars */
4939 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4940 AV * const other_av = MUTABLE_AV(SvRV(e));
4941 const SSize_t other_len = av_tindex(other_av) + 1;
4944 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4945 for (i = 0; i < other_len; ++i) {
4946 SV ** const svp = av_fetch(other_av, i, FALSE);
4948 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4949 if (svp) { /* ??? When can this not happen? */
4950 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4956 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4957 AV *other_av = MUTABLE_AV(SvRV(d));
4958 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4959 if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4963 const SSize_t other_len = av_tindex(other_av);
4965 if (NULL == seen_this) {
4966 seen_this = newHV();
4967 (void) sv_2mortal(MUTABLE_SV(seen_this));
4969 if (NULL == seen_other) {
4970 seen_other = newHV();
4971 (void) sv_2mortal(MUTABLE_SV(seen_other));
4973 for(i = 0; i <= other_len; ++i) {
4974 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4975 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4977 if (!this_elem || !other_elem) {
4978 if ((this_elem && SvOK(*this_elem))
4979 || (other_elem && SvOK(*other_elem)))
4982 else if (hv_exists_ent(seen_this,
4983 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4984 hv_exists_ent(seen_other,
4985 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4987 if (*this_elem != *other_elem)
4991 (void)hv_store_ent(seen_this,
4992 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4994 (void)hv_store_ent(seen_other,
4995 sv_2mortal(newSViv(PTR2IV(*other_elem))),
5001 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
5002 (void) do_smartmatch(seen_this, seen_other, 0);
5004 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
5013 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
5014 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
5017 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
5018 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5021 for(i = 0; i <= this_len; ++i) {
5022 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5023 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
5025 if (svp && matcher_matches_sv(matcher, *svp)) {
5027 destroy_matcher(matcher);
5032 destroy_matcher(matcher);
5036 else if (!SvOK(d)) {
5037 /* undef ~~ array */
5038 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5041 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
5042 for (i = 0; i <= this_len; ++i) {
5043 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5044 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
5045 if (!svp || !SvOK(*svp))
5054 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5056 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
5057 for (i = 0; i <= this_len; ++i) {
5058 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5065 /* infinite recursion isn't supposed to happen here */
5066 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
5067 (void) do_smartmatch(NULL, NULL, 1);
5069 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
5078 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
5079 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5080 SV *t = d; d = e; e = t;
5081 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
5084 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5085 SV *t = d; d = e; e = t;
5086 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
5087 goto sm_regex_array;
5090 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
5093 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
5095 result = matcher_matches_sv(matcher, d);
5097 PUSHs(result ? &PL_sv_yes : &PL_sv_no);
5098 destroy_matcher(matcher);
5103 /* See if there is overload magic on left */
5104 else if (object_on_left && SvAMAGIC(d)) {
5106 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
5107 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
5110 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
5118 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
5121 else if (!SvOK(d)) {
5122 /* undef ~~ scalar ; we already know that the scalar is SvOK */
5123 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
5128 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
5129 DEBUG_M(if (SvNIOK(e))
5130 Perl_deb(aTHX_ " applying rule Any-Num\n");
5132 Perl_deb(aTHX_ " applying rule Num-numish\n");
5134 /* numeric comparison */
5137 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
5138 (void) Perl_pp_i_eq(aTHX);
5140 (void) Perl_pp_eq(aTHX);
5148 /* As a last resort, use string comparison */
5149 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
5152 return Perl_pp_seq(aTHX);
5159 const U8 gimme = GIMME_V;
5161 /* This is essentially an optimization: if the match
5162 fails, we don't want to push a context and then
5163 pop it again right away, so we skip straight
5164 to the op that follows the leavewhen.
5165 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5167 if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs))
5168 RETURNOP(cLOGOP->op_other->op_next);
5170 cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
5184 assert(CxTYPE(cx) == CXt_WHEN);
5185 gimme = cx->blk_gimme;
5187 cxix = dopoptogivenfor(cxstack_ix);
5189 /* diag_listed_as: Can't "when" outside a topicalizer */
5190 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5191 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5193 oldsp = PL_stack_base + cx->blk_oldsp;
5194 if (gimme == G_VOID)
5195 PL_stack_sp = oldsp;
5197 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5199 /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
5200 assert(cxix < cxstack_ix);
5203 cx = &cxstack[cxix];
5205 if (CxFOREACH(cx)) {
5206 /* emulate pp_next. Note that any stack(s) cleanup will be
5207 * done by the pp_unstack which op_nextop should point to */
5210 PL_curcop = cx->blk_oldcop;
5211 return cx->blk_loop.my_op->op_nextop;
5215 assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
5216 return cx->blk_givwhen.leave_op;
5226 cxix = dopoptowhen(cxstack_ix);
5228 DIE(aTHX_ "Can't \"continue\" outside a when block");
5230 if (cxix < cxstack_ix)
5234 assert(CxTYPE(cx) == CXt_WHEN);
5235 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5239 nextop = cx->blk_givwhen.leave_op->op_next;
5250 cxix = dopoptogivenfor(cxstack_ix);
5252 DIE(aTHX_ "Can't \"break\" outside a given block");
5254 cx = &cxstack[cxix];
5256 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5258 if (cxix < cxstack_ix)
5261 /* Restore the sp at the time we entered the given block */
5263 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5265 return cx->blk_givwhen.leave_op;
5269 S_doparseform(pTHX_ SV *sv)
5272 char *s = SvPV(sv, len);
5274 char *base = NULL; /* start of current field */
5275 I32 skipspaces = 0; /* number of contiguous spaces seen */
5276 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5277 bool repeat = FALSE; /* ~~ seen on this line */
5278 bool postspace = FALSE; /* a text field may need right padding */
5281 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5283 bool ischop; /* it's a ^ rather than a @ */
5284 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5285 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5289 PERL_ARGS_ASSERT_DOPARSEFORM;
5292 Perl_croak(aTHX_ "Null picture in formline");
5294 if (SvTYPE(sv) >= SVt_PVMG) {
5295 /* This might, of course, still return NULL. */
5296 mg = mg_find(sv, PERL_MAGIC_fm);
5298 sv_upgrade(sv, SVt_PVMG);
5302 /* still the same as previously-compiled string? */
5303 SV *old = mg->mg_obj;
5304 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5305 && len == SvCUR(old)
5306 && strnEQ(SvPVX(old), s, len)
5308 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5312 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5313 Safefree(mg->mg_ptr);
5319 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5320 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5323 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5324 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5328 /* estimate the buffer size needed */
5329 for (base = s; s <= send; s++) {
5330 if (*s == '\n' || *s == '@' || *s == '^')
5336 Newx(fops, maxops, U32);
5341 *fpc++ = FF_LINEMARK;
5342 noblank = repeat = FALSE;
5360 case ' ': case '\t':
5367 } /* else FALL THROUGH */
5375 *fpc++ = FF_LITERAL;
5383 *fpc++ = (U32)skipspaces;
5387 *fpc++ = FF_NEWLINE;
5391 arg = fpc - linepc + 1;
5398 *fpc++ = FF_LINEMARK;
5399 noblank = repeat = FALSE;
5408 ischop = s[-1] == '^';
5414 arg = (s - base) - 1;
5416 *fpc++ = FF_LITERAL;
5422 if (*s == '*') { /* @* or ^* */
5424 *fpc++ = 2; /* skip the @* or ^* */
5426 *fpc++ = FF_LINESNGL;
5429 *fpc++ = FF_LINEGLOB;
5431 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5432 arg = ischop ? FORM_NUM_BLANK : 0;
5437 const char * const f = ++s;
5440 arg |= FORM_NUM_POINT + (s - f);
5442 *fpc++ = s - base; /* fieldsize for FETCH */
5443 *fpc++ = FF_DECIMAL;
5445 unchopnum |= ! ischop;
5447 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5448 arg = ischop ? FORM_NUM_BLANK : 0;
5450 s++; /* skip the '0' first */
5454 const char * const f = ++s;
5457 arg |= FORM_NUM_POINT + (s - f);
5459 *fpc++ = s - base; /* fieldsize for FETCH */
5460 *fpc++ = FF_0DECIMAL;
5462 unchopnum |= ! ischop;
5464 else { /* text field */
5466 bool ismore = FALSE;
5469 while (*++s == '>') ;
5470 prespace = FF_SPACE;
5472 else if (*s == '|') {
5473 while (*++s == '|') ;
5474 prespace = FF_HALFSPACE;
5479 while (*++s == '<') ;
5482 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5486 *fpc++ = s - base; /* fieldsize for FETCH */
5488 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5491 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5505 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5508 mg->mg_ptr = (char *) fops;
5509 mg->mg_len = arg * sizeof(U32);
5510 mg->mg_obj = sv_copy;
5511 mg->mg_flags |= MGf_REFCOUNTED;
5513 if (unchopnum && repeat)
5514 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5521 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5523 /* Can value be printed in fldsize chars, using %*.*f ? */
5527 int intsize = fldsize - (value < 0 ? 1 : 0);
5529 if (frcsize & FORM_NUM_POINT)
5531 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5534 while (intsize--) pwr *= 10.0;
5535 while (frcsize--) eps /= 10.0;
5538 if (value + eps >= pwr)
5541 if (value - eps <= -pwr)
5548 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5550 SV * const datasv = FILTER_DATA(idx);
5551 const int filter_has_file = IoLINES(datasv);
5552 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5553 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5558 char *prune_from = NULL;
5559 bool read_from_cache = FALSE;
5563 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5565 assert(maxlen >= 0);
5568 /* I was having segfault trouble under Linux 2.2.5 after a
5569 parse error occurred. (Had to hack around it with a test
5570 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5571 not sure where the trouble is yet. XXX */
5574 SV *const cache = datasv;
5577 const char *cache_p = SvPV(cache, cache_len);
5581 /* Running in block mode and we have some cached data already.
5583 if (cache_len >= umaxlen) {
5584 /* In fact, so much data we don't even need to call
5589 const char *const first_nl =
5590 (const char *)memchr(cache_p, '\n', cache_len);
5592 take = first_nl + 1 - cache_p;
5596 sv_catpvn(buf_sv, cache_p, take);
5597 sv_chop(cache, cache_p + take);
5598 /* Definitely not EOF */
5602 sv_catsv(buf_sv, cache);
5604 umaxlen -= cache_len;
5607 read_from_cache = TRUE;
5611 /* Filter API says that the filter appends to the contents of the buffer.
5612 Usually the buffer is "", so the details don't matter. But if it's not,
5613 then clearly what it contains is already filtered by this filter, so we
5614 don't want to pass it in a second time.
5615 I'm going to use a mortal in case the upstream filter croaks. */
5616 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5617 ? sv_newmortal() : buf_sv;
5618 SvUPGRADE(upstream, SVt_PV);
5620 if (filter_has_file) {
5621 status = FILTER_READ(idx+1, upstream, 0);
5624 if (filter_sub && status >= 0) {
5628 ENTER_with_name("call_filter_sub");
5633 DEFSV_set(upstream);
5637 PUSHs(filter_state);
5640 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5650 SV * const errsv = ERRSV;
5651 if (SvTRUE_NN(errsv))
5652 err = newSVsv(errsv);
5658 LEAVE_with_name("call_filter_sub");
5661 if (SvGMAGICAL(upstream)) {
5663 if (upstream == buf_sv) mg_free(buf_sv);
5665 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5666 if(!err && SvOK(upstream)) {
5667 got_p = SvPV_nomg(upstream, got_len);
5669 if (got_len > umaxlen) {
5670 prune_from = got_p + umaxlen;
5673 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5674 if (first_nl && first_nl + 1 < got_p + got_len) {
5675 /* There's a second line here... */
5676 prune_from = first_nl + 1;
5680 if (!err && prune_from) {
5681 /* Oh. Too long. Stuff some in our cache. */
5682 STRLEN cached_len = got_p + got_len - prune_from;
5683 SV *const cache = datasv;
5686 /* Cache should be empty. */
5687 assert(!SvCUR(cache));
5690 sv_setpvn(cache, prune_from, cached_len);
5691 /* If you ask for block mode, you may well split UTF-8 characters.
5692 "If it breaks, you get to keep both parts"
5693 (Your code is broken if you don't put them back together again
5694 before something notices.) */
5695 if (SvUTF8(upstream)) {
5698 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5700 /* Cannot just use sv_setpvn, as that could free the buffer
5701 before we have a chance to assign it. */
5702 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5703 got_len - cached_len);
5705 /* Can't yet be EOF */
5710 /* If they are at EOF but buf_sv has something in it, then they may never
5711 have touched the SV upstream, so it may be undefined. If we naively
5712 concatenate it then we get a warning about use of uninitialised value.
5714 if (!err && upstream != buf_sv &&
5716 sv_catsv_nomg(buf_sv, upstream);
5718 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5721 IoLINES(datasv) = 0;
5723 SvREFCNT_dec(filter_state);
5724 IoTOP_GV(datasv) = NULL;
5727 SvREFCNT_dec(filter_sub);
5728 IoBOTTOM_GV(datasv) = NULL;
5730 filter_del(S_run_user_filter);
5736 if (status == 0 && read_from_cache) {
5737 /* If we read some data from the cache (and by getting here it implies
5738 that we emptied the cache) then we aren't yet at EOF, and mustn't
5739 report that to our caller. */
5746 * ex: set ts=8 sts=4 sw=4 et: