3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
37 #define RUN_PP_CATCHABLY(thispp) \
38 STMT_START { if (CATCH_GET) return docatch(thispp); } STMT_END
40 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
46 const PERL_CONTEXT *cx;
49 if (PL_op->op_private & OPpOFFBYONE) {
50 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
53 cxix = dopoptosub(cxstack_ix);
59 switch (cx->blk_gimme) {
78 PMOP *pm = (PMOP*)cLOGOP->op_other;
83 const regexp_engine *eng;
84 bool is_bare_re= FALSE;
86 if (PL_op->op_flags & OPf_STACKED) {
96 /* prevent recompiling under /o and ithreads. */
97 #if defined(USE_ITHREADS)
98 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
105 assert (re != (REGEXP*) &PL_sv_undef);
106 eng = re ? RX_ENGINE(re) : current_re_engine();
108 new_re = (eng->op_comp
110 : &Perl_re_op_compile
111 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
113 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
115 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
117 if (pm->op_pmflags & PMf_HAS_CV)
118 ReANY(new_re)->qr_anoncv
119 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
123 /* The match's LHS's get-magic might need to access this op's regexp
124 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
125 get-magic now before we replace the regexp. Hopefully this hack can
126 be replaced with the approach described at
127 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
129 if (pm->op_type == OP_MATCH) {
131 const bool was_tainted = TAINT_get;
132 if (pm->op_flags & OPf_STACKED)
134 else if (pm->op_targ)
135 lhs = PAD_SV(pm->op_targ);
138 /* Restore the previous value of PL_tainted (which may have been
139 modified by get-magic), to avoid incorrectly setting the
140 RXf_TAINTED flag with RX_TAINT_on further down. */
141 TAINT_set(was_tainted);
142 #ifdef NO_TAINT_SUPPORT
143 PERL_UNUSED_VAR(was_tainted);
146 tmp = reg_temp_copy(NULL, new_re);
147 ReREFCNT_dec(new_re);
153 PM_SETRE(pm, new_re);
157 assert(TAINTING_get || !TAINT_get);
159 SvTAINTED_on((SV*)new_re);
163 /* handle the empty pattern */
164 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) {
165 if (PL_curpm == PL_reg_curpm) {
166 if (PL_curpm_under && PL_curpm_under == PL_reg_curpm) {
167 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
172 #if !defined(USE_ITHREADS)
173 /* can't change the optree at runtime either */
174 /* PMf_KEEP is handled differently under threads to avoid these problems */
175 if (pm->op_pmflags & PMf_KEEP) {
176 cLOGOP->op_first->op_next = PL_op->op_next;
188 PERL_CONTEXT *cx = CX_CUR();
189 PMOP * const pm = (PMOP*) cLOGOP->op_other;
190 SV * const dstr = cx->sb_dstr;
193 char *orig = cx->sb_orig;
194 REGEXP * const rx = cx->sb_rx;
196 REGEXP *old = PM_GETRE(pm);
203 PM_SETRE(pm,ReREFCNT_inc(rx));
206 rxres_restore(&cx->sb_rxres, rx);
208 if (cx->sb_iters++) {
209 const SSize_t saviters = cx->sb_iters;
210 if (cx->sb_iters > cx->sb_maxiters)
211 DIE(aTHX_ "Substitution loop");
213 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
215 /* See "how taint works" above pp_subst() */
216 sv_catsv_nomg(dstr, POPs);
217 if (UNLIKELY(TAINT_get))
218 cx->sb_rxtainted |= SUBST_TAINT_REPL;
219 if (CxONCE(cx) || s < orig ||
220 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
221 (s == m), cx->sb_targ, NULL,
222 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
224 SV *targ = cx->sb_targ;
226 assert(cx->sb_strend >= s);
227 if(cx->sb_strend > s) {
228 if (DO_UTF8(dstr) && !SvUTF8(targ))
229 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
231 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
233 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
234 cx->sb_rxtainted |= SUBST_TAINT_PAT;
236 if (pm->op_pmflags & PMf_NONDESTRUCT) {
238 /* From here on down we're using the copy, and leaving the
239 original untouched. */
243 SV_CHECK_THINKFIRST_COW_DROP(targ);
244 if (isGV(targ)) Perl_croak_no_modify();
246 SvPV_set(targ, SvPVX(dstr));
247 SvCUR_set(targ, SvCUR(dstr));
248 SvLEN_set(targ, SvLEN(dstr));
251 SvPV_set(dstr, NULL);
254 mPUSHi(saviters - 1);
256 (void)SvPOK_only_UTF8(targ);
259 /* update the taint state of various various variables in
260 * preparation for final exit.
261 * See "how taint works" above pp_subst() */
263 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
264 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
265 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
267 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
269 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
270 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
272 SvTAINTED_on(TOPs); /* taint return value */
273 /* needed for mg_set below */
275 cBOOL(cx->sb_rxtainted &
276 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
280 /* PL_tainted must be correctly set for this mg_set */
289 RETURNOP(pm->op_next);
290 NOT_REACHED; /* NOTREACHED */
292 cx->sb_iters = saviters;
294 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
297 assert(!RX_SUBOFFSET(rx));
298 cx->sb_orig = orig = RX_SUBBEG(rx);
300 cx->sb_strend = s + (cx->sb_strend - m);
302 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
304 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
305 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
307 sv_catpvn_nomg(dstr, s, m-s);
309 cx->sb_s = RX_OFFS(rx)[0].end + orig;
310 { /* Update the pos() information. */
312 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
315 /* the string being matched against may no longer be a string,
316 * e.g. $_=0; s/.../$_++/ge */
319 SvPV_force_nomg_nolen(sv);
321 if (!(mg = mg_find_mglob(sv))) {
322 mg = sv_magicext_mglob(sv);
324 MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
327 (void)ReREFCNT_inc(rx);
328 /* update the taint state of various various variables in preparation
329 * for calling the code block.
330 * See "how taint works" above pp_subst() */
332 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
333 cx->sb_rxtainted |= SUBST_TAINT_PAT;
335 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
336 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
337 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
339 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
341 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
342 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
343 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
344 ? cx->sb_dstr : cx->sb_targ);
347 rxres_save(&cx->sb_rxres, rx);
349 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
353 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
358 PERL_ARGS_ASSERT_RXRES_SAVE;
361 if (!p || p[1] < RX_NPARENS(rx)) {
363 i = 7 + (RX_NPARENS(rx)+1) * 2;
365 i = 6 + (RX_NPARENS(rx)+1) * 2;
374 /* what (if anything) to free on croak */
375 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
376 RX_MATCH_COPIED_off(rx);
377 *p++ = RX_NPARENS(rx);
380 *p++ = PTR2UV(RX_SAVED_COPY(rx));
381 RX_SAVED_COPY(rx) = NULL;
384 *p++ = PTR2UV(RX_SUBBEG(rx));
385 *p++ = (UV)RX_SUBLEN(rx);
386 *p++ = (UV)RX_SUBOFFSET(rx);
387 *p++ = (UV)RX_SUBCOFFSET(rx);
388 for (i = 0; i <= RX_NPARENS(rx); ++i) {
389 *p++ = (UV)RX_OFFS(rx)[i].start;
390 *p++ = (UV)RX_OFFS(rx)[i].end;
395 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
400 PERL_ARGS_ASSERT_RXRES_RESTORE;
403 RX_MATCH_COPY_FREE(rx);
404 RX_MATCH_COPIED_set(rx, *p);
406 RX_NPARENS(rx) = *p++;
409 if (RX_SAVED_COPY(rx))
410 SvREFCNT_dec (RX_SAVED_COPY(rx));
411 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
415 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
416 RX_SUBLEN(rx) = (I32)(*p++);
417 RX_SUBOFFSET(rx) = (I32)*p++;
418 RX_SUBCOFFSET(rx) = (I32)*p++;
419 for (i = 0; i <= RX_NPARENS(rx); ++i) {
420 RX_OFFS(rx)[i].start = (I32)(*p++);
421 RX_OFFS(rx)[i].end = (I32)(*p++);
426 S_rxres_free(pTHX_ void **rsp)
428 UV * const p = (UV*)*rsp;
430 PERL_ARGS_ASSERT_RXRES_FREE;
434 void *tmp = INT2PTR(char*,*p);
437 U32 i = 9 + p[1] * 2;
439 U32 i = 8 + p[1] * 2;
444 SvREFCNT_dec (INT2PTR(SV*,p[2]));
447 PoisonFree(p, i, sizeof(UV));
456 #define FORM_NUM_BLANK (1<<30)
457 #define FORM_NUM_POINT (1<<29)
461 dSP; dMARK; dORIGMARK;
462 SV * const tmpForm = *++MARK;
463 SV *formsv; /* contains text of original format */
464 U32 *fpc; /* format ops program counter */
465 char *t; /* current append position in target string */
466 const char *f; /* current position in format string */
468 SV *sv = NULL; /* current item */
469 const char *item = NULL;/* string value of current item */
470 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
471 I32 itembytes = 0; /* as itemsize, but length in bytes */
472 I32 fieldsize = 0; /* width of current field */
473 I32 lines = 0; /* number of lines that have been output */
474 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
475 const char *chophere = NULL; /* where to chop current item */
476 STRLEN linemark = 0; /* pos of start of line in output */
478 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
479 STRLEN len; /* length of current sv */
480 STRLEN linemax; /* estimate of output size in bytes */
481 bool item_is_utf8 = FALSE;
482 bool targ_is_utf8 = FALSE;
485 U8 *source; /* source of bytes to append */
486 STRLEN to_copy; /* how may bytes to append */
487 char trans; /* what chars to translate */
488 bool copied_form = FALSE; /* have we duplicated the form? */
490 mg = doparseform(tmpForm);
492 fpc = (U32*)mg->mg_ptr;
493 /* the actual string the format was compiled from.
494 * with overload etc, this may not match tmpForm */
498 SvPV_force(PL_formtarget, len);
499 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
500 SvTAINTED_on(PL_formtarget);
501 if (DO_UTF8(PL_formtarget))
503 /* this is an initial estimate of how much output buffer space
504 * to allocate. It may be exceeded later */
505 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
506 t = SvGROW(PL_formtarget, len + linemax + 1);
507 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
509 f = SvPV_const(formsv, len);
513 const char *name = "???";
516 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
517 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
518 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
519 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
520 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
522 case FF_CHECKNL: name = "CHECKNL"; break;
523 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
524 case FF_SPACE: name = "SPACE"; break;
525 case FF_HALFSPACE: name = "HALFSPACE"; break;
526 case FF_ITEM: name = "ITEM"; break;
527 case FF_CHOP: name = "CHOP"; break;
528 case FF_LINEGLOB: name = "LINEGLOB"; break;
529 case FF_NEWLINE: name = "NEWLINE"; break;
530 case FF_MORE: name = "MORE"; break;
531 case FF_LINEMARK: name = "LINEMARK"; break;
532 case FF_END: name = "END"; break;
533 case FF_0DECIMAL: name = "0DECIMAL"; break;
534 case FF_LINESNGL: name = "LINESNGL"; break;
537 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
539 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
542 case FF_LINEMARK: /* start (or end) of a line */
543 linemark = t - SvPVX(PL_formtarget);
548 case FF_LITERAL: /* append <arg> literal chars */
553 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
556 case FF_SKIP: /* skip <arg> chars in format */
560 case FF_FETCH: /* get next item and set field size to <arg> */
569 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
572 SvTAINTED_on(PL_formtarget);
575 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
577 const char *s = item = SvPV_const(sv, len);
578 const char *send = s + len;
581 item_is_utf8 = DO_UTF8(sv);
593 if (itemsize == fieldsize)
596 itembytes = s - item;
601 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
603 const char *s = item = SvPV_const(sv, len);
604 const char *send = s + len;
608 item_is_utf8 = DO_UTF8(sv);
610 /* look for a legal split position */
618 /* provisional split point */
622 /* we delay testing fieldsize until after we've
623 * processed the possible split char directly
624 * following the last field char; so if fieldsize=3
625 * and item="a b cdef", we consume "a b", not "a".
626 * Ditto further down.
628 if (size == fieldsize)
632 if (strchr(PL_chopset, *s)) {
633 /* provisional split point */
634 /* for a non-space split char, we include
635 * the split char; hence the '+1' */
639 if (size == fieldsize)
651 if (!chophere || s == send) {
655 itembytes = chophere - item;
660 case FF_SPACE: /* append padding space (diff of field, item size) */
661 arg = fieldsize - itemsize;
669 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
670 arg = fieldsize - itemsize;
679 case FF_ITEM: /* append a text item, while blanking ctrl chars */
685 case FF_CHOP: /* (for ^*) chop the current item */
686 if (sv != &PL_sv_no) {
687 const char *s = chophere;
689 ((sv == tmpForm || SvSMAGICAL(sv))
690 || (SvGMAGICAL(tmpForm) && !sv_only_taint_gmagic(tmpForm))) ) {
691 /* sv and tmpForm are either the same SV, or magic might allow modification
692 of tmpForm when sv is modified, so copy */
693 SV *newformsv = sv_mortalcopy(formsv);
696 f = SvPV_nolen(newformsv) + (f - SvPV_nolen(formsv));
697 Newx(new_compiled, mg->mg_len / sizeof(U32), U32);
698 memcpy(new_compiled, mg->mg_ptr, mg->mg_len);
699 SAVEFREEPV(new_compiled);
700 fpc = new_compiled + (fpc - (U32*)mg->mg_ptr);
712 /* tied, overloaded or similar strangeness.
713 * Do it the hard way */
714 sv_setpvn(sv, s, len - (s-item));
720 case FF_LINESNGL: /* process ^* */
724 case FF_LINEGLOB: /* process @* */
726 const bool oneline = fpc[-1] == FF_LINESNGL;
727 const char *s = item = SvPV_const(sv, len);
728 const char *const send = s + len;
730 item_is_utf8 = DO_UTF8(sv);
741 to_copy = s - item - 1;
755 /* append to_copy bytes from source to PL_formstring.
756 * item_is_utf8 implies source is utf8.
757 * if trans, translate certain characters during the copy */
762 SvCUR_set(PL_formtarget,
763 t - SvPVX_const(PL_formtarget));
765 if (targ_is_utf8 && !item_is_utf8) {
766 source = tmp = bytes_to_utf8(source, &to_copy);
769 if (item_is_utf8 && !targ_is_utf8) {
771 /* Upgrade targ to UTF8, and then we reduce it to
772 a problem we have a simple solution for.
773 Don't need get magic. */
774 sv_utf8_upgrade_nomg(PL_formtarget);
776 /* re-calculate linemark */
777 s = (U8*)SvPVX(PL_formtarget);
778 /* the bytes we initially allocated to append the
779 * whole line may have been gobbled up during the
780 * upgrade, so allocate a whole new line's worth
785 linemark = s - (U8*)SvPVX(PL_formtarget);
787 /* Easy. They agree. */
788 assert (item_is_utf8 == targ_is_utf8);
791 /* @* and ^* are the only things that can exceed
792 * the linemax, so grow by the output size, plus
793 * a whole new form's worth in case of any further
795 grow = linemax + to_copy;
797 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
798 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
800 Copy(source, t, to_copy, char);
802 /* blank out ~ or control chars, depending on trans.
803 * works on bytes not chars, so relies on not
804 * matching utf8 continuation bytes */
806 U8 *send = s + to_copy;
809 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
816 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
822 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
825 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
828 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
831 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
833 /* If the field is marked with ^ and the value is undefined,
835 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
843 /* overflow evidence */
844 if (num_overflow(value, fieldsize, arg)) {
850 /* Formats aren't yet marked for locales, so assume "yes". */
852 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
854 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
855 STORE_LC_NUMERIC_SET_TO_NEEDED();
856 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
859 const char* qfmt = quadmath_format_single(fmt);
862 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
863 len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
865 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
870 /* we generate fmt ourselves so it is safe */
871 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
872 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
873 GCC_DIAG_RESTORE_STMT;
875 PERL_MY_SNPRINTF_POST_GUARD(len, max);
876 RESTORE_LC_NUMERIC();
881 case FF_NEWLINE: /* delete trailing spaces, then append \n */
883 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
888 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
891 if (arg) { /* repeat until fields exhausted? */
897 t = SvPVX(PL_formtarget) + linemark;
902 case FF_MORE: /* replace long end of string with '...' */
904 const char *s = chophere;
905 const char *send = item + len;
907 while (isSPACE(*s) && (s < send))
912 arg = fieldsize - itemsize;
919 if (strBEGINs(s1," ")) {
920 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
930 case FF_END: /* tidy up, then return */
932 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
934 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
936 SvUTF8_on(PL_formtarget);
937 FmLINES(PL_formtarget) += lines;
939 if (fpc[-1] == FF_BLANK)
940 RETURNOP(cLISTOP->op_first);
947 /* also used for: pp_mapstart() */
953 if (PL_stack_base + TOPMARK == SP) {
955 if (GIMME_V == G_SCALAR)
957 RETURNOP(PL_op->op_next->op_next);
959 PL_stack_sp = PL_stack_base + TOPMARK + 1;
960 Perl_pp_pushmark(aTHX); /* push dst */
961 Perl_pp_pushmark(aTHX); /* push src */
962 ENTER_with_name("grep"); /* enter outer scope */
966 ENTER_with_name("grep_item"); /* enter inner scope */
969 src = PL_stack_base[TOPMARK];
971 src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
978 if (PL_op->op_type == OP_MAPSTART)
979 Perl_pp_pushmark(aTHX); /* push top */
980 return ((LOGOP*)PL_op->op_next)->op_other;
986 const U8 gimme = GIMME_V;
987 I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
993 /* first, move source pointer to the next item in the source list */
994 ++PL_markstack_ptr[-1];
996 /* if there are new items, push them into the destination list */
997 if (items && gimme != G_VOID) {
998 /* might need to make room back there first */
999 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1000 /* XXX this implementation is very pessimal because the stack
1001 * is repeatedly extended for every set of items. Is possible
1002 * to do this without any stack extension or copying at all
1003 * by maintaining a separate list over which the map iterates
1004 * (like foreach does). --gsar */
1006 /* everything in the stack after the destination list moves
1007 * towards the end the stack by the amount of room needed */
1008 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1010 /* items to shift up (accounting for the moved source pointer) */
1011 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1013 /* This optimization is by Ben Tilly and it does
1014 * things differently from what Sarathy (gsar)
1015 * is describing. The downside of this optimization is
1016 * that leaves "holes" (uninitialized and hopefully unused areas)
1017 * to the Perl stack, but on the other hand this
1018 * shouldn't be a problem. If Sarathy's idea gets
1019 * implemented, this optimization should become
1020 * irrelevant. --jhi */
1022 shift = count; /* Avoid shifting too often --Ben Tilly */
1026 dst = (SP += shift);
1027 PL_markstack_ptr[-1] += shift;
1028 *PL_markstack_ptr += shift;
1032 /* copy the new items down to the destination list */
1033 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1034 if (gimme == G_ARRAY) {
1035 /* add returned items to the collection (making mortal copies
1036 * if necessary), then clear the current temps stack frame
1037 * *except* for those items. We do this splicing the items
1038 * into the start of the tmps frame (so some items may be on
1039 * the tmps stack twice), then moving PL_tmps_floor above
1040 * them, then freeing the frame. That way, the only tmps that
1041 * accumulate over iterations are the return values for map.
1042 * We have to do to this way so that everything gets correctly
1043 * freed if we die during the map.
1047 /* make space for the slice */
1048 EXTEND_MORTAL(items);
1049 tmpsbase = PL_tmps_floor + 1;
1050 Move(PL_tmps_stack + tmpsbase,
1051 PL_tmps_stack + tmpsbase + items,
1052 PL_tmps_ix - PL_tmps_floor,
1054 PL_tmps_ix += items;
1059 sv = sv_mortalcopy(sv);
1061 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1063 /* clear the stack frame except for the items */
1064 PL_tmps_floor += items;
1066 /* FREETMPS may have cleared the TEMP flag on some of the items */
1069 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1072 /* scalar context: we don't care about which values map returns
1073 * (we use undef here). And so we certainly don't want to do mortal
1074 * copies of meaningless values. */
1075 while (items-- > 0) {
1077 *dst-- = &PL_sv_undef;
1085 LEAVE_with_name("grep_item"); /* exit inner scope */
1088 if (PL_markstack_ptr[-1] > TOPMARK) {
1090 (void)POPMARK; /* pop top */
1091 LEAVE_with_name("grep"); /* exit outer scope */
1092 (void)POPMARK; /* pop src */
1093 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1094 (void)POPMARK; /* pop dst */
1095 SP = PL_stack_base + POPMARK; /* pop original mark */
1096 if (gimme == G_SCALAR) {
1100 else if (gimme == G_ARRAY)
1107 ENTER_with_name("grep_item"); /* enter inner scope */
1110 /* set $_ to the new source item */
1111 src = PL_stack_base[PL_markstack_ptr[-1]];
1112 if (SvPADTMP(src)) {
1113 src = sv_mortalcopy(src);
1118 RETURNOP(cLOGOP->op_other);
1127 if (GIMME_V == G_ARRAY)
1130 if (SvTRUE_NN(targ))
1131 return cLOGOP->op_other;
1140 if (GIMME_V == G_ARRAY) {
1141 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1145 SV * const targ = PAD_SV(PL_op->op_targ);
1148 if (PL_op->op_private & OPpFLIP_LINENUM) {
1149 if (GvIO(PL_last_in_gv)) {
1150 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1153 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1155 flip = SvIV(sv) == SvIV(GvSV(gv));
1158 flip = SvTRUE_NN(sv);
1161 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1162 if (PL_op->op_flags & OPf_SPECIAL) {
1170 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1179 /* This code tries to decide if "$left .. $right" should use the
1180 magical string increment, or if the range is numeric (we make
1181 an exception for .."0" [#18165]). AMS 20021031. */
1183 #define RANGE_IS_NUMERIC(left,right) ( \
1184 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1185 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1186 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1187 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1188 && (!SvOK(right) || looks_like_number(right))))
1194 if (GIMME_V == G_ARRAY) {
1200 if (RANGE_IS_NUMERIC(left,right)) {
1202 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1203 (SvOK(right) && (SvIOK(right)
1204 ? SvIsUV(right) && SvUV(right) > IV_MAX
1205 : SvNV_nomg(right) > IV_MAX)))
1206 DIE(aTHX_ "Range iterator outside integer range");
1207 i = SvIV_nomg(left);
1208 j = SvIV_nomg(right);
1210 /* Dance carefully around signed max. */
1211 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1214 /* The wraparound of signed integers is undefined
1215 * behavior, but here we aim for count >=1, and
1216 * negative count is just wrong. */
1218 #if IVSIZE > Size_t_size
1225 Perl_croak(aTHX_ "Out of memory during list extend");
1232 SV * const sv = sv_2mortal(newSViv(i));
1234 if (n) /* avoid incrementing above IV_MAX */
1240 const char * const lpv = SvPV_nomg_const(left, llen);
1241 const char * const tmps = SvPV_nomg_const(right, len);
1243 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1244 if (DO_UTF8(right) && IN_UNI_8_BIT)
1245 len = sv_len_utf8_nomg(right);
1246 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1248 if (strEQ(SvPVX_const(sv),tmps))
1250 sv = sv_2mortal(newSVsv(sv));
1257 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1261 if (PL_op->op_private & OPpFLIP_LINENUM) {
1262 if (GvIO(PL_last_in_gv)) {
1263 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1266 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1267 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1271 flop = SvTRUE_NN(sv);
1275 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1276 sv_catpvs(targ, "E0");
1286 static const char * const context_name[] = {
1288 NULL, /* CXt_WHEN never actually needs "block" */
1289 NULL, /* CXt_BLOCK never actually needs "block" */
1290 NULL, /* CXt_GIVEN never actually needs "block" */
1291 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1292 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1293 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1294 NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1295 NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1303 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1307 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1309 for (i = cxstack_ix; i >= 0; i--) {
1310 const PERL_CONTEXT * const cx = &cxstack[i];
1311 switch (CxTYPE(cx)) {
1317 /* diag_listed_as: Exiting subroutine via %s */
1318 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1319 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1320 if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1323 case CXt_LOOP_PLAIN:
1324 case CXt_LOOP_LAZYIV:
1325 case CXt_LOOP_LAZYSV:
1329 STRLEN cx_label_len = 0;
1330 U32 cx_label_flags = 0;
1331 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1333 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1336 (const U8*)cx_label, cx_label_len,
1337 (const U8*)label, len) == 0)
1339 (const U8*)label, len,
1340 (const U8*)cx_label, cx_label_len) == 0)
1341 : (len == cx_label_len && ((cx_label == label)
1342 || memEQ(cx_label, label, len))) )) {
1343 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1344 (long)i, cx_label));
1347 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1358 Perl_dowantarray(pTHX)
1360 const U8 gimme = block_gimme();
1361 return (gimme == G_VOID) ? G_SCALAR : gimme;
1365 Perl_block_gimme(pTHX)
1367 const I32 cxix = dopoptosub(cxstack_ix);
1372 gimme = (cxstack[cxix].blk_gimme & G_WANT);
1374 Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1380 Perl_is_lvalue_sub(pTHX)
1382 const I32 cxix = dopoptosub(cxstack_ix);
1383 assert(cxix >= 0); /* We should only be called from inside subs */
1385 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1386 return CxLVAL(cxstack + cxix);
1391 /* only used by cx_pushsub() */
1393 Perl_was_lvalue_sub(pTHX)
1395 const I32 cxix = dopoptosub(cxstack_ix-1);
1396 assert(cxix >= 0); /* We should only be called from inside subs */
1398 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1399 return CxLVAL(cxstack + cxix);
1405 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1409 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1411 PERL_UNUSED_CONTEXT;
1414 for (i = startingblock; i >= 0; i--) {
1415 const PERL_CONTEXT * const cx = &cxstk[i];
1416 switch (CxTYPE(cx)) {
1420 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1421 * twice; the first for the normal foo() call, and the second
1422 * for a faked up re-entry into the sub to execute the
1423 * code block. Hide this faked entry from the world. */
1424 if (cx->cx_type & CXp_SUB_RE_FAKE)
1429 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1437 S_dopoptoeval(pTHX_ I32 startingblock)
1440 for (i = startingblock; i >= 0; i--) {
1441 const PERL_CONTEXT *cx = &cxstack[i];
1442 switch (CxTYPE(cx)) {
1446 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1454 S_dopoptoloop(pTHX_ I32 startingblock)
1457 for (i = startingblock; i >= 0; i--) {
1458 const PERL_CONTEXT * const cx = &cxstack[i];
1459 switch (CxTYPE(cx)) {
1465 /* diag_listed_as: Exiting subroutine via %s */
1466 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1467 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1468 if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1471 case CXt_LOOP_PLAIN:
1472 case CXt_LOOP_LAZYIV:
1473 case CXt_LOOP_LAZYSV:
1476 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1483 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1486 S_dopoptogivenfor(pTHX_ I32 startingblock)
1489 for (i = startingblock; i >= 0; i--) {
1490 const PERL_CONTEXT *cx = &cxstack[i];
1491 switch (CxTYPE(cx)) {
1495 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1497 case CXt_LOOP_PLAIN:
1498 assert(!(cx->cx_type & CXp_FOR_DEF));
1500 case CXt_LOOP_LAZYIV:
1501 case CXt_LOOP_LAZYSV:
1504 if (cx->cx_type & CXp_FOR_DEF) {
1505 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1514 S_dopoptowhen(pTHX_ I32 startingblock)
1517 for (i = startingblock; i >= 0; i--) {
1518 const PERL_CONTEXT *cx = &cxstack[i];
1519 switch (CxTYPE(cx)) {
1523 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1530 /* dounwind(): pop all contexts above (but not including) cxix.
1531 * Note that it clears the savestack frame associated with each popped
1532 * context entry, but doesn't free any temps.
1533 * It does a cx_popblock() of the last frame that it pops, and leaves
1534 * cxstack_ix equal to cxix.
1538 Perl_dounwind(pTHX_ I32 cxix)
1540 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1543 while (cxstack_ix > cxix) {
1544 PERL_CONTEXT *cx = CX_CUR();
1546 CX_DEBUG(cx, "UNWIND");
1547 /* Note: we don't need to restore the base context info till the end. */
1551 switch (CxTYPE(cx)) {
1554 /* CXt_SUBST is not a block context type, so skip the
1555 * cx_popblock(cx) below */
1556 if (cxstack_ix == cxix + 1) {
1567 case CXt_LOOP_PLAIN:
1568 case CXt_LOOP_LAZYIV:
1569 case CXt_LOOP_LAZYSV:
1582 /* these two don't have a POPFOO() */
1588 if (cxstack_ix == cxix + 1) {
1597 Perl_qerror(pTHX_ SV *err)
1599 PERL_ARGS_ASSERT_QERROR;
1602 if (PL_in_eval & EVAL_KEEPERR) {
1603 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1607 sv_catsv(ERRSV, err);
1610 sv_catsv(PL_errors, err);
1612 Perl_warn(aTHX_ "%" SVf, SVfARG(err));
1614 ++PL_parser->error_count;
1619 /* pop a CXt_EVAL context and in addition, if it was a require then
1621 * 0: do nothing extra;
1622 * 1: undef $INC{$name}; croak "$name did not return a true value";
1623 * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1627 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1629 SV *namesv = NULL; /* init to avoid dumb compiler warning */
1633 do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1635 /* keep namesv alive after cx_popeval() */
1636 namesv = cx->blk_eval.old_namesv;
1637 cx->blk_eval.old_namesv = NULL;
1646 HV *inc_hv = GvHVn(PL_incgv);
1647 I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv);
1648 const char *key = SvPVX_const(namesv);
1651 (void)hv_delete(inc_hv, key, klen, G_DISCARD);
1652 fmt = "%" SVf " did not return a true value";
1656 (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0);
1657 fmt = "%" SVf "Compilation failed in require";
1659 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1662 Perl_croak(aTHX_ fmt, SVfARG(errsv));
1667 /* die_unwind(): this is the final destination for the various croak()
1668 * functions. If we're in an eval, unwind the context and other stacks
1669 * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1670 * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1671 * to is a require the exception will be rethrown, as requires don't
1672 * actually trap exceptions.
1676 Perl_die_unwind(pTHX_ SV *msv)
1679 U8 in_eval = PL_in_eval;
1680 PERL_ARGS_ASSERT_DIE_UNWIND;
1685 /* We need to keep this SV alive through all the stack unwinding
1686 * and FREETMPSing below, while ensuing that it doesn't leak
1687 * if we call out to something which then dies (e.g. sub STORE{die}
1688 * when unlocalising a tied var). So we do a dance with
1689 * mortalising and SAVEFREEing.
1691 sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1694 * Historically, perl used to set ERRSV ($@) early in the die
1695 * process and rely on it not getting clobbered during unwinding.
1696 * That sucked, because it was liable to get clobbered, so the
1697 * setting of ERRSV used to emit the exception from eval{} has
1698 * been moved to much later, after unwinding (see just before
1699 * JMPENV_JUMP below). However, some modules were relying on the
1700 * early setting, by examining $@ during unwinding to use it as
1701 * a flag indicating whether the current unwinding was caused by
1702 * an exception. It was never a reliable flag for that purpose,
1703 * being totally open to false positives even without actual
1704 * clobberage, but was useful enough for production code to
1705 * semantically rely on it.
1707 * We'd like to have a proper introspective interface that
1708 * explicitly describes the reason for whatever unwinding
1709 * operations are currently in progress, so that those modules
1710 * work reliably and $@ isn't further overloaded. But we don't
1711 * have one yet. In its absence, as a stopgap measure, ERRSV is
1712 * now *additionally* set here, before unwinding, to serve as the
1713 * (unreliable) flag that it used to.
1715 * This behaviour is temporary, and should be removed when a
1716 * proper way to detect exceptional unwinding has been developed.
1717 * As of 2010-12, the authors of modules relying on the hack
1718 * are aware of the issue, because the modules failed on
1719 * perls 5.13.{1..7} which had late setting of $@ without this
1720 * early-setting hack.
1722 if (!(in_eval & EVAL_KEEPERR))
1723 sv_setsv_flags(ERRSV, exceptsv,
1724 (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
1726 if (in_eval & EVAL_KEEPERR) {
1727 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1731 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1732 && PL_curstackinfo->si_prev)
1742 JMPENV *restartjmpenv;
1745 if (cxix < cxstack_ix)
1749 assert(CxTYPE(cx) == CXt_EVAL);
1751 /* return false to the caller of eval */
1752 oldsp = PL_stack_base + cx->blk_oldsp;
1753 gimme = cx->blk_gimme;
1754 if (gimme == G_SCALAR)
1755 *++oldsp = &PL_sv_undef;
1756 PL_stack_sp = oldsp;
1758 restartjmpenv = cx->blk_eval.cur_top_env;
1759 restartop = cx->blk_eval.retop;
1761 /* We need a FREETMPS here to avoid late-called destructors
1762 * clobbering $@ *after* we set it below, e.g.
1763 * sub DESTROY { eval { die "X" } }
1764 * eval { my $x = bless []; die $x = 0, "Y" };
1766 * Here the clearing of the $x ref mortalises the anon array,
1767 * which needs to be freed *before* $& is set to "Y",
1768 * otherwise it gets overwritten with "X".
1770 * However, the FREETMPS will clobber exceptsv, so preserve it
1771 * on the savestack for now.
1773 SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv));
1775 /* now we're about to pop the savestack, so re-mortalise it */
1776 sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1778 /* Note that unlike pp_entereval, pp_require isn't supposed to
1779 * trap errors. So if we're a require, after we pop the
1780 * CXt_EVAL that pp_require pushed, rethrow the error with
1781 * croak(exceptsv). This is all handled by the call below when
1784 S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
1786 if (!(in_eval & EVAL_KEEPERR))
1787 sv_setsv(ERRSV, exceptsv);
1788 PL_restartjmpenv = restartjmpenv;
1789 PL_restartop = restartop;
1791 NOT_REACHED; /* NOTREACHED */
1795 write_to_stderr(exceptsv);
1797 NOT_REACHED; /* NOTREACHED */
1803 if (SvTRUE_NN(left) != SvTRUE_NN(right))
1811 =head1 CV Manipulation Functions
1813 =for apidoc caller_cx
1815 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1816 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1817 information returned to Perl by C<caller>. Note that XSUBs don't get a
1818 stack frame, so C<caller_cx(0, NULL)> will return information for the
1819 immediately-surrounding Perl code.
1821 This function skips over the automatic calls to C<&DB::sub> made on the
1822 behalf of the debugger. If the stack frame requested was a sub called by
1823 C<DB::sub>, the return value will be the frame for the call to
1824 C<DB::sub>, since that has the correct line number/etc. for the call
1825 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1826 frame for the sub call itself.
1831 const PERL_CONTEXT *
1832 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1834 I32 cxix = dopoptosub(cxstack_ix);
1835 const PERL_CONTEXT *cx;
1836 const PERL_CONTEXT *ccstack = cxstack;
1837 const PERL_SI *top_si = PL_curstackinfo;
1840 /* we may be in a higher stacklevel, so dig down deeper */
1841 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1842 top_si = top_si->si_prev;
1843 ccstack = top_si->si_cxstack;
1844 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1848 /* caller() should not report the automatic calls to &DB::sub */
1849 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1850 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1854 cxix = dopoptosub_at(ccstack, cxix - 1);
1857 cx = &ccstack[cxix];
1858 if (dbcxp) *dbcxp = cx;
1860 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1861 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1862 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1863 field below is defined for any cx. */
1864 /* caller() should not report the automatic calls to &DB::sub */
1865 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1866 cx = &ccstack[dbcxix];
1875 const PERL_CONTEXT *cx;
1876 const PERL_CONTEXT *dbcx;
1878 const HEK *stash_hek;
1880 bool has_arg = MAXARG && TOPs;
1889 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1891 if (gimme != G_ARRAY) {
1898 CX_DEBUG(cx, "CALLER");
1899 assert(CopSTASH(cx->blk_oldcop));
1900 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1901 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1903 if (gimme != G_ARRAY) {
1906 PUSHs(&PL_sv_undef);
1909 sv_sethek(TARG, stash_hek);
1918 PUSHs(&PL_sv_undef);
1921 sv_sethek(TARG, stash_hek);
1924 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1925 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1926 cx->blk_sub.retop, TRUE);
1928 lcop = cx->blk_oldcop;
1929 mPUSHu(CopLINE(lcop));
1932 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1933 /* So is ccstack[dbcxix]. */
1934 if (CvHASGV(dbcx->blk_sub.cv)) {
1935 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1936 PUSHs(boolSV(CxHASARGS(cx)));
1939 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1940 PUSHs(boolSV(CxHASARGS(cx)));
1944 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1947 gimme = cx->blk_gimme;
1948 if (gimme == G_VOID)
1949 PUSHs(&PL_sv_undef);
1951 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1952 if (CxTYPE(cx) == CXt_EVAL) {
1954 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1955 SV *cur_text = cx->blk_eval.cur_text;
1956 if (SvCUR(cur_text) >= 2) {
1957 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1958 SvUTF8(cur_text)|SVs_TEMP));
1961 /* I think this is will always be "", but be sure */
1962 PUSHs(sv_2mortal(newSVsv(cur_text)));
1968 else if (cx->blk_eval.old_namesv) {
1969 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1972 /* eval BLOCK (try blocks have old_namesv == 0) */
1974 PUSHs(&PL_sv_undef);
1975 PUSHs(&PL_sv_undef);
1979 PUSHs(&PL_sv_undef);
1980 PUSHs(&PL_sv_undef);
1982 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1983 && CopSTASH_eq(PL_curcop, PL_debstash))
1985 /* slot 0 of the pad contains the original @_ */
1986 AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
1987 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1988 cx->blk_sub.olddepth+1]))[0]);
1989 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1991 Perl_init_dbargs(aTHX);
1993 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1994 av_extend(PL_dbargs, AvFILLp(ary) + off);
1995 if (AvFILLp(ary) + 1 + off)
1996 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1997 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1999 mPUSHi(CopHINTS_get(cx->blk_oldcop));
2002 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
2004 if (old_warnings == pWARN_NONE)
2005 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
2006 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
2007 mask = &PL_sv_undef ;
2008 else if (old_warnings == pWARN_ALL ||
2009 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
2010 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
2013 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
2017 PUSHs(cx->blk_oldcop->cop_hints_hash ?
2018 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2028 if (MAXARG < 1 || (!TOPs && !POPs)) {
2030 tmps = NULL, len = 0;
2033 tmps = SvPVx_const(POPs, len);
2034 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
2039 /* like pp_nextstate, but used instead when the debugger is active */
2043 PL_curcop = (COP*)PL_op;
2044 TAINT_NOT; /* Each statement is presumed innocent */
2045 PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
2050 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2051 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2055 const U8 gimme = G_ARRAY;
2056 GV * const gv = PL_DBgv;
2059 if (gv && isGV_with_GP(gv))
2062 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2063 DIE(aTHX_ "No DB::DB routine defined");
2065 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2066 /* don't do recursive DB::DB call */
2076 (void)(*CvXSUB(cv))(aTHX_ cv);
2082 cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
2083 cx_pushsub(cx, cv, PL_op->op_next, 0);
2084 /* OP_DBSTATE's op_private holds hint bits rather than
2085 * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2086 * any CxLVAL() flags that have now been mis-calculated */
2093 if (CvDEPTH(cv) >= 2)
2094 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2095 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2096 RETURNOP(CvSTART(cv));
2108 (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2120 assert(CxTYPE(cx) == CXt_BLOCK);
2122 if (PL_op->op_flags & OPf_SPECIAL)
2123 /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */
2124 cx->blk_oldpm = PL_curpm;
2126 oldsp = PL_stack_base + cx->blk_oldsp;
2127 gimme = cx->blk_gimme;
2129 if (gimme == G_VOID)
2130 PL_stack_sp = oldsp;
2132 leave_adjust_stacks(oldsp, oldsp, gimme,
2133 PL_op->op_private & OPpLVALUE ? 3 : 1);
2143 S_outside_integer(pTHX_ SV *sv)
2146 const NV nv = SvNV_nomg(sv);
2147 if (Perl_isinfnan(nv))
2149 #ifdef NV_PRESERVES_UV
2150 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2153 if (nv <= (NV)IV_MIN)
2156 ((nv > (NV)UV_MAX ||
2157 SvUV_nomg(sv) > (UV)IV_MAX)))
2168 const U8 gimme = GIMME_V;
2169 void *itervarp; /* GV or pad slot of the iteration variable */
2170 SV *itersave; /* the old var in the iterator var slot */
2173 if (PL_op->op_targ) { /* "my" variable */
2174 itervarp = &PAD_SVl(PL_op->op_targ);
2175 itersave = *(SV**)itervarp;
2177 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2178 /* the SV currently in the pad slot is never live during
2179 * iteration (the slot is always aliased to one of the items)
2180 * so it's always stale */
2181 SvPADSTALE_on(itersave);
2183 SvREFCNT_inc_simple_void_NN(itersave);
2184 cxflags = CXp_FOR_PAD;
2187 SV * const sv = POPs;
2188 itervarp = (void *)sv;
2189 if (LIKELY(isGV(sv))) { /* symbol table variable */
2190 itersave = GvSV(sv);
2191 SvREFCNT_inc_simple_void(itersave);
2192 cxflags = CXp_FOR_GV;
2193 if (PL_op->op_private & OPpITER_DEF)
2194 cxflags |= CXp_FOR_DEF;
2196 else { /* LV ref: for \$foo (...) */
2197 assert(SvTYPE(sv) == SVt_PVMG);
2198 assert(SvMAGIC(sv));
2199 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2201 cxflags = CXp_FOR_LVREF;
2204 /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2205 assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2207 /* Note that this context is initially set as CXt_NULL. Further on
2208 * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2209 * there mustn't be anything in the blk_loop substruct that requires
2210 * freeing or undoing, in case we die in the meantime. And vice-versa.
2212 cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2213 cx_pushloop_for(cx, itervarp, itersave);
2215 if (PL_op->op_flags & OPf_STACKED) {
2216 /* OPf_STACKED implies either a single array: for(@), with a
2217 * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2219 SV *maybe_ary = POPs;
2220 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2223 SV * const right = maybe_ary;
2224 if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2225 DIE(aTHX_ "Assigned value is not a reference");
2228 if (RANGE_IS_NUMERIC(sv,right)) {
2229 cx->cx_type |= CXt_LOOP_LAZYIV;
2230 if (S_outside_integer(aTHX_ sv) ||
2231 S_outside_integer(aTHX_ right))
2232 DIE(aTHX_ "Range iterator outside integer range");
2233 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2234 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2237 cx->cx_type |= CXt_LOOP_LAZYSV;
2238 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2239 cx->blk_loop.state_u.lazysv.end = right;
2240 SvREFCNT_inc_simple_void_NN(right);
2241 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2242 /* This will do the upgrade to SVt_PV, and warn if the value
2243 is uninitialised. */
2244 (void) SvPV_nolen_const(right);
2245 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2246 to replace !SvOK() with a pointer to "". */
2248 SvREFCNT_dec(right);
2249 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2253 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2254 /* for (@array) {} */
2255 cx->cx_type |= CXt_LOOP_ARY;
2256 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2257 SvREFCNT_inc_simple_void_NN(maybe_ary);
2258 cx->blk_loop.state_u.ary.ix =
2259 (PL_op->op_private & OPpITER_REVERSED) ?
2260 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2263 /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
2265 else { /* iterating over items on the stack */
2266 cx->cx_type |= CXt_LOOP_LIST;
2267 cx->blk_oldsp = SP - PL_stack_base;
2268 cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2269 cx->blk_loop.state_u.stack.ix =
2270 (PL_op->op_private & OPpITER_REVERSED)
2272 : cx->blk_loop.state_u.stack.basesp;
2273 /* pre-extend stack so pp_iter doesn't have to check every time
2274 * it pushes yes/no */
2284 const U8 gimme = GIMME_V;
2286 cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2287 cx_pushloop_plain(cx);
2300 assert(CxTYPE_is_LOOP(cx));
2301 oldsp = PL_stack_base + cx->blk_oldsp;
2302 base = CxTYPE(cx) == CXt_LOOP_LIST
2303 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2305 gimme = cx->blk_gimme;
2307 if (gimme == G_VOID)
2310 leave_adjust_stacks(oldsp, base, gimme,
2311 PL_op->op_private & OPpLVALUE ? 3 : 1);
2314 cx_poploop(cx); /* Stack values are safe: release loop vars ... */
2322 /* This duplicates most of pp_leavesub, but with additional code to handle
2323 * return args in lvalue context. It was forked from pp_leavesub to
2324 * avoid slowing down that function any further.
2326 * Any changes made to this function may need to be copied to pp_leavesub
2329 * also tail-called by pp_return
2340 assert(CxTYPE(cx) == CXt_SUB);
2342 if (CxMULTICALL(cx)) {
2343 /* entry zero of a stack is always PL_sv_undef, which
2344 * simplifies converting a '()' return into undef in scalar context */
2345 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2349 gimme = cx->blk_gimme;
2350 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2352 if (gimme == G_VOID)
2353 PL_stack_sp = oldsp;
2355 U8 lval = CxLVAL(cx);
2356 bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2357 const char *what = NULL;
2359 if (gimme == G_SCALAR) {
2361 /* check for bad return arg */
2362 if (oldsp < PL_stack_sp) {
2363 SV *sv = *PL_stack_sp;
2364 if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2366 SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2367 : "a readonly value" : "a temporary";
2372 /* sub:lvalue{} will take us here. */
2377 "Can't return %s from lvalue subroutine", what);
2381 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2383 if (lval & OPpDEREF) {
2384 /* lval_sub()->{...} and similar */
2388 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2394 assert(gimme == G_ARRAY);
2395 assert (!(lval & OPpDEREF));
2398 /* scan for bad return args */
2400 for (p = PL_stack_sp; p > oldsp; p--) {
2402 /* the PL_sv_undef exception is to allow things like
2403 * this to work, where PL_sv_undef acts as 'skip'
2404 * placeholder on the LHS of list assigns:
2405 * sub foo :lvalue { undef }
2406 * ($a, undef, foo(), $b) = 1..4;
2408 if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2410 /* Might be flattened array after $#array = */
2411 what = SvREADONLY(sv)
2412 ? "a readonly value" : "a temporary";
2418 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2423 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
2425 retop = cx->blk_sub.retop;
2436 const I32 cxix = dopoptosub(cxstack_ix);
2438 assert(cxstack_ix >= 0);
2439 if (cxix < cxstack_ix) {
2441 if (!( PL_curstackinfo->si_type == PERLSI_SORT
2442 || ( PL_curstackinfo->si_type == PERLSI_MULTICALL
2443 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2446 DIE(aTHX_ "Can't return outside a subroutine");
2448 * a sort block, which is a CXt_NULL not a CXt_SUB;
2449 * or a /(?{...})/ block.
2450 * Handle specially. */
2451 assert(CxTYPE(&cxstack[0]) == CXt_NULL
2452 || ( CxTYPE(&cxstack[0]) == CXt_SUB
2453 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2454 if (cxstack_ix > 0) {
2455 /* See comment below about context popping. Since we know
2456 * we're scalar and not lvalue, we can preserve the return
2457 * value in a simpler fashion than there. */
2459 assert(cxstack[0].blk_gimme == G_SCALAR);
2460 if ( (sp != PL_stack_base)
2461 && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2463 *SP = sv_mortalcopy(sv);
2466 /* caller responsible for popping cxstack[0] */
2470 /* There are contexts that need popping. Doing this may free the
2471 * return value(s), so preserve them first: e.g. popping the plain
2472 * loop here would free $x:
2473 * sub f { { my $x = 1; return $x } }
2474 * We may also need to shift the args down; for example,
2475 * for (1,2) { return 3,4 }
2476 * leaves 1,2,3,4 on the stack. Both these actions will be done by
2477 * leave_adjust_stacks(), along with freeing any temps. Note that
2478 * whoever we tail-call (e.g. pp_leaveeval) will also call
2479 * leave_adjust_stacks(); however, the second call is likely to
2480 * just see a bunch of SvTEMPs with a ref count of 1, and so just
2481 * pass them through, rather than copying them again. So this
2482 * isn't as inefficient as it sounds.
2484 cx = &cxstack[cxix];
2486 if (cx->blk_gimme != G_VOID)
2487 leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2489 CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2493 cx = &cxstack[cxix]; /* CX stack may have been realloced */
2496 /* Like in the branch above, we need to handle any extra junk on
2497 * the stack. But because we're not also popping extra contexts, we
2498 * don't have to worry about prematurely freeing args. So we just
2499 * need to do the bare minimum to handle junk, and leave the main
2500 * arg processing in the function we tail call, e.g. pp_leavesub.
2501 * In list context we have to splice out the junk; in scalar
2502 * context we can leave as-is (pp_leavesub will later return the
2503 * top stack element). But for an empty arg list, e.g.
2504 * for (1,2) { return }
2505 * we need to set sp = oldsp so that pp_leavesub knows to push
2506 * &PL_sv_undef onto the stack.
2509 cx = &cxstack[cxix];
2510 oldsp = PL_stack_base + cx->blk_oldsp;
2511 if (oldsp != MARK) {
2512 SSize_t nargs = SP - MARK;
2514 if (cx->blk_gimme == G_ARRAY) {
2515 /* shift return args to base of call stack frame */
2516 Move(MARK + 1, oldsp + 1, nargs, SV*);
2517 PL_stack_sp = oldsp + nargs;
2521 PL_stack_sp = oldsp;
2525 /* fall through to a normal exit */
2526 switch (CxTYPE(cx)) {
2528 return CxTRYBLOCK(cx)
2529 ? Perl_pp_leavetry(aTHX)
2530 : Perl_pp_leaveeval(aTHX);
2532 return CvLVALUE(cx->blk_sub.cv)
2533 ? Perl_pp_leavesublv(aTHX)
2534 : Perl_pp_leavesub(aTHX);
2536 return Perl_pp_leavewrite(aTHX);
2538 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2542 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2544 static PERL_CONTEXT *
2548 if (PL_op->op_flags & OPf_SPECIAL) {
2549 cxix = dopoptoloop(cxstack_ix);
2551 /* diag_listed_as: Can't "last" outside a loop block */
2552 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2558 const char * const label =
2559 PL_op->op_flags & OPf_STACKED
2560 ? SvPV(TOPs,label_len)
2561 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2562 const U32 label_flags =
2563 PL_op->op_flags & OPf_STACKED
2565 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2567 cxix = dopoptolabel(label, label_len, label_flags);
2569 /* diag_listed_as: Label not found for "last %s" */
2570 Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"",
2572 SVfARG(PL_op->op_flags & OPf_STACKED
2573 && !SvGMAGICAL(TOPp1s)
2575 : newSVpvn_flags(label,
2577 label_flags | SVs_TEMP)));
2579 if (cxix < cxstack_ix)
2581 return &cxstack[cxix];
2590 cx = S_unwind_loop(aTHX);
2592 assert(CxTYPE_is_LOOP(cx));
2593 PL_stack_sp = PL_stack_base
2594 + (CxTYPE(cx) == CXt_LOOP_LIST
2595 ? cx->blk_loop.state_u.stack.basesp
2601 /* Stack values are safe: */
2603 cx_poploop(cx); /* release loop vars ... */
2605 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2615 /* if not a bare 'next' in the main scope, search for it */
2617 if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
2618 cx = S_unwind_loop(aTHX);
2621 PL_curcop = cx->blk_oldcop;
2623 return (cx)->blk_loop.my_op->op_nextop;
2628 PERL_CONTEXT *cx = S_unwind_loop(aTHX);
2629 OP* redo_op = cx->blk_loop.my_op->op_redoop;
2631 if (redo_op->op_type == OP_ENTER) {
2632 /* pop one less context to avoid $x being freed in while (my $x..) */
2635 assert(CxTYPE(cx) == CXt_BLOCK);
2636 redo_op = redo_op->op_next;
2642 PL_curcop = cx->blk_oldcop;
2647 #define UNENTERABLE (OP *)1
2648 #define GOTO_DEPTH 64
2651 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2654 static const char* const too_deep = "Target of goto is too deeply nested";
2656 PERL_ARGS_ASSERT_DOFINDLABEL;
2659 Perl_croak(aTHX_ "%s", too_deep);
2660 if (o->op_type == OP_LEAVE ||
2661 o->op_type == OP_SCOPE ||
2662 o->op_type == OP_LEAVELOOP ||
2663 o->op_type == OP_LEAVESUB ||
2664 o->op_type == OP_LEAVETRY ||
2665 o->op_type == OP_LEAVEGIVEN)
2667 *ops++ = cUNOPo->op_first;
2669 else if (oplimit - opstack < GOTO_DEPTH) {
2670 if (o->op_flags & OPf_KIDS
2671 && cUNOPo->op_first->op_type == OP_PUSHMARK) {
2672 *ops++ = UNENTERABLE;
2674 else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type]
2675 && OP_CLASS(o) != OA_LOGOP
2676 && o->op_type != OP_LINESEQ
2677 && o->op_type != OP_SREFGEN
2678 && o->op_type != OP_ENTEREVAL
2679 && o->op_type != OP_GLOB
2680 && o->op_type != OP_RV2CV) {
2681 OP * const kid = cUNOPo->op_first;
2682 if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid))
2683 *ops++ = UNENTERABLE;
2687 Perl_croak(aTHX_ "%s", too_deep);
2689 if (o->op_flags & OPf_KIDS) {
2691 OP * const kid1 = cUNOPo->op_first;
2692 /* First try all the kids at this level, since that's likeliest. */
2693 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2694 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2695 STRLEN kid_label_len;
2696 U32 kid_label_flags;
2697 const char *kid_label = CopLABEL_len_flags(kCOP,
2698 &kid_label_len, &kid_label_flags);
2700 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2703 (const U8*)kid_label, kid_label_len,
2704 (const U8*)label, len) == 0)
2706 (const U8*)label, len,
2707 (const U8*)kid_label, kid_label_len) == 0)
2708 : ( len == kid_label_len && ((kid_label == label)
2709 || memEQ(kid_label, label, len)))))
2713 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2714 bool first_kid_of_binary = FALSE;
2715 if (kid == PL_lastgotoprobe)
2717 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2720 else if (ops[-1] != UNENTERABLE
2721 && (ops[-1]->op_type == OP_NEXTSTATE ||
2722 ops[-1]->op_type == OP_DBSTATE))
2727 if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) {
2728 first_kid_of_binary = TRUE;
2731 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2733 if (first_kid_of_binary)
2734 *ops++ = UNENTERABLE;
2743 S_check_op_type(pTHX_ OP * const o)
2745 /* Eventually we may want to stack the needed arguments
2746 * for each op. For now, we punt on the hard ones. */
2747 /* XXX This comment seems to me like wishful thinking. --sprout */
2748 if (o == UNENTERABLE)
2750 "Can't \"goto\" into a binary or list expression");
2751 if (o->op_type == OP_ENTERITER)
2753 "Can't \"goto\" into the middle of a foreach loop");
2754 if (o->op_type == OP_ENTERGIVEN)
2756 "Can't \"goto\" into a \"given\" block");
2759 /* also used for: pp_dump() */
2767 OP *enterops[GOTO_DEPTH];
2768 const char *label = NULL;
2769 STRLEN label_len = 0;
2770 U32 label_flags = 0;
2771 const bool do_dump = (PL_op->op_type == OP_DUMP);
2772 static const char* const must_have_label = "goto must have label";
2774 if (PL_op->op_flags & OPf_STACKED) {
2775 /* goto EXPR or goto &foo */
2777 SV * const sv = POPs;
2780 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2781 /* This egregious kludge implements goto &subroutine */
2784 CV *cv = MUTABLE_CV(SvRV(sv));
2785 AV *arg = GvAV(PL_defgv);
2787 while (!CvROOT(cv) && !CvXSUB(cv)) {
2788 const GV * const gv = CvGV(cv);
2792 /* autoloaded stub? */
2793 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2795 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2797 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2798 if (autogv && (cv = GvCV(autogv)))
2800 tmpstr = sv_newmortal();
2801 gv_efullname3(tmpstr, gv, NULL);
2802 DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
2804 DIE(aTHX_ "Goto undefined subroutine");
2807 cxix = dopoptosub(cxstack_ix);
2809 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2811 cx = &cxstack[cxix];
2812 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2813 if (CxTYPE(cx) == CXt_EVAL) {
2815 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2816 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2818 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2819 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2821 else if (CxMULTICALL(cx))
2822 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2824 /* First do some returnish stuff. */
2826 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2828 if (cxix < cxstack_ix) {
2835 /* protect @_ during save stack unwind. */
2837 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
2839 assert(PL_scopestack_ix == cx->blk_oldscopesp);
2842 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2843 /* this is part of cx_popsub_args() */
2844 AV* av = MUTABLE_AV(PAD_SVl(0));
2845 assert(AvARRAY(MUTABLE_AV(
2846 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2847 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2849 /* we are going to donate the current @_ from the old sub
2850 * to the new sub. This first part of the donation puts a
2851 * new empty AV in the pad[0] slot of the old sub,
2852 * unless pad[0] and @_ differ (e.g. if the old sub did
2853 * local *_ = []); in which case clear the old pad[0]
2854 * array in the usual way */
2855 if (av == arg || AvREAL(av))
2856 clear_defarray(av, av == arg);
2857 else CLEAR_ARGARRAY(av);
2860 /* don't restore PL_comppad here. It won't be needed if the
2861 * sub we're going to is non-XS, but restoring it early then
2862 * croaking (e.g. the "Goto undefined subroutine" below)
2863 * means the CX block gets processed again in dounwind,
2864 * but this time with the wrong PL_comppad */
2866 /* A destructor called during LEAVE_SCOPE could have undefined
2867 * our precious cv. See bug #99850. */
2868 if (!CvROOT(cv) && !CvXSUB(cv)) {
2869 const GV * const gv = CvGV(cv);
2871 SV * const tmpstr = sv_newmortal();
2872 gv_efullname3(tmpstr, gv, NULL);
2873 DIE(aTHX_ "Goto undefined subroutine &%" SVf,
2876 DIE(aTHX_ "Goto undefined subroutine");
2879 if (CxTYPE(cx) == CXt_SUB) {
2880 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2881 SvREFCNT_dec_NN(cx->blk_sub.cv);
2884 /* Now do some callish stuff. */
2886 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2887 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2892 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2894 /* put GvAV(defgv) back onto stack */
2896 EXTEND(SP, items+1); /* @_ could have been extended. */
2901 bool r = cBOOL(AvREAL(arg));
2902 for (index=0; index<items; index++)
2906 SV ** const svp = av_fetch(arg, index, 0);
2907 sv = svp ? *svp : NULL;
2909 else sv = AvARRAY(arg)[index];
2911 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2912 : sv_2mortal(newSVavdefelem(arg, index, 1));
2916 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2917 /* Restore old @_ */
2918 CX_POP_SAVEARRAY(cx);
2921 retop = cx->blk_sub.retop;
2922 PL_comppad = cx->blk_sub.prevcomppad;
2923 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2925 /* XS subs don't have a CXt_SUB, so pop it;
2926 * this is a cx_popblock(), less all the stuff we already did
2927 * for cx_topblock() earlier */
2928 PL_curcop = cx->blk_oldcop;
2931 /* Push a mark for the start of arglist */
2934 (void)(*CvXSUB(cv))(aTHX_ cv);
2939 PADLIST * const padlist = CvPADLIST(cv);
2941 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2943 /* partial unrolled cx_pushsub(): */
2945 cx->blk_sub.cv = cv;
2946 cx->blk_sub.olddepth = CvDEPTH(cv);
2949 SvREFCNT_inc_simple_void_NN(cv);
2950 if (CvDEPTH(cv) > 1) {
2951 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2952 sub_crush_depth(cv);
2953 pad_push(padlist, CvDEPTH(cv));
2955 PL_curcop = cx->blk_oldcop;
2956 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2959 /* second half of donating @_ from the old sub to the
2960 * new sub: abandon the original pad[0] AV in the
2961 * new sub, and replace it with the donated @_.
2962 * pad[0] takes ownership of the extra refcount
2963 * we gave arg earlier */
2965 SvREFCNT_dec(PAD_SVl(0));
2966 PAD_SVl(0) = (SV *)arg;
2967 SvREFCNT_inc_simple_void_NN(arg);
2970 /* GvAV(PL_defgv) might have been modified on scope
2971 exit, so point it at arg again. */
2972 if (arg != GvAV(PL_defgv)) {
2973 AV * const av = GvAV(PL_defgv);
2974 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2979 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2980 Perl_get_db_sub(aTHX_ NULL, cv);
2982 CV * const gotocv = get_cvs("DB::goto", 0);
2984 PUSHMARK( PL_stack_sp );
2985 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2990 retop = CvSTART(cv);
2991 goto putback_return;
2996 label = SvPV_nomg_const(sv, label_len);
2997 label_flags = SvUTF8(sv);
3000 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
3001 /* goto LABEL or dump LABEL */
3002 label = cPVOP->op_pv;
3003 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
3004 label_len = strlen(label);
3006 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
3011 OP *gotoprobe = NULL;
3012 bool leaving_eval = FALSE;
3013 bool in_block = FALSE;
3014 bool pseudo_block = FALSE;
3015 PERL_CONTEXT *last_eval_cx = NULL;
3019 PL_lastgotoprobe = NULL;
3021 for (ix = cxstack_ix; ix >= 0; ix--) {
3023 switch (CxTYPE(cx)) {
3025 leaving_eval = TRUE;
3026 if (!CxTRYBLOCK(cx)) {
3027 gotoprobe = (last_eval_cx ?
3028 last_eval_cx->blk_eval.old_eval_root :
3033 /* else fall through */
3034 case CXt_LOOP_PLAIN:
3035 case CXt_LOOP_LAZYIV:
3036 case CXt_LOOP_LAZYSV:
3041 gotoprobe = OpSIBLING(cx->blk_oldcop);
3047 gotoprobe = OpSIBLING(cx->blk_oldcop);
3050 gotoprobe = PL_main_root;
3053 gotoprobe = CvROOT(cx->blk_sub.cv);
3054 pseudo_block = cBOOL(CxMULTICALL(cx));
3058 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3061 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3062 CxTYPE(cx), (long) ix);
3063 gotoprobe = PL_main_root;
3069 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3070 enterops, enterops + GOTO_DEPTH);
3073 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3074 sibl1->op_type == OP_UNSTACK &&
3075 (sibl2 = OpSIBLING(sibl1)))
3077 retop = dofindlabel(sibl2,
3078 label, label_len, label_flags, enterops,
3079 enterops + GOTO_DEPTH);
3085 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3086 PL_lastgotoprobe = gotoprobe;
3089 DIE(aTHX_ "Can't find label %" UTF8f,
3090 UTF8fARG(label_flags, label_len, label));
3092 /* if we're leaving an eval, check before we pop any frames
3093 that we're not going to punt, otherwise the error
3096 if (leaving_eval && *enterops && enterops[1]) {
3098 for (i = 1; enterops[i]; i++)
3099 S_check_op_type(aTHX_ enterops[i]);
3102 if (*enterops && enterops[1]) {
3103 I32 i = enterops[1] != UNENTERABLE
3104 && enterops[1]->op_type == OP_ENTER && in_block
3108 deprecate("\"goto\" to jump into a construct");
3111 /* pop unwanted frames */
3113 if (ix < cxstack_ix) {
3115 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3121 /* push wanted frames */
3123 if (*enterops && enterops[1]) {
3124 OP * const oldop = PL_op;
3125 ix = enterops[1] != UNENTERABLE
3126 && enterops[1]->op_type == OP_ENTER && in_block
3129 for (; enterops[ix]; ix++) {
3130 PL_op = enterops[ix];
3131 S_check_op_type(aTHX_ PL_op);
3132 DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n",
3134 PL_op->op_ppaddr(aTHX);
3142 if (!retop) retop = PL_main_start;
3144 PL_restartop = retop;
3145 PL_do_undump = TRUE;
3149 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3150 PL_do_undump = FALSE;
3168 anum = 0; (void)POPs;
3174 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3177 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3180 PL_exit_flags |= PERL_EXIT_EXPECTED;
3182 PUSHs(&PL_sv_undef);
3189 S_save_lines(pTHX_ AV *array, SV *sv)
3191 const char *s = SvPVX_const(sv);
3192 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3195 PERL_ARGS_ASSERT_SAVE_LINES;
3197 while (s && s < send) {
3199 SV * const tmpstr = newSV_type(SVt_PVMG);
3201 t = (const char *)memchr(s, '\n', send - s);
3207 sv_setpvn(tmpstr, s, t - s);
3208 av_store(array, line++, tmpstr);
3216 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3218 0 is used as continue inside eval,
3220 3 is used for a die caught by an inner eval - continue inner loop
3222 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3223 establish a local jmpenv to handle exception traps.
3228 S_docatch(pTHX_ Perl_ppaddr_t firstpp)
3231 OP * const oldop = PL_op;
3234 assert(CATCH_GET == TRUE);
3239 PL_op = firstpp(aTHX);
3244 /* die caught by an inner eval - continue inner loop */
3245 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3246 PL_restartjmpenv = NULL;
3247 PL_op = PL_restartop;
3256 NOT_REACHED; /* NOTREACHED */
3265 =for apidoc find_runcv
3267 Locate the CV corresponding to the currently executing sub or eval.
3268 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3269 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3270 entered. (This allows debuggers to eval in the scope of the breakpoint
3271 rather than in the scope of the debugger itself.)
3277 Perl_find_runcv(pTHX_ U32 *db_seqp)
3279 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3282 /* If this becomes part of the API, it might need a better name. */
3284 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3291 PL_curcop == &PL_compiling
3293 : PL_curcop->cop_seq;
3295 for (si = PL_curstackinfo; si; si = si->si_prev) {
3297 for (ix = si->si_cxix; ix >= 0; ix--) {
3298 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3300 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3301 cv = cx->blk_sub.cv;
3302 /* skip DB:: code */
3303 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3304 *db_seqp = cx->blk_oldcop->cop_seq;
3307 if (cx->cx_type & CXp_SUB_RE)
3310 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3311 cv = cx->blk_eval.cv;
3314 case FIND_RUNCV_padid_eq:
3316 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3319 case FIND_RUNCV_level_eq:
3320 if (level++ != arg) continue;
3328 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3332 /* Run yyparse() in a setjmp wrapper. Returns:
3333 * 0: yyparse() successful
3334 * 1: yyparse() failed
3338 S_try_yyparse(pTHX_ int gramtype)
3343 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3347 ret = yyparse(gramtype) ? 1 : 0;
3354 NOT_REACHED; /* NOTREACHED */
3361 /* Compile a require/do or an eval ''.
3363 * outside is the lexically enclosing CV (if any) that invoked us.
3364 * seq is the current COP scope value.
3365 * hh is the saved hints hash, if any.
3367 * Returns a bool indicating whether the compile was successful; if so,
3368 * PL_eval_start contains the first op of the compiled code; otherwise,
3371 * This function is called from two places: pp_require and pp_entereval.
3372 * These can be distinguished by whether PL_op is entereval.
3376 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3379 OP * const saveop = PL_op;
3380 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3381 COP * const oldcurcop = PL_curcop;
3382 bool in_require = (saveop->op_type == OP_REQUIRE);
3386 PL_in_eval = (in_require
3387 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3389 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3390 ? EVAL_RE_REPARSING : 0)));
3394 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3396 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3397 CX_CUR()->blk_eval.cv = evalcv;
3398 CX_CUR()->blk_gimme = gimme;
3400 CvOUTSIDE_SEQ(evalcv) = seq;
3401 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3403 /* set up a scratch pad */
3405 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3406 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3409 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3411 /* make sure we compile in the right package */
3413 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3414 SAVEGENERICSV(PL_curstash);
3415 PL_curstash = (HV *)CopSTASH(PL_curcop);
3416 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3418 SvREFCNT_inc_simple_void(PL_curstash);
3419 save_item(PL_curstname);
3420 sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash));
3423 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3424 SAVESPTR(PL_beginav);
3425 PL_beginav = newAV();
3426 SAVEFREESV(PL_beginav);
3427 SAVESPTR(PL_unitcheckav);
3428 PL_unitcheckav = newAV();
3429 SAVEFREESV(PL_unitcheckav);
3432 ENTER_with_name("evalcomp");
3433 SAVESPTR(PL_compcv);
3436 /* try to compile it */
3438 PL_eval_root = NULL;
3439 PL_curcop = &PL_compiling;
3440 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3441 PL_in_eval |= EVAL_KEEPERR;
3448 hv_clear(GvHV(PL_hintgv));
3451 PL_hints = saveop->op_private & OPpEVAL_COPHH
3452 ? oldcurcop->cop_hints : (U32)saveop->op_targ;
3454 /* making 'use re eval' not be in scope when compiling the
3455 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3456 * infinite recursion when S_has_runtime_code() gives a false
3457 * positive: the second time round, HINT_RE_EVAL isn't set so we
3458 * don't bother calling S_has_runtime_code() */
3459 if (PL_in_eval & EVAL_RE_REPARSING)
3460 PL_hints &= ~HINT_RE_EVAL;
3463 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3464 SvREFCNT_dec(GvHV(PL_hintgv));
3465 GvHV(PL_hintgv) = hh;
3468 SAVECOMPILEWARNINGS();
3470 if (PL_dowarn & G_WARN_ALL_ON)
3471 PL_compiling.cop_warnings = pWARN_ALL ;
3472 else if (PL_dowarn & G_WARN_ALL_OFF)
3473 PL_compiling.cop_warnings = pWARN_NONE ;
3475 PL_compiling.cop_warnings = pWARN_STD ;
3478 PL_compiling.cop_warnings =
3479 DUP_WARNINGS(oldcurcop->cop_warnings);
3480 cophh_free(CopHINTHASH_get(&PL_compiling));
3481 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3482 /* The label, if present, is the first entry on the chain. So rather
3483 than writing a blank label in front of it (which involves an
3484 allocation), just use the next entry in the chain. */
3485 PL_compiling.cop_hints_hash
3486 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3487 /* Check the assumption that this removed the label. */
3488 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3491 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3494 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3496 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3497 * so honour CATCH_GET and trap it here if necessary */
3500 /* compile the code */
3501 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3503 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3508 /* note that if yystatus == 3, then the require/eval died during
3509 * compilation, so the EVAL CX block has already been popped, and
3510 * various vars restored */
3511 if (yystatus != 3) {
3513 op_free(PL_eval_root);
3514 PL_eval_root = NULL;
3516 SP = PL_stack_base + POPMARK; /* pop original mark */
3518 assert(CxTYPE(cx) == CXt_EVAL);
3519 /* pop the CXt_EVAL, and if was a require, croak */
3520 S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
3523 /* die_unwind() re-croaks when in require, having popped the
3524 * require EVAL context. So we should never catch a require
3526 assert(!in_require);
3529 if (!*(SvPV_nolen_const(errsv)))
3530 sv_setpvs(errsv, "Compilation error");
3532 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3537 /* Compilation successful. Now clean up */
3539 LEAVE_with_name("evalcomp");
3541 CopLINE_set(&PL_compiling, 0);
3542 SAVEFREEOP(PL_eval_root);
3543 cv_forget_slab(evalcv);
3545 DEBUG_x(dump_eval());
3547 /* Register with debugger: */
3548 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3549 CV * const cv = get_cvs("DB::postponed", 0);
3553 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3555 call_sv(MUTABLE_SV(cv), G_DISCARD);
3559 if (PL_unitcheckav) {
3560 OP *es = PL_eval_start;
3561 call_list(PL_scopestack_ix, PL_unitcheckav);
3565 CvDEPTH(evalcv) = 1;
3566 SP = PL_stack_base + POPMARK; /* pop original mark */
3567 PL_op = saveop; /* The caller may need it. */
3568 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3574 /* Return NULL if the file doesn't exist or isn't a file;
3575 * else return PerlIO_openn().
3579 S_check_type_and_open(pTHX_ SV *name)
3584 const char *p = SvPV_const(name, len);
3587 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3589 /* checking here captures a reasonable error message when
3590 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3591 * user gets a confusing message about looking for the .pmc file
3592 * rather than for the .pm file so do the check in S_doopen_pm when
3593 * PMC is on instead of here. S_doopen_pm calls this func.
3594 * This check prevents a \0 in @INC causing problems.
3596 #ifdef PERL_DISABLE_PMC
3597 if (!IS_SAFE_PATHNAME(p, len, "require"))
3601 /* on Win32 stat is expensive (it does an open() and close() twice and
3602 a couple other IO calls), the open will fail with a dir on its own with
3603 errno EACCES, so only do a stat to separate a dir from a real EACCES
3604 caused by user perms */
3606 st_rc = PerlLIO_stat(p, &st);
3612 if(S_ISBLK(st.st_mode)) {
3616 else if(S_ISDIR(st.st_mode)) {
3625 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3627 /* EACCES stops the INC search early in pp_require to implement
3628 feature RT #113422 */
3629 if(!retio && errno == EACCES) { /* exists but probably a directory */
3631 st_rc = PerlLIO_stat(p, &st);
3633 if(S_ISDIR(st.st_mode))
3635 else if(S_ISBLK(st.st_mode))
3646 /* doopen_pm(): return the equivalent of PerlIO_openn() on the given name,
3647 * but first check for bad names (\0) and non-files.
3648 * Also if the filename ends in .pm and unless PERL_DISABLE_PMC,
3649 * try loading Foo.pmc first.
3651 #ifndef PERL_DISABLE_PMC
3653 S_doopen_pm(pTHX_ SV *name)
3656 const char *p = SvPV_const(name, namelen);
3658 PERL_ARGS_ASSERT_DOOPEN_PM;
3660 /* check the name before trying for the .pmc name to avoid the
3661 * warning referring to the .pmc which the user probably doesn't
3662 * know or care about
3664 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3667 if (memENDPs(p, namelen, ".pm")) {
3668 SV *const pmcsv = sv_newmortal();
3671 SvSetSV_nosteal(pmcsv,name);
3672 sv_catpvs(pmcsv, "c");
3674 pmcio = check_type_and_open(pmcsv);
3678 return check_type_and_open(name);
3681 # define doopen_pm(name) check_type_and_open(name)
3682 #endif /* !PERL_DISABLE_PMC */
3684 /* require doesn't search in @INC for absolute names, or when the name is
3685 explicitly relative the current directory: i.e. ./, ../ */
3686 PERL_STATIC_INLINE bool
3687 S_path_is_searchable(const char *name)
3689 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3691 if (PERL_FILE_IS_ABSOLUTE(name)
3693 || (*name == '.' && ((name[1] == '/' ||
3694 (name[1] == '.' && name[2] == '/'))
3695 || (name[1] == '\\' ||
3696 ( name[1] == '.' && name[2] == '\\')))
3699 || (*name == '.' && (name[1] == '/' ||
3700 (name[1] == '.' && name[2] == '/')))
3711 /* implement 'require 5.010001' */
3714 S_require_version(pTHX_ SV *sv)
3718 sv = sv_2mortal(new_version(sv));
3719 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3720 upg_version(PL_patchlevel, TRUE);
3721 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3722 if ( vcmp(sv,PL_patchlevel) <= 0 )
3723 DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
3724 SVfARG(sv_2mortal(vnormal(sv))),
3725 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3729 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3732 SV * const req = SvRV(sv);
3733 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3735 /* get the left hand term */
3736 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3738 first = SvIV(*av_fetch(lav,0,0));
3739 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3740 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3741 || av_tindex(lav) > 1 /* FP with > 3 digits */
3742 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3744 DIE(aTHX_ "Perl %" SVf " required--this is only "
3745 "%" SVf ", stopped",
3746 SVfARG(sv_2mortal(vnormal(req))),
3747 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3750 else { /* probably 'use 5.10' or 'use 5.8' */
3754 if (av_tindex(lav)>=1)
3755 second = SvIV(*av_fetch(lav,1,0));
3757 second /= second >= 600 ? 100 : 10;
3758 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3759 (int)first, (int)second);
3760 upg_version(hintsv, TRUE);
3762 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)"
3763 "--this is only %" SVf ", stopped",
3764 SVfARG(sv_2mortal(vnormal(req))),
3765 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3766 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3775 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
3776 * The first form will have already been converted at compile time to
3777 * the second form */
3780 S_require_file(pTHX_ SV *sv)
3790 int vms_unixname = 0;
3793 /* tryname is the actual pathname (with @INC prefix) which was loaded.
3794 * It's stored as a value in %INC, and used for error messages */
3795 const char *tryname = NULL;
3796 SV *namesv = NULL; /* SV equivalent of tryname */
3797 const U8 gimme = GIMME_V;
3798 int filter_has_file = 0;
3799 PerlIO *tryrsfp = NULL;
3800 SV *filter_cache = NULL;
3801 SV *filter_state = NULL;
3802 SV *filter_sub = NULL;
3806 bool path_searchable;
3807 I32 old_savestack_ix;
3808 const bool op_is_require = PL_op->op_type == OP_REQUIRE;
3809 const char *const op_name = op_is_require ? "require" : "do";
3810 SV ** svp_cached = NULL;
3812 assert(op_is_require || PL_op->op_type == OP_DOFILE);
3815 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3816 name = SvPV_nomg_const(sv, len);
3817 if (!(name && len > 0 && *name))
3818 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3821 /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */
3822 if (op_is_require) {
3823 /* can optimize to only perform one single lookup */
3824 svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0);
3825 if ( svp_cached && *svp_cached != &PL_sv_undef ) RETPUSHYES;
3829 if (!IS_SAFE_PATHNAME(name, len, op_name)) {
3830 if (!op_is_require) {
3834 DIE(aTHX_ "Can't locate %s: %s",
3835 pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
3836 NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3839 TAINT_PROPER(op_name);
3841 path_searchable = path_is_searchable(name);
3844 /* The key in the %ENV hash is in the syntax of file passed as the argument
3845 * usually this is in UNIX format, but sometimes in VMS format, which
3846 * can result in a module being pulled in more than once.
3847 * To prevent this, the key must be stored in UNIX format if the VMS
3848 * name can be translated to UNIX.
3852 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3854 unixlen = strlen(unixname);
3860 /* if not VMS or VMS name can not be translated to UNIX, pass it
3863 unixname = (char *) name;
3866 if (op_is_require) {
3867 /* reuse the previous hv_fetch result if possible */
3868 SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3870 if (*svp != &PL_sv_undef)
3873 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3874 "Compilation failed in require", unixname);
3877 /*XXX OPf_KIDS should always be true? -dapm 4/2017 */
3878 if (PL_op->op_flags & OPf_KIDS) {
3879 SVOP * const kid = (SVOP*)cUNOP->op_first;
3881 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3882 /* Make sure that a bareword module name (e.g. ::Foo::Bar)
3883 * doesn't map to a naughty pathname like /Foo/Bar.pm.
3884 * Note that the parser will normally detect such errors
3885 * at compile time before we reach here, but
3886 * Perl_load_module() can fake up an identical optree
3887 * without going near the parser, and being able to put
3888 * anything as the bareword. So we include a duplicate set
3889 * of checks here at runtime.
3891 const STRLEN package_len = len - 3;
3892 const char slashdot[2] = {'/', '.'};
3894 const char backslashdot[2] = {'\\', '.'};
3897 /* Disallow *purported* barewords that map to absolute
3898 filenames, filenames relative to the current or parent
3899 directory, or (*nix) hidden filenames. Also sanity check
3900 that the generated filename ends .pm */
3901 if (!path_searchable || len < 3 || name[0] == '.'
3902 || !memEQs(name + package_len, len - package_len, ".pm"))
3903 DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv);
3904 if (memchr(name, 0, package_len)) {
3905 /* diag_listed_as: Bareword in require contains "%s" */
3906 DIE(aTHX_ "Bareword in require contains \"\\0\"");
3908 if (ninstr(name, name + package_len, slashdot,
3909 slashdot + sizeof(slashdot))) {
3910 /* diag_listed_as: Bareword in require contains "%s" */
3911 DIE(aTHX_ "Bareword in require contains \"/.\"");
3914 if (ninstr(name, name + package_len, backslashdot,
3915 backslashdot + sizeof(backslashdot))) {
3916 /* diag_listed_as: Bareword in require contains "%s" */
3917 DIE(aTHX_ "Bareword in require contains \"\\.\"");
3924 PERL_DTRACE_PROBE_FILE_LOADING(unixname);
3926 /* Try to locate and open a file, possibly using @INC */
3928 /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load
3929 * the file directly rather than via @INC ... */
3930 if (!path_searchable) {
3931 /* At this point, name is SvPVX(sv) */
3933 tryrsfp = doopen_pm(sv);
3936 /* ... but if we fail, still search @INC for code references;
3937 * these are applied even on on-searchable paths (except
3938 * if we got EACESS).
3940 * For searchable paths, just search @INC normally
3942 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3943 AV * const ar = GvAVn(PL_incgv);
3950 namesv = newSV_type(SVt_PV);
3951 for (i = 0; i <= AvFILL(ar); i++) {
3952 SV * const dirsv = *av_fetch(ar, i, TRUE);
3960 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3961 && !SvOBJECT(SvRV(loader)))
3963 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3967 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
3968 PTR2UV(SvRV(dirsv)), name);
3969 tryname = SvPVX_const(namesv);
3972 if (SvPADTMP(nsv)) {
3973 nsv = sv_newmortal();
3974 SvSetSV_nosteal(nsv,sv);
3977 ENTER_with_name("call_INC");
3985 if (SvGMAGICAL(loader)) {
3986 SV *l = sv_newmortal();
3987 sv_setsv_nomg(l, loader);
3990 if (sv_isobject(loader))
3991 count = call_method("INC", G_ARRAY);
3993 count = call_sv(loader, G_ARRAY);
4003 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
4004 && !isGV_with_GP(SvRV(arg))) {
4005 filter_cache = SvRV(arg);
4012 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
4016 if (isGV_with_GP(arg)) {
4017 IO * const io = GvIO((const GV *)arg);
4022 tryrsfp = IoIFP(io);
4023 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
4024 PerlIO_close(IoOFP(io));
4035 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
4037 SvREFCNT_inc_simple_void_NN(filter_sub);
4040 filter_state = SP[i];
4041 SvREFCNT_inc_simple_void(filter_state);
4045 if (!tryrsfp && (filter_cache || filter_sub)) {
4046 tryrsfp = PerlIO_open(BIT_BUCKET,
4052 /* FREETMPS may free our filter_cache */
4053 SvREFCNT_inc_simple_void(filter_cache);
4057 LEAVE_with_name("call_INC");
4059 /* Now re-mortalize it. */
4060 sv_2mortal(filter_cache);
4062 /* Adjust file name if the hook has set an %INC entry.
4063 This needs to happen after the FREETMPS above. */
4064 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
4066 tryname = SvPV_nolen_const(*svp);
4073 filter_has_file = 0;
4074 filter_cache = NULL;
4076 SvREFCNT_dec_NN(filter_state);
4077 filter_state = NULL;
4080 SvREFCNT_dec_NN(filter_sub);
4084 else if (path_searchable) {
4085 /* match against a plain @INC element (non-searchable
4086 * paths are only matched against refs in @INC) */
4091 dir = SvPV_nomg_const(dirsv, dirlen);
4097 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
4101 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4104 sv_setpv(namesv, unixdir);
4105 sv_catpv(namesv, unixname);
4106 #elif defined(__SYMBIAN32__)
4107 if (PL_origfilename[0] &&
4108 PL_origfilename[1] == ':' &&
4109 !(dir[0] && dir[1] == ':'))
4110 Perl_sv_setpvf(aTHX_ namesv,
4115 Perl_sv_setpvf(aTHX_ namesv,
4119 /* The equivalent of
4120 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4121 but without the need to parse the format string, or
4122 call strlen on either pointer, and with the correct
4123 allocation up front. */
4125 char *tmp = SvGROW(namesv, dirlen + len + 2);
4127 memcpy(tmp, dir, dirlen);
4130 /* Avoid '<dir>//<file>' */
4131 if (!dirlen || *(tmp-1) != '/') {
4134 /* So SvCUR_set reports the correct length below */
4138 /* name came from an SV, so it will have a '\0' at the
4139 end that we can copy as part of this memcpy(). */
4140 memcpy(tmp, name, len + 1);
4142 SvCUR_set(namesv, dirlen + len + 1);
4146 TAINT_PROPER(op_name);
4147 tryname = SvPVX_const(namesv);
4148 tryrsfp = doopen_pm(namesv);
4150 if (tryname[0] == '.' && tryname[1] == '/') {
4152 while (*++tryname == '/') {}
4156 else if (errno == EMFILE || errno == EACCES) {
4157 /* no point in trying other paths if out of handles;
4158 * on the other hand, if we couldn't open one of the
4159 * files, then going on with the search could lead to
4160 * unexpected results; see perl #113422
4169 /* at this point we've ether opened a file (tryrsfp) or set errno */
4171 saved_errno = errno; /* sv_2mortal can realloc things */
4174 /* we failed; croak if require() or return undef if do() */
4175 if (op_is_require) {
4176 if(saved_errno == EMFILE || saved_errno == EACCES) {
4177 /* diag_listed_as: Can't locate %s */
4178 DIE(aTHX_ "Can't locate %s: %s: %s",
4179 name, tryname, Strerror(saved_errno));
4181 if (path_searchable) { /* did we lookup @INC? */
4182 AV * const ar = GvAVn(PL_incgv);
4184 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4185 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4186 for (i = 0; i <= AvFILL(ar); i++) {
4187 sv_catpvs(inc, " ");
4188 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4190 if (memENDPs(name, len, ".pm")) {
4191 const char *e = name + len - (sizeof(".pm") - 1);
4193 bool utf8 = cBOOL(SvUTF8(sv));
4195 /* if the filename, when converted from "Foo/Bar.pm"
4196 * form back to Foo::Bar form, makes a valid
4197 * package name (i.e. parseable by C<require
4198 * Foo::Bar>), then emit a hint.
4200 * this loop is modelled after the one in
4204 if (utf8 && isIDFIRST_utf8_safe(c, e)) {
4206 while (c < e && isIDCONT_utf8_safe(
4207 (const U8*) c, (const U8*) e))
4210 else if (isWORDCHAR_A(*c)) {
4211 while (c < e && isWORDCHAR_A(*c))
4220 if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
4221 sv_catpvs(msg, " (you may need to install the ");
4222 for (c = name; c < e; c++) {
4224 sv_catpvs(msg, "::");
4227 sv_catpvn(msg, c, 1);
4230 sv_catpvs(msg, " module)");
4233 else if (memENDs(name, len, ".h")) {
4234 sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4236 else if (memENDs(name, len, ".ph")) {
4237 sv_catpvs(msg, " (did you run h2ph?)");
4240 /* diag_listed_as: Can't locate %s */
4242 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4246 DIE(aTHX_ "Can't locate %s", name);
4249 #ifdef DEFAULT_INC_EXCLUDES_DOT
4253 /* the complication is to match the logic from doopen_pm() so
4254 * we don't treat do "sda1" as a previously successful "do".
4256 bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED)
4257 && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode)
4258 && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL;
4264 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4265 "do \"%s\" failed, '.' is no longer in @INC; "
4266 "did you mean do \"./%s\"?",
4275 SETERRNO(0, SS_NORMAL);
4277 /* Update %INC. Assume success here to prevent recursive requirement. */
4278 /* name is never assigned to again, so len is still strlen(name) */
4279 /* Check whether a hook in @INC has already filled %INC */
4281 (void)hv_store(GvHVn(PL_incgv),
4282 unixname, unixlen, newSVpv(tryname,0),0);
4284 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4286 (void)hv_store(GvHVn(PL_incgv),
4287 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4290 /* Now parse the file */
4292 old_savestack_ix = PL_savestack_ix;
4293 SAVECOPFILE_FREE(&PL_compiling);
4294 CopFILE_set(&PL_compiling, tryname);
4295 lex_start(NULL, tryrsfp, 0);
4297 if (filter_sub || filter_cache) {
4298 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4299 than hanging another SV from it. In turn, filter_add() optionally
4300 takes the SV to use as the filter (or creates a new SV if passed
4301 NULL), so simply pass in whatever value filter_cache has. */
4302 SV * const fc = filter_cache ? newSV(0) : NULL;
4304 if (fc) sv_copypv(fc, filter_cache);
4305 datasv = filter_add(S_run_user_filter, fc);
4306 IoLINES(datasv) = filter_has_file;
4307 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4308 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4311 /* switch to eval mode */
4313 cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4314 cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4316 SAVECOPLINE(&PL_compiling);
4317 CopLINE_set(&PL_compiling, 0);
4321 if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4324 op = PL_op->op_next;
4326 PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4332 /* also used for: pp_dofile() */
4336 RUN_PP_CATCHABLY(Perl_pp_require);
4343 return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4344 ? S_require_version(aTHX_ sv)
4345 : S_require_file(aTHX_ sv);
4350 /* This is a op added to hold the hints hash for
4351 pp_entereval. The hash can be modified by the code
4352 being eval'ed, so we return a copy instead. */
4357 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4369 char tbuf[TYPE_DIGITS(long) + 12];
4377 I32 old_savestack_ix;
4379 RUN_PP_CATCHABLY(Perl_pp_entereval);
4382 was = PL_breakable_sub_gen;
4383 saved_delete = FALSE;
4387 bytes = PL_op->op_private & OPpEVAL_BYTES;
4389 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4390 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4392 else if (PL_hints & HINT_LOCALIZE_HH || (
4393 PL_op->op_private & OPpEVAL_COPHH
4394 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4396 saved_hh = cop_hints_2hv(PL_curcop, 0);
4397 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4401 /* make sure we've got a plain PV (no overload etc) before testing
4402 * for taint. Making a copy here is probably overkill, but better
4403 * safe than sorry */
4405 const char * const p = SvPV_const(sv, len);
4407 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4408 lex_flags |= LEX_START_COPIED;
4410 if (bytes && SvUTF8(sv))
4411 SvPVbyte_force(sv, len);
4413 else if (bytes && SvUTF8(sv)) {
4414 /* Don't modify someone else's scalar */
4417 (void)sv_2mortal(sv);
4418 SvPVbyte_force(sv,len);
4419 lex_flags |= LEX_START_COPIED;
4422 TAINT_IF(SvTAINTED(sv));
4423 TAINT_PROPER("eval");
4425 old_savestack_ix = PL_savestack_ix;
4427 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4428 ? LEX_IGNORE_UTF8_HINTS
4429 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4433 /* switch to eval mode */
4435 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4436 SV * const temp_sv = sv_newmortal();
4437 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]",
4438 (unsigned long)++PL_evalseq,
4439 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4440 tmpbuf = SvPVX(temp_sv);
4441 len = SvCUR(temp_sv);
4444 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4445 SAVECOPFILE_FREE(&PL_compiling);
4446 CopFILE_set(&PL_compiling, tmpbuf+2);
4447 SAVECOPLINE(&PL_compiling);
4448 CopLINE_set(&PL_compiling, 1);
4449 /* special case: an eval '' executed within the DB package gets lexically
4450 * placed in the first non-DB CV rather than the current CV - this
4451 * allows the debugger to execute code, find lexicals etc, in the
4452 * scope of the code being debugged. Passing &seq gets find_runcv
4453 * to do the dirty work for us */
4454 runcv = find_runcv(&seq);
4457 cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
4458 cx_pusheval(cx, PL_op->op_next, NULL);
4460 /* prepare to compile string */
4462 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4463 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4465 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4466 deleting the eval's FILEGV from the stash before gv_check() runs
4467 (i.e. before run-time proper). To work around the coredump that
4468 ensues, we always turn GvMULTI_on for any globals that were
4469 introduced within evals. See force_ident(). GSAR 96-10-12 */
4470 char *const safestr = savepvn(tmpbuf, len);
4471 SAVEDELETE(PL_defstash, safestr, len);
4472 saved_delete = TRUE;
4477 if (doeval_compile(gimme, runcv, seq, saved_hh)) {
4478 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4479 ? PERLDB_LINE_OR_SAVESRC
4480 : PERLDB_SAVESRC_NOSUBS) {
4481 /* Retain the filegv we created. */
4482 } else if (!saved_delete) {
4483 char *const safestr = savepvn(tmpbuf, len);
4484 SAVEDELETE(PL_defstash, safestr, len);
4486 return PL_eval_start;
4488 /* We have already left the scope set up earlier thanks to the LEAVE
4489 in doeval_compile(). */
4490 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4491 ? PERLDB_LINE_OR_SAVESRC
4492 : PERLDB_SAVESRC_INVALID) {
4493 /* Retain the filegv we created. */
4494 } else if (!saved_delete) {
4495 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4497 return PL_op->op_next;
4502 /* also tail-called by pp_return */
4517 assert(CxTYPE(cx) == CXt_EVAL);
4519 oldsp = PL_stack_base + cx->blk_oldsp;
4520 gimme = cx->blk_gimme;
4522 /* did require return a false value? */
4523 failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE
4524 && !(gimme == G_SCALAR
4525 ? SvTRUE_NN(*PL_stack_sp)
4526 : PL_stack_sp > oldsp);
4528 if (gimme == G_VOID) {
4529 PL_stack_sp = oldsp;
4530 /* free now to avoid late-called destructors clobbering $@ */
4534 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4536 /* the cx_popeval does a leavescope, which frees the optree associated
4537 * with eval, which if it frees the nextstate associated with
4538 * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
4539 * regex when running under 'use re Debug' because it needs PL_curcop
4540 * to get the current hints. So restore it early.
4542 PL_curcop = cx->blk_oldcop;
4544 /* grab this value before cx_popeval restores the old PL_in_eval */
4545 keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4546 retop = cx->blk_eval.retop;
4547 evalcv = cx->blk_eval.cv;
4549 assert(CvDEPTH(evalcv) == 1);
4551 CvDEPTH(evalcv) = 0;
4553 /* pop the CXt_EVAL, and if a require failed, croak */
4554 S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
4562 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4563 close to the related Perl_create_eval_scope. */
4565 Perl_delete_eval_scope(pTHX)
4576 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4577 also needed by Perl_fold_constants. */
4579 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
4582 const U8 gimme = GIMME_V;
4584 cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
4585 PL_stack_sp, PL_savestack_ix);
4586 cx_pusheval(cx, retop, NULL);
4588 PL_in_eval = EVAL_INEVAL;
4589 if (flags & G_KEEPERR)
4590 PL_in_eval |= EVAL_KEEPERR;
4593 if (flags & G_FAKINGEVAL) {
4594 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4600 RUN_PP_CATCHABLY(Perl_pp_entertry);
4603 create_eval_scope(cLOGOP->op_other->op_next, 0);
4604 return PL_op->op_next;
4608 /* also tail-called by pp_return */
4620 assert(CxTYPE(cx) == CXt_EVAL);
4621 oldsp = PL_stack_base + cx->blk_oldsp;
4622 gimme = cx->blk_gimme;
4624 if (gimme == G_VOID) {
4625 PL_stack_sp = oldsp;
4626 /* free now to avoid late-called destructors clobbering $@ */
4630 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4634 retop = cx->blk_eval.retop;
4645 const U8 gimme = GIMME_V;
4649 assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4650 GvSV(PL_defgv) = SvREFCNT_inc(newsv);
4652 cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
4653 cx_pushgiven(cx, origsv);
4663 PERL_UNUSED_CONTEXT;
4666 assert(CxTYPE(cx) == CXt_GIVEN);
4667 oldsp = PL_stack_base + cx->blk_oldsp;
4668 gimme = cx->blk_gimme;
4670 if (gimme == G_VOID)
4671 PL_stack_sp = oldsp;
4673 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4683 /* Helper routines used by pp_smartmatch */
4685 S_make_matcher(pTHX_ REGEXP *re)
4687 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4689 PERL_ARGS_ASSERT_MAKE_MATCHER;
4691 PM_SETRE(matcher, ReREFCNT_inc(re));
4693 SAVEFREEOP((OP *) matcher);
4694 ENTER_with_name("matcher"); SAVETMPS;
4700 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4705 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4707 PL_op = (OP *) matcher;
4710 (void) Perl_pp_match(aTHX);
4712 result = SvTRUEx(POPs);
4719 S_destroy_matcher(pTHX_ PMOP *matcher)
4721 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4722 PERL_UNUSED_ARG(matcher);
4725 LEAVE_with_name("matcher");
4728 /* Do a smart match */
4731 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4732 return do_smartmatch(NULL, NULL, 0);
4735 /* This version of do_smartmatch() implements the
4736 * table of smart matches that is found in perlsyn.
4739 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4743 bool object_on_left = FALSE;
4744 SV *e = TOPs; /* e is for 'expression' */
4745 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4747 /* Take care only to invoke mg_get() once for each argument.
4748 * Currently we do this by copying the SV if it's magical. */
4750 if (!copied && SvGMAGICAL(d))
4751 d = sv_mortalcopy(d);
4758 e = sv_mortalcopy(e);
4760 /* First of all, handle overload magic of the rightmost argument */
4763 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4764 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4766 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4773 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4776 SP -= 2; /* Pop the values */
4781 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4788 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4789 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4790 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4792 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4793 object_on_left = TRUE;
4796 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4798 if (object_on_left) {
4799 goto sm_any_sub; /* Treat objects like scalars */
4801 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4802 /* Test sub truth for each key */
4804 bool andedresults = TRUE;
4805 HV *hv = (HV*) SvRV(d);
4806 I32 numkeys = hv_iterinit(hv);
4807 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4810 while ( (he = hv_iternext(hv)) ) {
4811 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4812 ENTER_with_name("smartmatch_hash_key_test");
4815 PUSHs(hv_iterkeysv(he));
4817 c = call_sv(e, G_SCALAR);
4820 andedresults = FALSE;
4822 andedresults = SvTRUEx(POPs) && andedresults;
4824 LEAVE_with_name("smartmatch_hash_key_test");
4831 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4832 /* Test sub truth for each element */
4834 bool andedresults = TRUE;
4835 AV *av = (AV*) SvRV(d);
4836 const I32 len = av_tindex(av);
4837 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4840 for (i = 0; i <= len; ++i) {
4841 SV * const * const svp = av_fetch(av, i, FALSE);
4842 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4843 ENTER_with_name("smartmatch_array_elem_test");
4849 c = call_sv(e, G_SCALAR);
4852 andedresults = FALSE;
4854 andedresults = SvTRUEx(POPs) && andedresults;
4856 LEAVE_with_name("smartmatch_array_elem_test");
4865 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4866 ENTER_with_name("smartmatch_coderef");
4871 c = call_sv(e, G_SCALAR);
4875 else if (SvTEMP(TOPs))
4876 SvREFCNT_inc_void(TOPs);
4878 LEAVE_with_name("smartmatch_coderef");
4883 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4884 if (object_on_left) {
4885 goto sm_any_hash; /* Treat objects like scalars */
4887 else if (!SvOK(d)) {
4888 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4891 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4892 /* Check that the key-sets are identical */
4894 HV *other_hv = MUTABLE_HV(SvRV(d));
4897 U32 this_key_count = 0,
4898 other_key_count = 0;
4899 HV *hv = MUTABLE_HV(SvRV(e));
4901 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4902 /* Tied hashes don't know how many keys they have. */
4903 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4904 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4908 HV * const temp = other_hv;
4914 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4918 /* The hashes have the same number of keys, so it suffices
4919 to check that one is a subset of the other. */
4920 (void) hv_iterinit(hv);
4921 while ( (he = hv_iternext(hv)) ) {
4922 SV *key = hv_iterkeysv(he);
4924 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4927 if(!hv_exists_ent(other_hv, key, 0)) {
4928 (void) hv_iterinit(hv); /* reset iterator */
4934 (void) hv_iterinit(other_hv);
4935 while ( hv_iternext(other_hv) )
4939 other_key_count = HvUSEDKEYS(other_hv);
4941 if (this_key_count != other_key_count)
4946 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4947 AV * const other_av = MUTABLE_AV(SvRV(d));
4948 const SSize_t other_len = av_tindex(other_av) + 1;
4950 HV *hv = MUTABLE_HV(SvRV(e));
4952 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4953 for (i = 0; i < other_len; ++i) {
4954 SV ** const svp = av_fetch(other_av, i, FALSE);
4955 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4956 if (svp) { /* ??? When can this not happen? */
4957 if (hv_exists_ent(hv, *svp, 0))
4963 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4964 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4967 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4969 HV *hv = MUTABLE_HV(SvRV(e));
4971 (void) hv_iterinit(hv);
4972 while ( (he = hv_iternext(hv)) ) {
4973 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4975 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4977 (void) hv_iterinit(hv);
4978 destroy_matcher(matcher);
4983 destroy_matcher(matcher);
4989 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4990 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4997 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4998 if (object_on_left) {
4999 goto sm_any_array; /* Treat objects like scalars */
5001 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5002 AV * const other_av = MUTABLE_AV(SvRV(e));
5003 const SSize_t other_len = av_tindex(other_av) + 1;
5006 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
5007 for (i = 0; i < other_len; ++i) {
5008 SV ** const svp = av_fetch(other_av, i, FALSE);
5010 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
5011 if (svp) { /* ??? When can this not happen? */
5012 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
5018 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5019 AV *other_av = MUTABLE_AV(SvRV(d));
5020 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
5021 if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
5025 const SSize_t other_len = av_tindex(other_av);
5027 if (NULL == seen_this) {
5028 seen_this = newHV();
5029 (void) sv_2mortal(MUTABLE_SV(seen_this));
5031 if (NULL == seen_other) {
5032 seen_other = newHV();
5033 (void) sv_2mortal(MUTABLE_SV(seen_other));
5035 for(i = 0; i <= other_len; ++i) {
5036 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5037 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
5039 if (!this_elem || !other_elem) {
5040 if ((this_elem && SvOK(*this_elem))
5041 || (other_elem && SvOK(*other_elem)))
5044 else if (hv_exists_ent(seen_this,
5045 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
5046 hv_exists_ent(seen_other,
5047 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
5049 if (*this_elem != *other_elem)
5053 (void)hv_store_ent(seen_this,
5054 sv_2mortal(newSViv(PTR2IV(*this_elem))),
5056 (void)hv_store_ent(seen_other,
5057 sv_2mortal(newSViv(PTR2IV(*other_elem))),
5063 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
5064 (void) do_smartmatch(seen_this, seen_other, 0);
5066 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
5075 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
5076 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
5079 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
5080 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5083 for(i = 0; i <= this_len; ++i) {
5084 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5085 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
5087 if (svp && matcher_matches_sv(matcher, *svp)) {
5089 destroy_matcher(matcher);
5094 destroy_matcher(matcher);
5098 else if (!SvOK(d)) {
5099 /* undef ~~ array */
5100 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5103 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
5104 for (i = 0; i <= this_len; ++i) {
5105 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5106 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
5107 if (!svp || !SvOK(*svp))
5116 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5118 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
5119 for (i = 0; i <= this_len; ++i) {
5120 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5127 /* infinite recursion isn't supposed to happen here */
5128 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
5129 (void) do_smartmatch(NULL, NULL, 1);
5131 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
5140 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
5141 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5142 SV *t = d; d = e; e = t;
5143 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
5146 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5147 SV *t = d; d = e; e = t;
5148 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
5149 goto sm_regex_array;
5152 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
5155 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
5157 result = matcher_matches_sv(matcher, d);
5159 PUSHs(result ? &PL_sv_yes : &PL_sv_no);
5160 destroy_matcher(matcher);
5165 /* See if there is overload magic on left */
5166 else if (object_on_left && SvAMAGIC(d)) {
5168 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
5169 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
5172 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
5180 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
5183 else if (!SvOK(d)) {
5184 /* undef ~~ scalar ; we already know that the scalar is SvOK */
5185 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
5190 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
5191 DEBUG_M(if (SvNIOK(e))
5192 Perl_deb(aTHX_ " applying rule Any-Num\n");
5194 Perl_deb(aTHX_ " applying rule Num-numish\n");
5196 /* numeric comparison */
5199 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
5200 (void) Perl_pp_i_eq(aTHX);
5202 (void) Perl_pp_eq(aTHX);
5210 /* As a last resort, use string comparison */
5211 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
5214 return Perl_pp_seq(aTHX);
5221 const U8 gimme = GIMME_V;
5223 /* This is essentially an optimization: if the match
5224 fails, we don't want to push a context and then
5225 pop it again right away, so we skip straight
5226 to the op that follows the leavewhen.
5227 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5229 if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) {
5230 if (gimme == G_SCALAR)
5231 PUSHs(&PL_sv_undef);
5232 RETURNOP(cLOGOP->op_other->op_next);
5235 cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
5249 assert(CxTYPE(cx) == CXt_WHEN);
5250 gimme = cx->blk_gimme;
5252 cxix = dopoptogivenfor(cxstack_ix);
5254 /* diag_listed_as: Can't "when" outside a topicalizer */
5255 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5256 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5258 oldsp = PL_stack_base + cx->blk_oldsp;
5259 if (gimme == G_VOID)
5260 PL_stack_sp = oldsp;
5262 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5264 /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
5265 assert(cxix < cxstack_ix);
5268 cx = &cxstack[cxix];
5270 if (CxFOREACH(cx)) {
5271 /* emulate pp_next. Note that any stack(s) cleanup will be
5272 * done by the pp_unstack which op_nextop should point to */
5275 PL_curcop = cx->blk_oldcop;
5276 return cx->blk_loop.my_op->op_nextop;
5280 assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
5281 return cx->blk_givwhen.leave_op;
5291 cxix = dopoptowhen(cxstack_ix);
5293 DIE(aTHX_ "Can't \"continue\" outside a when block");
5295 if (cxix < cxstack_ix)
5299 assert(CxTYPE(cx) == CXt_WHEN);
5300 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5304 nextop = cx->blk_givwhen.leave_op->op_next;
5315 cxix = dopoptogivenfor(cxstack_ix);
5317 DIE(aTHX_ "Can't \"break\" outside a given block");
5319 cx = &cxstack[cxix];
5321 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5323 if (cxix < cxstack_ix)
5326 /* Restore the sp at the time we entered the given block */
5328 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5330 return cx->blk_givwhen.leave_op;
5334 S_doparseform(pTHX_ SV *sv)
5337 char *s = SvPV(sv, len);
5339 char *base = NULL; /* start of current field */
5340 I32 skipspaces = 0; /* number of contiguous spaces seen */
5341 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5342 bool repeat = FALSE; /* ~~ seen on this line */
5343 bool postspace = FALSE; /* a text field may need right padding */
5346 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5348 bool ischop; /* it's a ^ rather than a @ */
5349 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5350 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5354 PERL_ARGS_ASSERT_DOPARSEFORM;
5357 Perl_croak(aTHX_ "Null picture in formline");
5359 if (SvTYPE(sv) >= SVt_PVMG) {
5360 /* This might, of course, still return NULL. */
5361 mg = mg_find(sv, PERL_MAGIC_fm);
5363 sv_upgrade(sv, SVt_PVMG);
5367 /* still the same as previously-compiled string? */
5368 SV *old = mg->mg_obj;
5369 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5370 && len == SvCUR(old)
5371 && strnEQ(SvPVX(old), s, len)
5373 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5377 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5378 Safefree(mg->mg_ptr);
5384 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5385 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5388 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5389 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5393 /* estimate the buffer size needed */
5394 for (base = s; s <= send; s++) {
5395 if (*s == '\n' || *s == '@' || *s == '^')
5401 Newx(fops, maxops, U32);
5406 *fpc++ = FF_LINEMARK;
5407 noblank = repeat = FALSE;
5425 case ' ': case '\t':
5441 *fpc++ = FF_LITERAL;
5449 *fpc++ = (U32)skipspaces;
5453 *fpc++ = FF_NEWLINE;
5457 arg = fpc - linepc + 1;
5464 *fpc++ = FF_LINEMARK;
5465 noblank = repeat = FALSE;
5474 ischop = s[-1] == '^';
5480 arg = (s - base) - 1;
5482 *fpc++ = FF_LITERAL;
5488 if (*s == '*') { /* @* or ^* */
5490 *fpc++ = 2; /* skip the @* or ^* */
5492 *fpc++ = FF_LINESNGL;
5495 *fpc++ = FF_LINEGLOB;
5497 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5498 arg = ischop ? FORM_NUM_BLANK : 0;
5503 const char * const f = ++s;
5506 arg |= FORM_NUM_POINT + (s - f);
5508 *fpc++ = s - base; /* fieldsize for FETCH */
5509 *fpc++ = FF_DECIMAL;
5511 unchopnum |= ! ischop;
5513 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5514 arg = ischop ? FORM_NUM_BLANK : 0;
5516 s++; /* skip the '0' first */
5520 const char * const f = ++s;
5523 arg |= FORM_NUM_POINT + (s - f);
5525 *fpc++ = s - base; /* fieldsize for FETCH */
5526 *fpc++ = FF_0DECIMAL;
5528 unchopnum |= ! ischop;
5530 else { /* text field */
5532 bool ismore = FALSE;
5535 while (*++s == '>') ;
5536 prespace = FF_SPACE;
5538 else if (*s == '|') {
5539 while (*++s == '|') ;
5540 prespace = FF_HALFSPACE;
5545 while (*++s == '<') ;
5548 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5552 *fpc++ = s - base; /* fieldsize for FETCH */
5554 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5557 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5571 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5574 mg->mg_ptr = (char *) fops;
5575 mg->mg_len = arg * sizeof(U32);
5576 mg->mg_obj = sv_copy;
5577 mg->mg_flags |= MGf_REFCOUNTED;
5579 if (unchopnum && repeat)
5580 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5587 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5589 /* Can value be printed in fldsize chars, using %*.*f ? */
5593 int intsize = fldsize - (value < 0 ? 1 : 0);
5595 if (frcsize & FORM_NUM_POINT)
5597 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5600 while (intsize--) pwr *= 10.0;
5601 while (frcsize--) eps /= 10.0;
5604 if (value + eps >= pwr)
5607 if (value - eps <= -pwr)
5614 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5616 SV * const datasv = FILTER_DATA(idx);
5617 const int filter_has_file = IoLINES(datasv);
5618 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5619 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5624 char *prune_from = NULL;
5625 bool read_from_cache = FALSE;
5629 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5631 assert(maxlen >= 0);
5634 /* I was having segfault trouble under Linux 2.2.5 after a
5635 parse error occurred. (Had to hack around it with a test
5636 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5637 not sure where the trouble is yet. XXX */
5640 SV *const cache = datasv;
5643 const char *cache_p = SvPV(cache, cache_len);
5647 /* Running in block mode and we have some cached data already.
5649 if (cache_len >= umaxlen) {
5650 /* In fact, so much data we don't even need to call
5655 const char *const first_nl =
5656 (const char *)memchr(cache_p, '\n', cache_len);
5658 take = first_nl + 1 - cache_p;
5662 sv_catpvn(buf_sv, cache_p, take);
5663 sv_chop(cache, cache_p + take);
5664 /* Definitely not EOF */
5668 sv_catsv(buf_sv, cache);
5670 umaxlen -= cache_len;
5673 read_from_cache = TRUE;
5677 /* Filter API says that the filter appends to the contents of the buffer.
5678 Usually the buffer is "", so the details don't matter. But if it's not,
5679 then clearly what it contains is already filtered by this filter, so we
5680 don't want to pass it in a second time.
5681 I'm going to use a mortal in case the upstream filter croaks. */
5682 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5683 ? sv_newmortal() : buf_sv;
5684 SvUPGRADE(upstream, SVt_PV);
5686 if (filter_has_file) {
5687 status = FILTER_READ(idx+1, upstream, 0);
5690 if (filter_sub && status >= 0) {
5694 ENTER_with_name("call_filter_sub");
5699 DEFSV_set(upstream);
5703 PUSHs(filter_state);
5706 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5716 SV * const errsv = ERRSV;
5717 if (SvTRUE_NN(errsv))
5718 err = newSVsv(errsv);
5724 LEAVE_with_name("call_filter_sub");
5727 if (SvGMAGICAL(upstream)) {
5729 if (upstream == buf_sv) mg_free(buf_sv);
5731 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5732 if(!err && SvOK(upstream)) {
5733 got_p = SvPV_nomg(upstream, got_len);
5735 if (got_len > umaxlen) {
5736 prune_from = got_p + umaxlen;
5739 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5740 if (first_nl && first_nl + 1 < got_p + got_len) {
5741 /* There's a second line here... */
5742 prune_from = first_nl + 1;
5746 if (!err && prune_from) {
5747 /* Oh. Too long. Stuff some in our cache. */
5748 STRLEN cached_len = got_p + got_len - prune_from;
5749 SV *const cache = datasv;
5752 /* Cache should be empty. */
5753 assert(!SvCUR(cache));
5756 sv_setpvn(cache, prune_from, cached_len);
5757 /* If you ask for block mode, you may well split UTF-8 characters.
5758 "If it breaks, you get to keep both parts"
5759 (Your code is broken if you don't put them back together again
5760 before something notices.) */
5761 if (SvUTF8(upstream)) {
5764 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5766 /* Cannot just use sv_setpvn, as that could free the buffer
5767 before we have a chance to assign it. */
5768 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5769 got_len - cached_len);
5771 /* Can't yet be EOF */
5776 /* If they are at EOF but buf_sv has something in it, then they may never
5777 have touched the SV upstream, so it may be undefined. If we naively
5778 concatenate it then we get a warning about use of uninitialised value.
5780 if (!err && upstream != buf_sv &&
5782 sv_catsv_nomg(buf_sv, upstream);
5784 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5787 IoLINES(datasv) = 0;
5789 SvREFCNT_dec(filter_state);
5790 IoTOP_GV(datasv) = NULL;
5793 SvREFCNT_dec(filter_sub);
5794 IoBOTTOM_GV(datasv) = NULL;
5796 filter_del(S_run_user_filter);
5802 if (status == 0 && read_from_cache) {
5803 /* If we read some data from the cache (and by getting here it implies
5804 that we emptied the cache) then we aren't yet at EOF, and mustn't
5805 report that to our caller. */
5812 * ex: set ts=8 sts=4 sw=4 et: