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
784 s += UTF8_SAFE_SKIP(s,
785 (U8 *) SvEND(PL_formtarget));
786 linemark = s - (U8*)SvPVX(PL_formtarget);
788 /* Easy. They agree. */
789 assert (item_is_utf8 == targ_is_utf8);
792 /* @* and ^* are the only things that can exceed
793 * the linemax, so grow by the output size, plus
794 * a whole new form's worth in case of any further
796 grow = linemax + to_copy;
798 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
799 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
801 Copy(source, t, to_copy, char);
803 /* blank out ~ or control chars, depending on trans.
804 * works on bytes not chars, so relies on not
805 * matching utf8 continuation bytes */
807 U8 *send = s + to_copy;
810 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
817 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
823 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
826 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
829 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
832 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
834 /* If the field is marked with ^ and the value is undefined,
836 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
844 /* overflow evidence */
845 if (num_overflow(value, fieldsize, arg)) {
851 /* Formats aren't yet marked for locales, so assume "yes". */
853 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
855 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
856 STORE_LC_NUMERIC_SET_TO_NEEDED();
857 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
860 const char* qfmt = quadmath_format_single(fmt);
863 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
864 len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
866 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
871 /* we generate fmt ourselves so it is safe */
872 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
873 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
874 GCC_DIAG_RESTORE_STMT;
876 PERL_MY_SNPRINTF_POST_GUARD(len, max);
877 RESTORE_LC_NUMERIC();
882 case FF_NEWLINE: /* delete trailing spaces, then append \n */
884 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
889 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
892 if (arg) { /* repeat until fields exhausted? */
898 t = SvPVX(PL_formtarget) + linemark;
903 case FF_MORE: /* replace long end of string with '...' */
905 const char *s = chophere;
906 const char *send = item + len;
908 while (isSPACE(*s) && (s < send))
913 arg = fieldsize - itemsize;
920 if (strBEGINs(s1," ")) {
921 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
931 case FF_END: /* tidy up, then return */
933 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
935 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
937 SvUTF8_on(PL_formtarget);
938 FmLINES(PL_formtarget) += lines;
940 if (fpc[-1] == FF_BLANK)
941 RETURNOP(cLISTOP->op_first);
948 /* also used for: pp_mapstart() */
954 if (PL_stack_base + TOPMARK == SP) {
956 if (GIMME_V == G_SCALAR)
958 RETURNOP(PL_op->op_next->op_next);
960 PL_stack_sp = PL_stack_base + TOPMARK + 1;
961 Perl_pp_pushmark(aTHX); /* push dst */
962 Perl_pp_pushmark(aTHX); /* push src */
963 ENTER_with_name("grep"); /* enter outer scope */
967 ENTER_with_name("grep_item"); /* enter inner scope */
970 src = PL_stack_base[TOPMARK];
972 src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
979 if (PL_op->op_type == OP_MAPSTART)
980 Perl_pp_pushmark(aTHX); /* push top */
981 return ((LOGOP*)PL_op->op_next)->op_other;
987 const U8 gimme = GIMME_V;
988 I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
994 /* first, move source pointer to the next item in the source list */
995 ++PL_markstack_ptr[-1];
997 /* if there are new items, push them into the destination list */
998 if (items && gimme != G_VOID) {
999 /* might need to make room back there first */
1000 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1001 /* XXX this implementation is very pessimal because the stack
1002 * is repeatedly extended for every set of items. Is possible
1003 * to do this without any stack extension or copying at all
1004 * by maintaining a separate list over which the map iterates
1005 * (like foreach does). --gsar */
1007 /* everything in the stack after the destination list moves
1008 * towards the end the stack by the amount of room needed */
1009 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1011 /* items to shift up (accounting for the moved source pointer) */
1012 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1014 /* This optimization is by Ben Tilly and it does
1015 * things differently from what Sarathy (gsar)
1016 * is describing. The downside of this optimization is
1017 * that leaves "holes" (uninitialized and hopefully unused areas)
1018 * to the Perl stack, but on the other hand this
1019 * shouldn't be a problem. If Sarathy's idea gets
1020 * implemented, this optimization should become
1021 * irrelevant. --jhi */
1023 shift = count; /* Avoid shifting too often --Ben Tilly */
1027 dst = (SP += shift);
1028 PL_markstack_ptr[-1] += shift;
1029 *PL_markstack_ptr += shift;
1033 /* copy the new items down to the destination list */
1034 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1035 if (gimme == G_ARRAY) {
1036 /* add returned items to the collection (making mortal copies
1037 * if necessary), then clear the current temps stack frame
1038 * *except* for those items. We do this splicing the items
1039 * into the start of the tmps frame (so some items may be on
1040 * the tmps stack twice), then moving PL_tmps_floor above
1041 * them, then freeing the frame. That way, the only tmps that
1042 * accumulate over iterations are the return values for map.
1043 * We have to do to this way so that everything gets correctly
1044 * freed if we die during the map.
1048 /* make space for the slice */
1049 EXTEND_MORTAL(items);
1050 tmpsbase = PL_tmps_floor + 1;
1051 Move(PL_tmps_stack + tmpsbase,
1052 PL_tmps_stack + tmpsbase + items,
1053 PL_tmps_ix - PL_tmps_floor,
1055 PL_tmps_ix += items;
1060 sv = sv_mortalcopy(sv);
1062 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1064 /* clear the stack frame except for the items */
1065 PL_tmps_floor += items;
1067 /* FREETMPS may have cleared the TEMP flag on some of the items */
1070 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1073 /* scalar context: we don't care about which values map returns
1074 * (we use undef here). And so we certainly don't want to do mortal
1075 * copies of meaningless values. */
1076 while (items-- > 0) {
1078 *dst-- = &PL_sv_undef;
1086 LEAVE_with_name("grep_item"); /* exit inner scope */
1089 if (PL_markstack_ptr[-1] > TOPMARK) {
1091 (void)POPMARK; /* pop top */
1092 LEAVE_with_name("grep"); /* exit outer scope */
1093 (void)POPMARK; /* pop src */
1094 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1095 (void)POPMARK; /* pop dst */
1096 SP = PL_stack_base + POPMARK; /* pop original mark */
1097 if (gimme == G_SCALAR) {
1101 else if (gimme == G_ARRAY)
1108 ENTER_with_name("grep_item"); /* enter inner scope */
1111 /* set $_ to the new source item */
1112 src = PL_stack_base[PL_markstack_ptr[-1]];
1113 if (SvPADTMP(src)) {
1114 src = sv_mortalcopy(src);
1119 RETURNOP(cLOGOP->op_other);
1128 if (GIMME_V == G_ARRAY)
1131 if (SvTRUE_NN(targ))
1132 return cLOGOP->op_other;
1141 if (GIMME_V == G_ARRAY) {
1142 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1146 SV * const targ = PAD_SV(PL_op->op_targ);
1149 if (PL_op->op_private & OPpFLIP_LINENUM) {
1150 if (GvIO(PL_last_in_gv)) {
1151 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1154 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1156 flip = SvIV(sv) == SvIV(GvSV(gv));
1159 flip = SvTRUE_NN(sv);
1162 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1163 if (PL_op->op_flags & OPf_SPECIAL) {
1171 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1180 /* This code tries to decide if "$left .. $right" should use the
1181 magical string increment, or if the range is numeric (we make
1182 an exception for .."0" [#18165]). AMS 20021031. */
1184 #define RANGE_IS_NUMERIC(left,right) ( \
1185 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1186 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1187 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1188 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1189 && (!SvOK(right) || looks_like_number(right))))
1195 if (GIMME_V == G_ARRAY) {
1201 if (RANGE_IS_NUMERIC(left,right)) {
1203 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1204 (SvOK(right) && (SvIOK(right)
1205 ? SvIsUV(right) && SvUV(right) > IV_MAX
1206 : SvNV_nomg(right) > IV_MAX)))
1207 DIE(aTHX_ "Range iterator outside integer range");
1208 i = SvIV_nomg(left);
1209 j = SvIV_nomg(right);
1211 /* Dance carefully around signed max. */
1212 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1215 /* The wraparound of signed integers is undefined
1216 * behavior, but here we aim for count >=1, and
1217 * negative count is just wrong. */
1219 #if IVSIZE > Size_t_size
1226 Perl_croak(aTHX_ "Out of memory during list extend");
1233 SV * const sv = sv_2mortal(newSViv(i));
1235 if (n) /* avoid incrementing above IV_MAX */
1241 const char * const lpv = SvPV_nomg_const(left, llen);
1242 const char * const tmps = SvPV_nomg_const(right, len);
1244 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1245 if (DO_UTF8(right) && IN_UNI_8_BIT)
1246 len = sv_len_utf8_nomg(right);
1247 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1249 if (strEQ(SvPVX_const(sv),tmps))
1251 sv = sv_2mortal(newSVsv(sv));
1258 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1262 if (PL_op->op_private & OPpFLIP_LINENUM) {
1263 if (GvIO(PL_last_in_gv)) {
1264 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1267 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1268 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1272 flop = SvTRUE_NN(sv);
1276 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1277 sv_catpvs(targ, "E0");
1287 static const char * const context_name[] = {
1289 NULL, /* CXt_WHEN never actually needs "block" */
1290 NULL, /* CXt_BLOCK never actually needs "block" */
1291 NULL, /* CXt_GIVEN never actually needs "block" */
1292 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1293 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1294 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1295 NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1296 NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1304 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1308 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1310 for (i = cxstack_ix; i >= 0; i--) {
1311 const PERL_CONTEXT * const cx = &cxstack[i];
1312 switch (CxTYPE(cx)) {
1318 /* diag_listed_as: Exiting subroutine via %s */
1319 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1320 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1321 if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1324 case CXt_LOOP_PLAIN:
1325 case CXt_LOOP_LAZYIV:
1326 case CXt_LOOP_LAZYSV:
1330 STRLEN cx_label_len = 0;
1331 U32 cx_label_flags = 0;
1332 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1334 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1337 (const U8*)cx_label, cx_label_len,
1338 (const U8*)label, len) == 0)
1340 (const U8*)label, len,
1341 (const U8*)cx_label, cx_label_len) == 0)
1342 : (len == cx_label_len && ((cx_label == label)
1343 || memEQ(cx_label, label, len))) )) {
1344 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1345 (long)i, cx_label));
1348 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1359 Perl_dowantarray(pTHX)
1361 const U8 gimme = block_gimme();
1362 return (gimme == G_VOID) ? G_SCALAR : gimme;
1366 Perl_block_gimme(pTHX)
1368 const I32 cxix = dopoptosub(cxstack_ix);
1373 gimme = (cxstack[cxix].blk_gimme & G_WANT);
1375 Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1381 Perl_is_lvalue_sub(pTHX)
1383 const I32 cxix = dopoptosub(cxstack_ix);
1384 assert(cxix >= 0); /* We should only be called from inside subs */
1386 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1387 return CxLVAL(cxstack + cxix);
1392 /* only used by cx_pushsub() */
1394 Perl_was_lvalue_sub(pTHX)
1396 const I32 cxix = dopoptosub(cxstack_ix-1);
1397 assert(cxix >= 0); /* We should only be called from inside subs */
1399 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1400 return CxLVAL(cxstack + cxix);
1406 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1410 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1412 PERL_UNUSED_CONTEXT;
1415 for (i = startingblock; i >= 0; i--) {
1416 const PERL_CONTEXT * const cx = &cxstk[i];
1417 switch (CxTYPE(cx)) {
1421 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1422 * twice; the first for the normal foo() call, and the second
1423 * for a faked up re-entry into the sub to execute the
1424 * code block. Hide this faked entry from the world. */
1425 if (cx->cx_type & CXp_SUB_RE_FAKE)
1430 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1438 S_dopoptoeval(pTHX_ I32 startingblock)
1441 for (i = startingblock; i >= 0; i--) {
1442 const PERL_CONTEXT *cx = &cxstack[i];
1443 switch (CxTYPE(cx)) {
1447 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1455 S_dopoptoloop(pTHX_ I32 startingblock)
1458 for (i = startingblock; i >= 0; i--) {
1459 const PERL_CONTEXT * const cx = &cxstack[i];
1460 switch (CxTYPE(cx)) {
1466 /* diag_listed_as: Exiting subroutine via %s */
1467 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1468 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1469 if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1472 case CXt_LOOP_PLAIN:
1473 case CXt_LOOP_LAZYIV:
1474 case CXt_LOOP_LAZYSV:
1477 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1484 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1487 S_dopoptogivenfor(pTHX_ I32 startingblock)
1490 for (i = startingblock; i >= 0; i--) {
1491 const PERL_CONTEXT *cx = &cxstack[i];
1492 switch (CxTYPE(cx)) {
1496 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1498 case CXt_LOOP_PLAIN:
1499 assert(!(cx->cx_type & CXp_FOR_DEF));
1501 case CXt_LOOP_LAZYIV:
1502 case CXt_LOOP_LAZYSV:
1505 if (cx->cx_type & CXp_FOR_DEF) {
1506 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1515 S_dopoptowhen(pTHX_ I32 startingblock)
1518 for (i = startingblock; i >= 0; i--) {
1519 const PERL_CONTEXT *cx = &cxstack[i];
1520 switch (CxTYPE(cx)) {
1524 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1531 /* dounwind(): pop all contexts above (but not including) cxix.
1532 * Note that it clears the savestack frame associated with each popped
1533 * context entry, but doesn't free any temps.
1534 * It does a cx_popblock() of the last frame that it pops, and leaves
1535 * cxstack_ix equal to cxix.
1539 Perl_dounwind(pTHX_ I32 cxix)
1541 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1544 while (cxstack_ix > cxix) {
1545 PERL_CONTEXT *cx = CX_CUR();
1547 CX_DEBUG(cx, "UNWIND");
1548 /* Note: we don't need to restore the base context info till the end. */
1552 switch (CxTYPE(cx)) {
1555 /* CXt_SUBST is not a block context type, so skip the
1556 * cx_popblock(cx) below */
1557 if (cxstack_ix == cxix + 1) {
1568 case CXt_LOOP_PLAIN:
1569 case CXt_LOOP_LAZYIV:
1570 case CXt_LOOP_LAZYSV:
1583 /* these two don't have a POPFOO() */
1589 if (cxstack_ix == cxix + 1) {
1598 Perl_qerror(pTHX_ SV *err)
1600 PERL_ARGS_ASSERT_QERROR;
1603 if (PL_in_eval & EVAL_KEEPERR) {
1604 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1608 sv_catsv(ERRSV, err);
1611 sv_catsv(PL_errors, err);
1613 Perl_warn(aTHX_ "%" SVf, SVfARG(err));
1615 ++PL_parser->error_count;
1620 /* pop a CXt_EVAL context and in addition, if it was a require then
1622 * 0: do nothing extra;
1623 * 1: undef $INC{$name}; croak "$name did not return a true value";
1624 * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1628 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1630 SV *namesv = NULL; /* init to avoid dumb compiler warning */
1634 do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1636 /* keep namesv alive after cx_popeval() */
1637 namesv = cx->blk_eval.old_namesv;
1638 cx->blk_eval.old_namesv = NULL;
1647 HV *inc_hv = GvHVn(PL_incgv);
1648 I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv);
1649 const char *key = SvPVX_const(namesv);
1652 (void)hv_delete(inc_hv, key, klen, G_DISCARD);
1653 fmt = "%" SVf " did not return a true value";
1657 (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0);
1658 fmt = "%" SVf "Compilation failed in require";
1660 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1663 Perl_croak(aTHX_ fmt, SVfARG(errsv));
1668 /* die_unwind(): this is the final destination for the various croak()
1669 * functions. If we're in an eval, unwind the context and other stacks
1670 * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1671 * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1672 * to is a require the exception will be rethrown, as requires don't
1673 * actually trap exceptions.
1677 Perl_die_unwind(pTHX_ SV *msv)
1680 U8 in_eval = PL_in_eval;
1681 PERL_ARGS_ASSERT_DIE_UNWIND;
1686 /* We need to keep this SV alive through all the stack unwinding
1687 * and FREETMPSing below, while ensuing that it doesn't leak
1688 * if we call out to something which then dies (e.g. sub STORE{die}
1689 * when unlocalising a tied var). So we do a dance with
1690 * mortalising and SAVEFREEing.
1692 sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1695 * Historically, perl used to set ERRSV ($@) early in the die
1696 * process and rely on it not getting clobbered during unwinding.
1697 * That sucked, because it was liable to get clobbered, so the
1698 * setting of ERRSV used to emit the exception from eval{} has
1699 * been moved to much later, after unwinding (see just before
1700 * JMPENV_JUMP below). However, some modules were relying on the
1701 * early setting, by examining $@ during unwinding to use it as
1702 * a flag indicating whether the current unwinding was caused by
1703 * an exception. It was never a reliable flag for that purpose,
1704 * being totally open to false positives even without actual
1705 * clobberage, but was useful enough for production code to
1706 * semantically rely on it.
1708 * We'd like to have a proper introspective interface that
1709 * explicitly describes the reason for whatever unwinding
1710 * operations are currently in progress, so that those modules
1711 * work reliably and $@ isn't further overloaded. But we don't
1712 * have one yet. In its absence, as a stopgap measure, ERRSV is
1713 * now *additionally* set here, before unwinding, to serve as the
1714 * (unreliable) flag that it used to.
1716 * This behaviour is temporary, and should be removed when a
1717 * proper way to detect exceptional unwinding has been developed.
1718 * As of 2010-12, the authors of modules relying on the hack
1719 * are aware of the issue, because the modules failed on
1720 * perls 5.13.{1..7} which had late setting of $@ without this
1721 * early-setting hack.
1723 if (!(in_eval & EVAL_KEEPERR))
1724 sv_setsv_flags(ERRSV, exceptsv,
1725 (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
1727 if (in_eval & EVAL_KEEPERR) {
1728 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1732 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1733 && PL_curstackinfo->si_prev)
1743 JMPENV *restartjmpenv;
1746 if (cxix < cxstack_ix)
1750 assert(CxTYPE(cx) == CXt_EVAL);
1752 /* return false to the caller of eval */
1753 oldsp = PL_stack_base + cx->blk_oldsp;
1754 gimme = cx->blk_gimme;
1755 if (gimme == G_SCALAR)
1756 *++oldsp = &PL_sv_undef;
1757 PL_stack_sp = oldsp;
1759 restartjmpenv = cx->blk_eval.cur_top_env;
1760 restartop = cx->blk_eval.retop;
1762 /* We need a FREETMPS here to avoid late-called destructors
1763 * clobbering $@ *after* we set it below, e.g.
1764 * sub DESTROY { eval { die "X" } }
1765 * eval { my $x = bless []; die $x = 0, "Y" };
1767 * Here the clearing of the $x ref mortalises the anon array,
1768 * which needs to be freed *before* $& is set to "Y",
1769 * otherwise it gets overwritten with "X".
1771 * However, the FREETMPS will clobber exceptsv, so preserve it
1772 * on the savestack for now.
1774 SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv));
1776 /* now we're about to pop the savestack, so re-mortalise it */
1777 sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1779 /* Note that unlike pp_entereval, pp_require isn't supposed to
1780 * trap errors. So if we're a require, after we pop the
1781 * CXt_EVAL that pp_require pushed, rethrow the error with
1782 * croak(exceptsv). This is all handled by the call below when
1785 S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
1787 if (!(in_eval & EVAL_KEEPERR))
1788 sv_setsv(ERRSV, exceptsv);
1789 PL_restartjmpenv = restartjmpenv;
1790 PL_restartop = restartop;
1792 NOT_REACHED; /* NOTREACHED */
1796 write_to_stderr(exceptsv);
1798 NOT_REACHED; /* NOTREACHED */
1804 if (SvTRUE_NN(left) != SvTRUE_NN(right))
1812 =head1 CV Manipulation Functions
1814 =for apidoc caller_cx
1816 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1817 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1818 information returned to Perl by C<caller>. Note that XSUBs don't get a
1819 stack frame, so C<caller_cx(0, NULL)> will return information for the
1820 immediately-surrounding Perl code.
1822 This function skips over the automatic calls to C<&DB::sub> made on the
1823 behalf of the debugger. If the stack frame requested was a sub called by
1824 C<DB::sub>, the return value will be the frame for the call to
1825 C<DB::sub>, since that has the correct line number/etc. for the call
1826 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1827 frame for the sub call itself.
1832 const PERL_CONTEXT *
1833 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1835 I32 cxix = dopoptosub(cxstack_ix);
1836 const PERL_CONTEXT *cx;
1837 const PERL_CONTEXT *ccstack = cxstack;
1838 const PERL_SI *top_si = PL_curstackinfo;
1841 /* we may be in a higher stacklevel, so dig down deeper */
1842 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1843 top_si = top_si->si_prev;
1844 ccstack = top_si->si_cxstack;
1845 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1849 /* caller() should not report the automatic calls to &DB::sub */
1850 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1851 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1855 cxix = dopoptosub_at(ccstack, cxix - 1);
1858 cx = &ccstack[cxix];
1859 if (dbcxp) *dbcxp = cx;
1861 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1862 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1863 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1864 field below is defined for any cx. */
1865 /* caller() should not report the automatic calls to &DB::sub */
1866 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1867 cx = &ccstack[dbcxix];
1876 const PERL_CONTEXT *cx;
1877 const PERL_CONTEXT *dbcx;
1879 const HEK *stash_hek;
1881 bool has_arg = MAXARG && TOPs;
1890 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1892 if (gimme != G_ARRAY) {
1899 CX_DEBUG(cx, "CALLER");
1900 assert(CopSTASH(cx->blk_oldcop));
1901 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1902 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1904 if (gimme != G_ARRAY) {
1907 PUSHs(&PL_sv_undef);
1910 sv_sethek(TARG, stash_hek);
1919 PUSHs(&PL_sv_undef);
1922 sv_sethek(TARG, stash_hek);
1925 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1926 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1927 cx->blk_sub.retop, TRUE);
1929 lcop = cx->blk_oldcop;
1930 mPUSHu(CopLINE(lcop));
1933 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1934 /* So is ccstack[dbcxix]. */
1935 if (CvHASGV(dbcx->blk_sub.cv)) {
1936 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1937 PUSHs(boolSV(CxHASARGS(cx)));
1940 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1941 PUSHs(boolSV(CxHASARGS(cx)));
1945 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1948 gimme = cx->blk_gimme;
1949 if (gimme == G_VOID)
1950 PUSHs(&PL_sv_undef);
1952 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1953 if (CxTYPE(cx) == CXt_EVAL) {
1955 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1956 SV *cur_text = cx->blk_eval.cur_text;
1957 if (SvCUR(cur_text) >= 2) {
1958 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1959 SvUTF8(cur_text)|SVs_TEMP));
1962 /* I think this is will always be "", but be sure */
1963 PUSHs(sv_2mortal(newSVsv(cur_text)));
1969 else if (cx->blk_eval.old_namesv) {
1970 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1973 /* eval BLOCK (try blocks have old_namesv == 0) */
1975 PUSHs(&PL_sv_undef);
1976 PUSHs(&PL_sv_undef);
1980 PUSHs(&PL_sv_undef);
1981 PUSHs(&PL_sv_undef);
1983 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1984 && CopSTASH_eq(PL_curcop, PL_debstash))
1986 /* slot 0 of the pad contains the original @_ */
1987 AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
1988 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1989 cx->blk_sub.olddepth+1]))[0]);
1990 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1992 Perl_init_dbargs(aTHX);
1994 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1995 av_extend(PL_dbargs, AvFILLp(ary) + off);
1996 if (AvFILLp(ary) + 1 + off)
1997 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1998 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
2000 mPUSHi(CopHINTS_get(cx->blk_oldcop));
2003 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
2005 if (old_warnings == pWARN_NONE)
2006 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
2007 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
2008 mask = &PL_sv_undef ;
2009 else if (old_warnings == pWARN_ALL ||
2010 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
2011 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
2014 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
2018 PUSHs(cx->blk_oldcop->cop_hints_hash ?
2019 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2029 if (MAXARG < 1 || (!TOPs && !POPs)) {
2031 tmps = NULL, len = 0;
2034 tmps = SvPVx_const(POPs, len);
2035 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
2040 /* like pp_nextstate, but used instead when the debugger is active */
2044 PL_curcop = (COP*)PL_op;
2045 TAINT_NOT; /* Each statement is presumed innocent */
2046 PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
2051 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2052 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2056 const U8 gimme = G_ARRAY;
2057 GV * const gv = PL_DBgv;
2060 if (gv && isGV_with_GP(gv))
2063 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2064 DIE(aTHX_ "No DB::DB routine defined");
2066 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2067 /* don't do recursive DB::DB call */
2077 (void)(*CvXSUB(cv))(aTHX_ cv);
2083 cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
2084 cx_pushsub(cx, cv, PL_op->op_next, 0);
2085 /* OP_DBSTATE's op_private holds hint bits rather than
2086 * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2087 * any CxLVAL() flags that have now been mis-calculated */
2094 if (CvDEPTH(cv) >= 2)
2095 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2096 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2097 RETURNOP(CvSTART(cv));
2109 (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2121 assert(CxTYPE(cx) == CXt_BLOCK);
2123 if (PL_op->op_flags & OPf_SPECIAL)
2124 /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */
2125 cx->blk_oldpm = PL_curpm;
2127 oldsp = PL_stack_base + cx->blk_oldsp;
2128 gimme = cx->blk_gimme;
2130 if (gimme == G_VOID)
2131 PL_stack_sp = oldsp;
2133 leave_adjust_stacks(oldsp, oldsp, gimme,
2134 PL_op->op_private & OPpLVALUE ? 3 : 1);
2144 S_outside_integer(pTHX_ SV *sv)
2147 const NV nv = SvNV_nomg(sv);
2148 if (Perl_isinfnan(nv))
2150 #ifdef NV_PRESERVES_UV
2151 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2154 if (nv <= (NV)IV_MIN)
2157 ((nv > (NV)UV_MAX ||
2158 SvUV_nomg(sv) > (UV)IV_MAX)))
2169 const U8 gimme = GIMME_V;
2170 void *itervarp; /* GV or pad slot of the iteration variable */
2171 SV *itersave; /* the old var in the iterator var slot */
2174 if (PL_op->op_targ) { /* "my" variable */
2175 itervarp = &PAD_SVl(PL_op->op_targ);
2176 itersave = *(SV**)itervarp;
2178 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2179 /* the SV currently in the pad slot is never live during
2180 * iteration (the slot is always aliased to one of the items)
2181 * so it's always stale */
2182 SvPADSTALE_on(itersave);
2184 SvREFCNT_inc_simple_void_NN(itersave);
2185 cxflags = CXp_FOR_PAD;
2188 SV * const sv = POPs;
2189 itervarp = (void *)sv;
2190 if (LIKELY(isGV(sv))) { /* symbol table variable */
2191 itersave = GvSV(sv);
2192 SvREFCNT_inc_simple_void(itersave);
2193 cxflags = CXp_FOR_GV;
2194 if (PL_op->op_private & OPpITER_DEF)
2195 cxflags |= CXp_FOR_DEF;
2197 else { /* LV ref: for \$foo (...) */
2198 assert(SvTYPE(sv) == SVt_PVMG);
2199 assert(SvMAGIC(sv));
2200 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2202 cxflags = CXp_FOR_LVREF;
2205 /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2206 assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2208 /* Note that this context is initially set as CXt_NULL. Further on
2209 * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2210 * there mustn't be anything in the blk_loop substruct that requires
2211 * freeing or undoing, in case we die in the meantime. And vice-versa.
2213 cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2214 cx_pushloop_for(cx, itervarp, itersave);
2216 if (PL_op->op_flags & OPf_STACKED) {
2217 /* OPf_STACKED implies either a single array: for(@), with a
2218 * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2220 SV *maybe_ary = POPs;
2221 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2224 SV * const right = maybe_ary;
2225 if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2226 DIE(aTHX_ "Assigned value is not a reference");
2229 if (RANGE_IS_NUMERIC(sv,right)) {
2230 cx->cx_type |= CXt_LOOP_LAZYIV;
2231 if (S_outside_integer(aTHX_ sv) ||
2232 S_outside_integer(aTHX_ right))
2233 DIE(aTHX_ "Range iterator outside integer range");
2234 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2235 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2238 cx->cx_type |= CXt_LOOP_LAZYSV;
2239 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2240 cx->blk_loop.state_u.lazysv.end = right;
2241 SvREFCNT_inc_simple_void_NN(right);
2242 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2243 /* This will do the upgrade to SVt_PV, and warn if the value
2244 is uninitialised. */
2245 (void) SvPV_nolen_const(right);
2246 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2247 to replace !SvOK() with a pointer to "". */
2249 SvREFCNT_dec(right);
2250 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2254 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2255 /* for (@array) {} */
2256 cx->cx_type |= CXt_LOOP_ARY;
2257 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2258 SvREFCNT_inc_simple_void_NN(maybe_ary);
2259 cx->blk_loop.state_u.ary.ix =
2260 (PL_op->op_private & OPpITER_REVERSED) ?
2261 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2264 /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
2266 else { /* iterating over items on the stack */
2267 cx->cx_type |= CXt_LOOP_LIST;
2268 cx->blk_oldsp = SP - PL_stack_base;
2269 cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2270 cx->blk_loop.state_u.stack.ix =
2271 (PL_op->op_private & OPpITER_REVERSED)
2273 : cx->blk_loop.state_u.stack.basesp;
2274 /* pre-extend stack so pp_iter doesn't have to check every time
2275 * it pushes yes/no */
2285 const U8 gimme = GIMME_V;
2287 cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2288 cx_pushloop_plain(cx);
2301 assert(CxTYPE_is_LOOP(cx));
2302 oldsp = PL_stack_base + cx->blk_oldsp;
2303 base = CxTYPE(cx) == CXt_LOOP_LIST
2304 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2306 gimme = cx->blk_gimme;
2308 if (gimme == G_VOID)
2311 leave_adjust_stacks(oldsp, base, gimme,
2312 PL_op->op_private & OPpLVALUE ? 3 : 1);
2315 cx_poploop(cx); /* Stack values are safe: release loop vars ... */
2323 /* This duplicates most of pp_leavesub, but with additional code to handle
2324 * return args in lvalue context. It was forked from pp_leavesub to
2325 * avoid slowing down that function any further.
2327 * Any changes made to this function may need to be copied to pp_leavesub
2330 * also tail-called by pp_return
2341 assert(CxTYPE(cx) == CXt_SUB);
2343 if (CxMULTICALL(cx)) {
2344 /* entry zero of a stack is always PL_sv_undef, which
2345 * simplifies converting a '()' return into undef in scalar context */
2346 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2350 gimme = cx->blk_gimme;
2351 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2353 if (gimme == G_VOID)
2354 PL_stack_sp = oldsp;
2356 U8 lval = CxLVAL(cx);
2357 bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2358 const char *what = NULL;
2360 if (gimme == G_SCALAR) {
2362 /* check for bad return arg */
2363 if (oldsp < PL_stack_sp) {
2364 SV *sv = *PL_stack_sp;
2365 if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2367 SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2368 : "a readonly value" : "a temporary";
2373 /* sub:lvalue{} will take us here. */
2378 "Can't return %s from lvalue subroutine", what);
2382 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2384 if (lval & OPpDEREF) {
2385 /* lval_sub()->{...} and similar */
2389 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2395 assert(gimme == G_ARRAY);
2396 assert (!(lval & OPpDEREF));
2399 /* scan for bad return args */
2401 for (p = PL_stack_sp; p > oldsp; p--) {
2403 /* the PL_sv_undef exception is to allow things like
2404 * this to work, where PL_sv_undef acts as 'skip'
2405 * placeholder on the LHS of list assigns:
2406 * sub foo :lvalue { undef }
2407 * ($a, undef, foo(), $b) = 1..4;
2409 if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2411 /* Might be flattened array after $#array = */
2412 what = SvREADONLY(sv)
2413 ? "a readonly value" : "a temporary";
2419 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2424 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
2426 retop = cx->blk_sub.retop;
2437 const I32 cxix = dopoptosub(cxstack_ix);
2439 assert(cxstack_ix >= 0);
2440 if (cxix < cxstack_ix) {
2442 if (!( PL_curstackinfo->si_type == PERLSI_SORT
2443 || ( PL_curstackinfo->si_type == PERLSI_MULTICALL
2444 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2447 DIE(aTHX_ "Can't return outside a subroutine");
2449 * a sort block, which is a CXt_NULL not a CXt_SUB;
2450 * or a /(?{...})/ block.
2451 * Handle specially. */
2452 assert(CxTYPE(&cxstack[0]) == CXt_NULL
2453 || ( CxTYPE(&cxstack[0]) == CXt_SUB
2454 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2455 if (cxstack_ix > 0) {
2456 /* See comment below about context popping. Since we know
2457 * we're scalar and not lvalue, we can preserve the return
2458 * value in a simpler fashion than there. */
2460 assert(cxstack[0].blk_gimme == G_SCALAR);
2461 if ( (sp != PL_stack_base)
2462 && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2464 *SP = sv_mortalcopy(sv);
2467 /* caller responsible for popping cxstack[0] */
2471 /* There are contexts that need popping. Doing this may free the
2472 * return value(s), so preserve them first: e.g. popping the plain
2473 * loop here would free $x:
2474 * sub f { { my $x = 1; return $x } }
2475 * We may also need to shift the args down; for example,
2476 * for (1,2) { return 3,4 }
2477 * leaves 1,2,3,4 on the stack. Both these actions will be done by
2478 * leave_adjust_stacks(), along with freeing any temps. Note that
2479 * whoever we tail-call (e.g. pp_leaveeval) will also call
2480 * leave_adjust_stacks(); however, the second call is likely to
2481 * just see a bunch of SvTEMPs with a ref count of 1, and so just
2482 * pass them through, rather than copying them again. So this
2483 * isn't as inefficient as it sounds.
2485 cx = &cxstack[cxix];
2487 if (cx->blk_gimme != G_VOID)
2488 leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2490 CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2494 cx = &cxstack[cxix]; /* CX stack may have been realloced */
2497 /* Like in the branch above, we need to handle any extra junk on
2498 * the stack. But because we're not also popping extra contexts, we
2499 * don't have to worry about prematurely freeing args. So we just
2500 * need to do the bare minimum to handle junk, and leave the main
2501 * arg processing in the function we tail call, e.g. pp_leavesub.
2502 * In list context we have to splice out the junk; in scalar
2503 * context we can leave as-is (pp_leavesub will later return the
2504 * top stack element). But for an empty arg list, e.g.
2505 * for (1,2) { return }
2506 * we need to set sp = oldsp so that pp_leavesub knows to push
2507 * &PL_sv_undef onto the stack.
2510 cx = &cxstack[cxix];
2511 oldsp = PL_stack_base + cx->blk_oldsp;
2512 if (oldsp != MARK) {
2513 SSize_t nargs = SP - MARK;
2515 if (cx->blk_gimme == G_ARRAY) {
2516 /* shift return args to base of call stack frame */
2517 Move(MARK + 1, oldsp + 1, nargs, SV*);
2518 PL_stack_sp = oldsp + nargs;
2522 PL_stack_sp = oldsp;
2526 /* fall through to a normal exit */
2527 switch (CxTYPE(cx)) {
2529 return CxTRYBLOCK(cx)
2530 ? Perl_pp_leavetry(aTHX)
2531 : Perl_pp_leaveeval(aTHX);
2533 return CvLVALUE(cx->blk_sub.cv)
2534 ? Perl_pp_leavesublv(aTHX)
2535 : Perl_pp_leavesub(aTHX);
2537 return Perl_pp_leavewrite(aTHX);
2539 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2543 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2545 static PERL_CONTEXT *
2549 if (PL_op->op_flags & OPf_SPECIAL) {
2550 cxix = dopoptoloop(cxstack_ix);
2552 /* diag_listed_as: Can't "last" outside a loop block */
2553 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2559 const char * const label =
2560 PL_op->op_flags & OPf_STACKED
2561 ? SvPV(TOPs,label_len)
2562 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2563 const U32 label_flags =
2564 PL_op->op_flags & OPf_STACKED
2566 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2568 cxix = dopoptolabel(label, label_len, label_flags);
2570 /* diag_listed_as: Label not found for "last %s" */
2571 Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"",
2573 SVfARG(PL_op->op_flags & OPf_STACKED
2574 && !SvGMAGICAL(TOPp1s)
2576 : newSVpvn_flags(label,
2578 label_flags | SVs_TEMP)));
2580 if (cxix < cxstack_ix)
2582 return &cxstack[cxix];
2591 cx = S_unwind_loop(aTHX);
2593 assert(CxTYPE_is_LOOP(cx));
2594 PL_stack_sp = PL_stack_base
2595 + (CxTYPE(cx) == CXt_LOOP_LIST
2596 ? cx->blk_loop.state_u.stack.basesp
2602 /* Stack values are safe: */
2604 cx_poploop(cx); /* release loop vars ... */
2606 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2616 /* if not a bare 'next' in the main scope, search for it */
2618 if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
2619 cx = S_unwind_loop(aTHX);
2622 PL_curcop = cx->blk_oldcop;
2624 return (cx)->blk_loop.my_op->op_nextop;
2629 PERL_CONTEXT *cx = S_unwind_loop(aTHX);
2630 OP* redo_op = cx->blk_loop.my_op->op_redoop;
2632 if (redo_op->op_type == OP_ENTER) {
2633 /* pop one less context to avoid $x being freed in while (my $x..) */
2636 assert(CxTYPE(cx) == CXt_BLOCK);
2637 redo_op = redo_op->op_next;
2643 PL_curcop = cx->blk_oldcop;
2648 #define UNENTERABLE (OP *)1
2649 #define GOTO_DEPTH 64
2652 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2655 static const char* const too_deep = "Target of goto is too deeply nested";
2657 PERL_ARGS_ASSERT_DOFINDLABEL;
2660 Perl_croak(aTHX_ "%s", too_deep);
2661 if (o->op_type == OP_LEAVE ||
2662 o->op_type == OP_SCOPE ||
2663 o->op_type == OP_LEAVELOOP ||
2664 o->op_type == OP_LEAVESUB ||
2665 o->op_type == OP_LEAVETRY ||
2666 o->op_type == OP_LEAVEGIVEN)
2668 *ops++ = cUNOPo->op_first;
2670 else if (oplimit - opstack < GOTO_DEPTH) {
2671 if (o->op_flags & OPf_KIDS
2672 && cUNOPo->op_first->op_type == OP_PUSHMARK) {
2673 *ops++ = UNENTERABLE;
2675 else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type]
2676 && OP_CLASS(o) != OA_LOGOP
2677 && o->op_type != OP_LINESEQ
2678 && o->op_type != OP_SREFGEN
2679 && o->op_type != OP_ENTEREVAL
2680 && o->op_type != OP_GLOB
2681 && o->op_type != OP_RV2CV) {
2682 OP * const kid = cUNOPo->op_first;
2683 if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid))
2684 *ops++ = UNENTERABLE;
2688 Perl_croak(aTHX_ "%s", too_deep);
2690 if (o->op_flags & OPf_KIDS) {
2692 OP * const kid1 = cUNOPo->op_first;
2693 /* First try all the kids at this level, since that's likeliest. */
2694 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2695 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2696 STRLEN kid_label_len;
2697 U32 kid_label_flags;
2698 const char *kid_label = CopLABEL_len_flags(kCOP,
2699 &kid_label_len, &kid_label_flags);
2701 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2704 (const U8*)kid_label, kid_label_len,
2705 (const U8*)label, len) == 0)
2707 (const U8*)label, len,
2708 (const U8*)kid_label, kid_label_len) == 0)
2709 : ( len == kid_label_len && ((kid_label == label)
2710 || memEQ(kid_label, label, len)))))
2714 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2715 bool first_kid_of_binary = FALSE;
2716 if (kid == PL_lastgotoprobe)
2718 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2721 else if (ops[-1] != UNENTERABLE
2722 && (ops[-1]->op_type == OP_NEXTSTATE ||
2723 ops[-1]->op_type == OP_DBSTATE))
2728 if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) {
2729 first_kid_of_binary = TRUE;
2732 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2734 if (first_kid_of_binary)
2735 *ops++ = UNENTERABLE;
2744 S_check_op_type(pTHX_ OP * const o)
2746 /* Eventually we may want to stack the needed arguments
2747 * for each op. For now, we punt on the hard ones. */
2748 /* XXX This comment seems to me like wishful thinking. --sprout */
2749 if (o == UNENTERABLE)
2751 "Can't \"goto\" into a binary or list expression");
2752 if (o->op_type == OP_ENTERITER)
2754 "Can't \"goto\" into the middle of a foreach loop");
2755 if (o->op_type == OP_ENTERGIVEN)
2757 "Can't \"goto\" into a \"given\" block");
2760 /* also used for: pp_dump() */
2768 OP *enterops[GOTO_DEPTH];
2769 const char *label = NULL;
2770 STRLEN label_len = 0;
2771 U32 label_flags = 0;
2772 const bool do_dump = (PL_op->op_type == OP_DUMP);
2773 static const char* const must_have_label = "goto must have label";
2775 if (PL_op->op_flags & OPf_STACKED) {
2776 /* goto EXPR or goto &foo */
2778 SV * const sv = POPs;
2781 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2782 /* This egregious kludge implements goto &subroutine */
2785 CV *cv = MUTABLE_CV(SvRV(sv));
2786 AV *arg = GvAV(PL_defgv);
2788 while (!CvROOT(cv) && !CvXSUB(cv)) {
2789 const GV * const gv = CvGV(cv);
2793 /* autoloaded stub? */
2794 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2796 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2798 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2799 if (autogv && (cv = GvCV(autogv)))
2801 tmpstr = sv_newmortal();
2802 gv_efullname3(tmpstr, gv, NULL);
2803 DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
2805 DIE(aTHX_ "Goto undefined subroutine");
2808 cxix = dopoptosub(cxstack_ix);
2810 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2812 cx = &cxstack[cxix];
2813 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2814 if (CxTYPE(cx) == CXt_EVAL) {
2816 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2817 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2819 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2820 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2822 else if (CxMULTICALL(cx))
2823 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2825 /* First do some returnish stuff. */
2827 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2829 if (cxix < cxstack_ix) {
2836 /* protect @_ during save stack unwind. */
2838 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
2840 assert(PL_scopestack_ix == cx->blk_oldscopesp);
2843 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2844 /* this is part of cx_popsub_args() */
2845 AV* av = MUTABLE_AV(PAD_SVl(0));
2846 assert(AvARRAY(MUTABLE_AV(
2847 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2848 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2850 /* we are going to donate the current @_ from the old sub
2851 * to the new sub. This first part of the donation puts a
2852 * new empty AV in the pad[0] slot of the old sub,
2853 * unless pad[0] and @_ differ (e.g. if the old sub did
2854 * local *_ = []); in which case clear the old pad[0]
2855 * array in the usual way */
2856 if (av == arg || AvREAL(av))
2857 clear_defarray(av, av == arg);
2858 else CLEAR_ARGARRAY(av);
2861 /* don't restore PL_comppad here. It won't be needed if the
2862 * sub we're going to is non-XS, but restoring it early then
2863 * croaking (e.g. the "Goto undefined subroutine" below)
2864 * means the CX block gets processed again in dounwind,
2865 * but this time with the wrong PL_comppad */
2867 /* A destructor called during LEAVE_SCOPE could have undefined
2868 * our precious cv. See bug #99850. */
2869 if (!CvROOT(cv) && !CvXSUB(cv)) {
2870 const GV * const gv = CvGV(cv);
2872 SV * const tmpstr = sv_newmortal();
2873 gv_efullname3(tmpstr, gv, NULL);
2874 DIE(aTHX_ "Goto undefined subroutine &%" SVf,
2877 DIE(aTHX_ "Goto undefined subroutine");
2880 if (CxTYPE(cx) == CXt_SUB) {
2881 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2882 SvREFCNT_dec_NN(cx->blk_sub.cv);
2885 /* Now do some callish stuff. */
2887 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2888 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2893 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2895 /* put GvAV(defgv) back onto stack */
2897 EXTEND(SP, items+1); /* @_ could have been extended. */
2902 bool r = cBOOL(AvREAL(arg));
2903 for (index=0; index<items; index++)
2907 SV ** const svp = av_fetch(arg, index, 0);
2908 sv = svp ? *svp : NULL;
2910 else sv = AvARRAY(arg)[index];
2912 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2913 : sv_2mortal(newSVavdefelem(arg, index, 1));
2917 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2918 /* Restore old @_ */
2919 CX_POP_SAVEARRAY(cx);
2922 retop = cx->blk_sub.retop;
2923 PL_comppad = cx->blk_sub.prevcomppad;
2924 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2926 /* XS subs don't have a CXt_SUB, so pop it;
2927 * this is a cx_popblock(), less all the stuff we already did
2928 * for cx_topblock() earlier */
2929 PL_curcop = cx->blk_oldcop;
2932 /* Push a mark for the start of arglist */
2935 (void)(*CvXSUB(cv))(aTHX_ cv);
2940 PADLIST * const padlist = CvPADLIST(cv);
2942 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2944 /* partial unrolled cx_pushsub(): */
2946 cx->blk_sub.cv = cv;
2947 cx->blk_sub.olddepth = CvDEPTH(cv);
2950 SvREFCNT_inc_simple_void_NN(cv);
2951 if (CvDEPTH(cv) > 1) {
2952 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2953 sub_crush_depth(cv);
2954 pad_push(padlist, CvDEPTH(cv));
2956 PL_curcop = cx->blk_oldcop;
2957 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2960 /* second half of donating @_ from the old sub to the
2961 * new sub: abandon the original pad[0] AV in the
2962 * new sub, and replace it with the donated @_.
2963 * pad[0] takes ownership of the extra refcount
2964 * we gave arg earlier */
2966 SvREFCNT_dec(PAD_SVl(0));
2967 PAD_SVl(0) = (SV *)arg;
2968 SvREFCNT_inc_simple_void_NN(arg);
2971 /* GvAV(PL_defgv) might have been modified on scope
2972 exit, so point it at arg again. */
2973 if (arg != GvAV(PL_defgv)) {
2974 AV * const av = GvAV(PL_defgv);
2975 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2980 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2981 Perl_get_db_sub(aTHX_ NULL, cv);
2983 CV * const gotocv = get_cvs("DB::goto", 0);
2985 PUSHMARK( PL_stack_sp );
2986 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2991 retop = CvSTART(cv);
2992 goto putback_return;
2997 label = SvPV_nomg_const(sv, label_len);
2998 label_flags = SvUTF8(sv);
3001 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
3002 /* goto LABEL or dump LABEL */
3003 label = cPVOP->op_pv;
3004 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
3005 label_len = strlen(label);
3007 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
3012 OP *gotoprobe = NULL;
3013 bool leaving_eval = FALSE;
3014 bool in_block = FALSE;
3015 bool pseudo_block = FALSE;
3016 PERL_CONTEXT *last_eval_cx = NULL;
3020 PL_lastgotoprobe = NULL;
3022 for (ix = cxstack_ix; ix >= 0; ix--) {
3024 switch (CxTYPE(cx)) {
3026 leaving_eval = TRUE;
3027 if (!CxTRYBLOCK(cx)) {
3028 gotoprobe = (last_eval_cx ?
3029 last_eval_cx->blk_eval.old_eval_root :
3034 /* else fall through */
3035 case CXt_LOOP_PLAIN:
3036 case CXt_LOOP_LAZYIV:
3037 case CXt_LOOP_LAZYSV:
3042 gotoprobe = OpSIBLING(cx->blk_oldcop);
3048 gotoprobe = OpSIBLING(cx->blk_oldcop);
3051 gotoprobe = PL_main_root;
3054 gotoprobe = CvROOT(cx->blk_sub.cv);
3055 pseudo_block = cBOOL(CxMULTICALL(cx));
3059 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3062 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3063 CxTYPE(cx), (long) ix);
3064 gotoprobe = PL_main_root;
3070 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3071 enterops, enterops + GOTO_DEPTH);
3074 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3075 sibl1->op_type == OP_UNSTACK &&
3076 (sibl2 = OpSIBLING(sibl1)))
3078 retop = dofindlabel(sibl2,
3079 label, label_len, label_flags, enterops,
3080 enterops + GOTO_DEPTH);
3086 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3087 PL_lastgotoprobe = gotoprobe;
3090 DIE(aTHX_ "Can't find label %" UTF8f,
3091 UTF8fARG(label_flags, label_len, label));
3093 /* if we're leaving an eval, check before we pop any frames
3094 that we're not going to punt, otherwise the error
3097 if (leaving_eval && *enterops && enterops[1]) {
3099 for (i = 1; enterops[i]; i++)
3100 S_check_op_type(aTHX_ enterops[i]);
3103 if (*enterops && enterops[1]) {
3104 I32 i = enterops[1] != UNENTERABLE
3105 && enterops[1]->op_type == OP_ENTER && in_block
3109 deprecate("\"goto\" to jump into a construct");
3112 /* pop unwanted frames */
3114 if (ix < cxstack_ix) {
3116 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3122 /* push wanted frames */
3124 if (*enterops && enterops[1]) {
3125 OP * const oldop = PL_op;
3126 ix = enterops[1] != UNENTERABLE
3127 && enterops[1]->op_type == OP_ENTER && in_block
3130 for (; enterops[ix]; ix++) {
3131 PL_op = enterops[ix];
3132 S_check_op_type(aTHX_ PL_op);
3133 DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n",
3135 PL_op->op_ppaddr(aTHX);
3143 if (!retop) retop = PL_main_start;
3145 PL_restartop = retop;
3146 PL_do_undump = TRUE;
3150 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3151 PL_do_undump = FALSE;
3169 anum = 0; (void)POPs;
3175 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3178 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3181 PL_exit_flags |= PERL_EXIT_EXPECTED;
3183 PUSHs(&PL_sv_undef);
3190 S_save_lines(pTHX_ AV *array, SV *sv)
3192 const char *s = SvPVX_const(sv);
3193 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3196 PERL_ARGS_ASSERT_SAVE_LINES;
3198 while (s && s < send) {
3200 SV * const tmpstr = newSV_type(SVt_PVMG);
3202 t = (const char *)memchr(s, '\n', send - s);
3208 sv_setpvn(tmpstr, s, t - s);
3209 av_store(array, line++, tmpstr);
3217 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3219 0 is used as continue inside eval,
3221 3 is used for a die caught by an inner eval - continue inner loop
3223 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3224 establish a local jmpenv to handle exception traps.
3229 S_docatch(pTHX_ Perl_ppaddr_t firstpp)
3232 OP * const oldop = PL_op;
3235 assert(CATCH_GET == TRUE);
3240 PL_op = firstpp(aTHX);
3245 /* die caught by an inner eval - continue inner loop */
3246 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3247 PL_restartjmpenv = NULL;
3248 PL_op = PL_restartop;
3257 NOT_REACHED; /* NOTREACHED */
3266 =for apidoc find_runcv
3268 Locate the CV corresponding to the currently executing sub or eval.
3269 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3270 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3271 entered. (This allows debuggers to eval in the scope of the breakpoint
3272 rather than in the scope of the debugger itself.)
3278 Perl_find_runcv(pTHX_ U32 *db_seqp)
3280 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3283 /* If this becomes part of the API, it might need a better name. */
3285 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3292 PL_curcop == &PL_compiling
3294 : PL_curcop->cop_seq;
3296 for (si = PL_curstackinfo; si; si = si->si_prev) {
3298 for (ix = si->si_cxix; ix >= 0; ix--) {
3299 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3301 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3302 cv = cx->blk_sub.cv;
3303 /* skip DB:: code */
3304 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3305 *db_seqp = cx->blk_oldcop->cop_seq;
3308 if (cx->cx_type & CXp_SUB_RE)
3311 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3312 cv = cx->blk_eval.cv;
3315 case FIND_RUNCV_padid_eq:
3317 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3320 case FIND_RUNCV_level_eq:
3321 if (level++ != arg) continue;
3329 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3333 /* Run yyparse() in a setjmp wrapper. Returns:
3334 * 0: yyparse() successful
3335 * 1: yyparse() failed
3339 S_try_yyparse(pTHX_ int gramtype)
3344 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3348 ret = yyparse(gramtype) ? 1 : 0;
3355 NOT_REACHED; /* NOTREACHED */
3362 /* Compile a require/do or an eval ''.
3364 * outside is the lexically enclosing CV (if any) that invoked us.
3365 * seq is the current COP scope value.
3366 * hh is the saved hints hash, if any.
3368 * Returns a bool indicating whether the compile was successful; if so,
3369 * PL_eval_start contains the first op of the compiled code; otherwise,
3372 * This function is called from two places: pp_require and pp_entereval.
3373 * These can be distinguished by whether PL_op is entereval.
3377 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3380 OP * const saveop = PL_op;
3381 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3382 COP * const oldcurcop = PL_curcop;
3383 bool in_require = (saveop->op_type == OP_REQUIRE);
3387 PL_in_eval = (in_require
3388 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3390 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3391 ? EVAL_RE_REPARSING : 0)));
3395 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3397 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3398 CX_CUR()->blk_eval.cv = evalcv;
3399 CX_CUR()->blk_gimme = gimme;
3401 CvOUTSIDE_SEQ(evalcv) = seq;
3402 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3404 /* set up a scratch pad */
3406 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3407 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3410 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3412 /* make sure we compile in the right package */
3414 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3415 SAVEGENERICSV(PL_curstash);
3416 PL_curstash = (HV *)CopSTASH(PL_curcop);
3417 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3419 SvREFCNT_inc_simple_void(PL_curstash);
3420 save_item(PL_curstname);
3421 sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash));
3424 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3425 SAVESPTR(PL_beginav);
3426 PL_beginav = newAV();
3427 SAVEFREESV(PL_beginav);
3428 SAVESPTR(PL_unitcheckav);
3429 PL_unitcheckav = newAV();
3430 SAVEFREESV(PL_unitcheckav);
3433 ENTER_with_name("evalcomp");
3434 SAVESPTR(PL_compcv);
3437 /* try to compile it */
3439 PL_eval_root = NULL;
3440 PL_curcop = &PL_compiling;
3441 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3442 PL_in_eval |= EVAL_KEEPERR;
3449 hv_clear(GvHV(PL_hintgv));
3452 PL_hints = saveop->op_private & OPpEVAL_COPHH
3453 ? oldcurcop->cop_hints : (U32)saveop->op_targ;
3455 /* making 'use re eval' not be in scope when compiling the
3456 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3457 * infinite recursion when S_has_runtime_code() gives a false
3458 * positive: the second time round, HINT_RE_EVAL isn't set so we
3459 * don't bother calling S_has_runtime_code() */
3460 if (PL_in_eval & EVAL_RE_REPARSING)
3461 PL_hints &= ~HINT_RE_EVAL;
3464 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3465 SvREFCNT_dec(GvHV(PL_hintgv));
3466 GvHV(PL_hintgv) = hh;
3469 SAVECOMPILEWARNINGS();
3471 if (PL_dowarn & G_WARN_ALL_ON)
3472 PL_compiling.cop_warnings = pWARN_ALL ;
3473 else if (PL_dowarn & G_WARN_ALL_OFF)
3474 PL_compiling.cop_warnings = pWARN_NONE ;
3476 PL_compiling.cop_warnings = pWARN_STD ;
3479 PL_compiling.cop_warnings =
3480 DUP_WARNINGS(oldcurcop->cop_warnings);
3481 cophh_free(CopHINTHASH_get(&PL_compiling));
3482 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3483 /* The label, if present, is the first entry on the chain. So rather
3484 than writing a blank label in front of it (which involves an
3485 allocation), just use the next entry in the chain. */
3486 PL_compiling.cop_hints_hash
3487 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3488 /* Check the assumption that this removed the label. */
3489 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3492 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3495 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3497 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3498 * so honour CATCH_GET and trap it here if necessary */
3501 /* compile the code */
3502 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3504 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3509 /* note that if yystatus == 3, then the require/eval died during
3510 * compilation, so the EVAL CX block has already been popped, and
3511 * various vars restored */
3512 if (yystatus != 3) {
3514 op_free(PL_eval_root);
3515 PL_eval_root = NULL;
3517 SP = PL_stack_base + POPMARK; /* pop original mark */
3519 assert(CxTYPE(cx) == CXt_EVAL);
3520 /* pop the CXt_EVAL, and if was a require, croak */
3521 S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
3524 /* die_unwind() re-croaks when in require, having popped the
3525 * require EVAL context. So we should never catch a require
3527 assert(!in_require);
3530 if (!*(SvPV_nolen_const(errsv)))
3531 sv_setpvs(errsv, "Compilation error");
3533 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3538 /* Compilation successful. Now clean up */
3540 LEAVE_with_name("evalcomp");
3542 CopLINE_set(&PL_compiling, 0);
3543 SAVEFREEOP(PL_eval_root);
3544 cv_forget_slab(evalcv);
3546 DEBUG_x(dump_eval());
3548 /* Register with debugger: */
3549 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3550 CV * const cv = get_cvs("DB::postponed", 0);
3554 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3556 call_sv(MUTABLE_SV(cv), G_DISCARD);
3560 if (PL_unitcheckav) {
3561 OP *es = PL_eval_start;
3562 call_list(PL_scopestack_ix, PL_unitcheckav);
3566 CvDEPTH(evalcv) = 1;
3567 SP = PL_stack_base + POPMARK; /* pop original mark */
3568 PL_op = saveop; /* The caller may need it. */
3569 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3575 /* Return NULL if the file doesn't exist or isn't a file;
3576 * else return PerlIO_openn().
3580 S_check_type_and_open(pTHX_ SV *name)
3585 const char *p = SvPV_const(name, len);
3588 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3590 /* checking here captures a reasonable error message when
3591 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3592 * user gets a confusing message about looking for the .pmc file
3593 * rather than for the .pm file so do the check in S_doopen_pm when
3594 * PMC is on instead of here. S_doopen_pm calls this func.
3595 * This check prevents a \0 in @INC causing problems.
3597 #ifdef PERL_DISABLE_PMC
3598 if (!IS_SAFE_PATHNAME(p, len, "require"))
3602 /* on Win32 stat is expensive (it does an open() and close() twice and
3603 a couple other IO calls), the open will fail with a dir on its own with
3604 errno EACCES, so only do a stat to separate a dir from a real EACCES
3605 caused by user perms */
3607 st_rc = PerlLIO_stat(p, &st);
3613 if(S_ISBLK(st.st_mode)) {
3617 else if(S_ISDIR(st.st_mode)) {
3626 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3628 /* EACCES stops the INC search early in pp_require to implement
3629 feature RT #113422 */
3630 if(!retio && errno == EACCES) { /* exists but probably a directory */
3632 st_rc = PerlLIO_stat(p, &st);
3634 if(S_ISDIR(st.st_mode))
3636 else if(S_ISBLK(st.st_mode))
3647 /* doopen_pm(): return the equivalent of PerlIO_openn() on the given name,
3648 * but first check for bad names (\0) and non-files.
3649 * Also if the filename ends in .pm and unless PERL_DISABLE_PMC,
3650 * try loading Foo.pmc first.
3652 #ifndef PERL_DISABLE_PMC
3654 S_doopen_pm(pTHX_ SV *name)
3657 const char *p = SvPV_const(name, namelen);
3659 PERL_ARGS_ASSERT_DOOPEN_PM;
3661 /* check the name before trying for the .pmc name to avoid the
3662 * warning referring to the .pmc which the user probably doesn't
3663 * know or care about
3665 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3668 if (memENDPs(p, namelen, ".pm")) {
3669 SV *const pmcsv = sv_newmortal();
3672 SvSetSV_nosteal(pmcsv,name);
3673 sv_catpvs(pmcsv, "c");
3675 pmcio = check_type_and_open(pmcsv);
3679 return check_type_and_open(name);
3682 # define doopen_pm(name) check_type_and_open(name)
3683 #endif /* !PERL_DISABLE_PMC */
3685 /* require doesn't search in @INC for absolute names, or when the name is
3686 explicitly relative the current directory: i.e. ./, ../ */
3687 PERL_STATIC_INLINE bool
3688 S_path_is_searchable(const char *name)
3690 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3692 if (PERL_FILE_IS_ABSOLUTE(name)
3694 || (*name == '.' && ((name[1] == '/' ||
3695 (name[1] == '.' && name[2] == '/'))
3696 || (name[1] == '\\' ||
3697 ( name[1] == '.' && name[2] == '\\')))
3700 || (*name == '.' && (name[1] == '/' ||
3701 (name[1] == '.' && name[2] == '/')))
3712 /* implement 'require 5.010001' */
3715 S_require_version(pTHX_ SV *sv)
3719 sv = sv_2mortal(new_version(sv));
3720 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3721 upg_version(PL_patchlevel, TRUE);
3722 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3723 if ( vcmp(sv,PL_patchlevel) <= 0 )
3724 DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
3725 SVfARG(sv_2mortal(vnormal(sv))),
3726 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3730 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3733 SV * const req = SvRV(sv);
3734 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3736 /* get the left hand term */
3737 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3739 first = SvIV(*av_fetch(lav,0,0));
3740 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3741 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3742 || av_tindex(lav) > 1 /* FP with > 3 digits */
3743 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3745 DIE(aTHX_ "Perl %" SVf " required--this is only "
3746 "%" SVf ", stopped",
3747 SVfARG(sv_2mortal(vnormal(req))),
3748 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3751 else { /* probably 'use 5.10' or 'use 5.8' */
3755 if (av_tindex(lav)>=1)
3756 second = SvIV(*av_fetch(lav,1,0));
3758 second /= second >= 600 ? 100 : 10;
3759 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3760 (int)first, (int)second);
3761 upg_version(hintsv, TRUE);
3763 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)"
3764 "--this is only %" SVf ", stopped",
3765 SVfARG(sv_2mortal(vnormal(req))),
3766 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3767 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3776 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
3777 * The first form will have already been converted at compile time to
3778 * the second form */
3781 S_require_file(pTHX_ SV *sv)
3791 int vms_unixname = 0;
3794 /* tryname is the actual pathname (with @INC prefix) which was loaded.
3795 * It's stored as a value in %INC, and used for error messages */
3796 const char *tryname = NULL;
3797 SV *namesv = NULL; /* SV equivalent of tryname */
3798 const U8 gimme = GIMME_V;
3799 int filter_has_file = 0;
3800 PerlIO *tryrsfp = NULL;
3801 SV *filter_cache = NULL;
3802 SV *filter_state = NULL;
3803 SV *filter_sub = NULL;
3807 bool path_searchable;
3808 I32 old_savestack_ix;
3809 const bool op_is_require = PL_op->op_type == OP_REQUIRE;
3810 const char *const op_name = op_is_require ? "require" : "do";
3811 SV ** svp_cached = NULL;
3813 assert(op_is_require || PL_op->op_type == OP_DOFILE);
3816 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3817 name = SvPV_nomg_const(sv, len);
3818 if (!(name && len > 0 && *name))
3819 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3822 /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */
3823 if (op_is_require) {
3824 /* can optimize to only perform one single lookup */
3825 svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0);
3826 if ( svp_cached && *svp_cached != &PL_sv_undef ) RETPUSHYES;
3830 if (!IS_SAFE_PATHNAME(name, len, op_name)) {
3831 if (!op_is_require) {
3835 DIE(aTHX_ "Can't locate %s: %s",
3836 pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
3837 NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3840 TAINT_PROPER(op_name);
3842 path_searchable = path_is_searchable(name);
3845 /* The key in the %ENV hash is in the syntax of file passed as the argument
3846 * usually this is in UNIX format, but sometimes in VMS format, which
3847 * can result in a module being pulled in more than once.
3848 * To prevent this, the key must be stored in UNIX format if the VMS
3849 * name can be translated to UNIX.
3853 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3855 unixlen = strlen(unixname);
3861 /* if not VMS or VMS name can not be translated to UNIX, pass it
3864 unixname = (char *) name;
3867 if (op_is_require) {
3868 /* reuse the previous hv_fetch result if possible */
3869 SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3871 if (*svp != &PL_sv_undef)
3874 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3875 "Compilation failed in require", unixname);
3878 /*XXX OPf_KIDS should always be true? -dapm 4/2017 */
3879 if (PL_op->op_flags & OPf_KIDS) {
3880 SVOP * const kid = (SVOP*)cUNOP->op_first;
3882 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3883 /* Make sure that a bareword module name (e.g. ::Foo::Bar)
3884 * doesn't map to a naughty pathname like /Foo/Bar.pm.
3885 * Note that the parser will normally detect such errors
3886 * at compile time before we reach here, but
3887 * Perl_load_module() can fake up an identical optree
3888 * without going near the parser, and being able to put
3889 * anything as the bareword. So we include a duplicate set
3890 * of checks here at runtime.
3892 const STRLEN package_len = len - 3;
3893 const char slashdot[2] = {'/', '.'};
3895 const char backslashdot[2] = {'\\', '.'};
3898 /* Disallow *purported* barewords that map to absolute
3899 filenames, filenames relative to the current or parent
3900 directory, or (*nix) hidden filenames. Also sanity check
3901 that the generated filename ends .pm */
3902 if (!path_searchable || len < 3 || name[0] == '.'
3903 || !memEQs(name + package_len, len - package_len, ".pm"))
3904 DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv);
3905 if (memchr(name, 0, package_len)) {
3906 /* diag_listed_as: Bareword in require contains "%s" */
3907 DIE(aTHX_ "Bareword in require contains \"\\0\"");
3909 if (ninstr(name, name + package_len, slashdot,
3910 slashdot + sizeof(slashdot))) {
3911 /* diag_listed_as: Bareword in require contains "%s" */
3912 DIE(aTHX_ "Bareword in require contains \"/.\"");
3915 if (ninstr(name, name + package_len, backslashdot,
3916 backslashdot + sizeof(backslashdot))) {
3917 /* diag_listed_as: Bareword in require contains "%s" */
3918 DIE(aTHX_ "Bareword in require contains \"\\.\"");
3925 PERL_DTRACE_PROBE_FILE_LOADING(unixname);
3927 /* Try to locate and open a file, possibly using @INC */
3929 /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load
3930 * the file directly rather than via @INC ... */
3931 if (!path_searchable) {
3932 /* At this point, name is SvPVX(sv) */
3934 tryrsfp = doopen_pm(sv);
3937 /* ... but if we fail, still search @INC for code references;
3938 * these are applied even on on-searchable paths (except
3939 * if we got EACESS).
3941 * For searchable paths, just search @INC normally
3943 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3944 AV * const ar = GvAVn(PL_incgv);
3951 namesv = newSV_type(SVt_PV);
3952 for (i = 0; i <= AvFILL(ar); i++) {
3953 SV * const dirsv = *av_fetch(ar, i, TRUE);
3961 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3962 && !SvOBJECT(SvRV(loader)))
3964 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3968 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
3969 PTR2UV(SvRV(dirsv)), name);
3970 tryname = SvPVX_const(namesv);
3973 if (SvPADTMP(nsv)) {
3974 nsv = sv_newmortal();
3975 SvSetSV_nosteal(nsv,sv);
3978 ENTER_with_name("call_INC");
3986 if (SvGMAGICAL(loader)) {
3987 SV *l = sv_newmortal();
3988 sv_setsv_nomg(l, loader);
3991 if (sv_isobject(loader))
3992 count = call_method("INC", G_ARRAY);
3994 count = call_sv(loader, G_ARRAY);
4004 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
4005 && !isGV_with_GP(SvRV(arg))) {
4006 filter_cache = SvRV(arg);
4013 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
4017 if (isGV_with_GP(arg)) {
4018 IO * const io = GvIO((const GV *)arg);
4023 tryrsfp = IoIFP(io);
4024 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
4025 PerlIO_close(IoOFP(io));
4036 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
4038 SvREFCNT_inc_simple_void_NN(filter_sub);
4041 filter_state = SP[i];
4042 SvREFCNT_inc_simple_void(filter_state);
4046 if (!tryrsfp && (filter_cache || filter_sub)) {
4047 tryrsfp = PerlIO_open(BIT_BUCKET,
4053 /* FREETMPS may free our filter_cache */
4054 SvREFCNT_inc_simple_void(filter_cache);
4058 LEAVE_with_name("call_INC");
4060 /* Now re-mortalize it. */
4061 sv_2mortal(filter_cache);
4063 /* Adjust file name if the hook has set an %INC entry.
4064 This needs to happen after the FREETMPS above. */
4065 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
4067 tryname = SvPV_nolen_const(*svp);
4074 filter_has_file = 0;
4075 filter_cache = NULL;
4077 SvREFCNT_dec_NN(filter_state);
4078 filter_state = NULL;
4081 SvREFCNT_dec_NN(filter_sub);
4085 else if (path_searchable) {
4086 /* match against a plain @INC element (non-searchable
4087 * paths are only matched against refs in @INC) */
4092 dir = SvPV_nomg_const(dirsv, dirlen);
4098 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
4102 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4105 sv_setpv(namesv, unixdir);
4106 sv_catpv(namesv, unixname);
4107 #elif defined(__SYMBIAN32__)
4108 if (PL_origfilename[0] &&
4109 PL_origfilename[1] == ':' &&
4110 !(dir[0] && dir[1] == ':'))
4111 Perl_sv_setpvf(aTHX_ namesv,
4116 Perl_sv_setpvf(aTHX_ namesv,
4120 /* The equivalent of
4121 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4122 but without the need to parse the format string, or
4123 call strlen on either pointer, and with the correct
4124 allocation up front. */
4126 char *tmp = SvGROW(namesv, dirlen + len + 2);
4128 memcpy(tmp, dir, dirlen);
4131 /* Avoid '<dir>//<file>' */
4132 if (!dirlen || *(tmp-1) != '/') {
4135 /* So SvCUR_set reports the correct length below */
4139 /* name came from an SV, so it will have a '\0' at the
4140 end that we can copy as part of this memcpy(). */
4141 memcpy(tmp, name, len + 1);
4143 SvCUR_set(namesv, dirlen + len + 1);
4147 TAINT_PROPER(op_name);
4148 tryname = SvPVX_const(namesv);
4149 tryrsfp = doopen_pm(namesv);
4151 if (tryname[0] == '.' && tryname[1] == '/') {
4153 while (*++tryname == '/') {}
4157 else if (errno == EMFILE || errno == EACCES) {
4158 /* no point in trying other paths if out of handles;
4159 * on the other hand, if we couldn't open one of the
4160 * files, then going on with the search could lead to
4161 * unexpected results; see perl #113422
4170 /* at this point we've ether opened a file (tryrsfp) or set errno */
4172 saved_errno = errno; /* sv_2mortal can realloc things */
4175 /* we failed; croak if require() or return undef if do() */
4176 if (op_is_require) {
4177 if(saved_errno == EMFILE || saved_errno == EACCES) {
4178 /* diag_listed_as: Can't locate %s */
4179 DIE(aTHX_ "Can't locate %s: %s: %s",
4180 name, tryname, Strerror(saved_errno));
4182 if (path_searchable) { /* did we lookup @INC? */
4183 AV * const ar = GvAVn(PL_incgv);
4185 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4186 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4187 for (i = 0; i <= AvFILL(ar); i++) {
4188 sv_catpvs(inc, " ");
4189 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4191 if (memENDPs(name, len, ".pm")) {
4192 const char *e = name + len - (sizeof(".pm") - 1);
4194 bool utf8 = cBOOL(SvUTF8(sv));
4196 /* if the filename, when converted from "Foo/Bar.pm"
4197 * form back to Foo::Bar form, makes a valid
4198 * package name (i.e. parseable by C<require
4199 * Foo::Bar>), then emit a hint.
4201 * this loop is modelled after the one in
4205 if (utf8 && isIDFIRST_utf8_safe(c, e)) {
4207 while (c < e && isIDCONT_utf8_safe(
4208 (const U8*) c, (const U8*) e))
4211 else if (isWORDCHAR_A(*c)) {
4212 while (c < e && isWORDCHAR_A(*c))
4221 if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
4222 sv_catpvs(msg, " (you may need to install the ");
4223 for (c = name; c < e; c++) {
4225 sv_catpvs(msg, "::");
4228 sv_catpvn(msg, c, 1);
4231 sv_catpvs(msg, " module)");
4234 else if (memENDs(name, len, ".h")) {
4235 sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4237 else if (memENDs(name, len, ".ph")) {
4238 sv_catpvs(msg, " (did you run h2ph?)");
4241 /* diag_listed_as: Can't locate %s */
4243 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4247 DIE(aTHX_ "Can't locate %s", name);
4250 #ifdef DEFAULT_INC_EXCLUDES_DOT
4254 /* the complication is to match the logic from doopen_pm() so
4255 * we don't treat do "sda1" as a previously successful "do".
4257 bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED)
4258 && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode)
4259 && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL;
4265 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4266 "do \"%s\" failed, '.' is no longer in @INC; "
4267 "did you mean do \"./%s\"?",
4276 SETERRNO(0, SS_NORMAL);
4278 /* Update %INC. Assume success here to prevent recursive requirement. */
4279 /* name is never assigned to again, so len is still strlen(name) */
4280 /* Check whether a hook in @INC has already filled %INC */
4282 (void)hv_store(GvHVn(PL_incgv),
4283 unixname, unixlen, newSVpv(tryname,0),0);
4285 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4287 (void)hv_store(GvHVn(PL_incgv),
4288 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4291 /* Now parse the file */
4293 old_savestack_ix = PL_savestack_ix;
4294 SAVECOPFILE_FREE(&PL_compiling);
4295 CopFILE_set(&PL_compiling, tryname);
4296 lex_start(NULL, tryrsfp, 0);
4298 if (filter_sub || filter_cache) {
4299 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4300 than hanging another SV from it. In turn, filter_add() optionally
4301 takes the SV to use as the filter (or creates a new SV if passed
4302 NULL), so simply pass in whatever value filter_cache has. */
4303 SV * const fc = filter_cache ? newSV(0) : NULL;
4305 if (fc) sv_copypv(fc, filter_cache);
4306 datasv = filter_add(S_run_user_filter, fc);
4307 IoLINES(datasv) = filter_has_file;
4308 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4309 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4312 /* switch to eval mode */
4314 cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4315 cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4317 SAVECOPLINE(&PL_compiling);
4318 CopLINE_set(&PL_compiling, 0);
4322 if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4325 op = PL_op->op_next;
4327 PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4333 /* also used for: pp_dofile() */
4337 RUN_PP_CATCHABLY(Perl_pp_require);
4344 return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4345 ? S_require_version(aTHX_ sv)
4346 : S_require_file(aTHX_ sv);
4351 /* This is a op added to hold the hints hash for
4352 pp_entereval. The hash can be modified by the code
4353 being eval'ed, so we return a copy instead. */
4358 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4370 char tbuf[TYPE_DIGITS(long) + 12];
4378 I32 old_savestack_ix;
4380 RUN_PP_CATCHABLY(Perl_pp_entereval);
4383 was = PL_breakable_sub_gen;
4384 saved_delete = FALSE;
4388 bytes = PL_op->op_private & OPpEVAL_BYTES;
4390 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4391 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4393 else if (PL_hints & HINT_LOCALIZE_HH || (
4394 PL_op->op_private & OPpEVAL_COPHH
4395 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4397 saved_hh = cop_hints_2hv(PL_curcop, 0);
4398 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4402 /* make sure we've got a plain PV (no overload etc) before testing
4403 * for taint. Making a copy here is probably overkill, but better
4404 * safe than sorry */
4406 const char * const p = SvPV_const(sv, len);
4408 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4409 lex_flags |= LEX_START_COPIED;
4411 if (bytes && SvUTF8(sv))
4412 SvPVbyte_force(sv, len);
4414 else if (bytes && SvUTF8(sv)) {
4415 /* Don't modify someone else's scalar */
4418 (void)sv_2mortal(sv);
4419 SvPVbyte_force(sv,len);
4420 lex_flags |= LEX_START_COPIED;
4423 TAINT_IF(SvTAINTED(sv));
4424 TAINT_PROPER("eval");
4426 old_savestack_ix = PL_savestack_ix;
4428 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4429 ? LEX_IGNORE_UTF8_HINTS
4430 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4434 /* switch to eval mode */
4436 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4437 SV * const temp_sv = sv_newmortal();
4438 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]",
4439 (unsigned long)++PL_evalseq,
4440 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4441 tmpbuf = SvPVX(temp_sv);
4442 len = SvCUR(temp_sv);
4445 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4446 SAVECOPFILE_FREE(&PL_compiling);
4447 CopFILE_set(&PL_compiling, tmpbuf+2);
4448 SAVECOPLINE(&PL_compiling);
4449 CopLINE_set(&PL_compiling, 1);
4450 /* special case: an eval '' executed within the DB package gets lexically
4451 * placed in the first non-DB CV rather than the current CV - this
4452 * allows the debugger to execute code, find lexicals etc, in the
4453 * scope of the code being debugged. Passing &seq gets find_runcv
4454 * to do the dirty work for us */
4455 runcv = find_runcv(&seq);
4458 cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
4459 cx_pusheval(cx, PL_op->op_next, NULL);
4461 /* prepare to compile string */
4463 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4464 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4466 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4467 deleting the eval's FILEGV from the stash before gv_check() runs
4468 (i.e. before run-time proper). To work around the coredump that
4469 ensues, we always turn GvMULTI_on for any globals that were
4470 introduced within evals. See force_ident(). GSAR 96-10-12 */
4471 char *const safestr = savepvn(tmpbuf, len);
4472 SAVEDELETE(PL_defstash, safestr, len);
4473 saved_delete = TRUE;
4478 if (doeval_compile(gimme, runcv, seq, saved_hh)) {
4479 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4480 ? PERLDB_LINE_OR_SAVESRC
4481 : PERLDB_SAVESRC_NOSUBS) {
4482 /* Retain the filegv we created. */
4483 } else if (!saved_delete) {
4484 char *const safestr = savepvn(tmpbuf, len);
4485 SAVEDELETE(PL_defstash, safestr, len);
4487 return PL_eval_start;
4489 /* We have already left the scope set up earlier thanks to the LEAVE
4490 in doeval_compile(). */
4491 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4492 ? PERLDB_LINE_OR_SAVESRC
4493 : PERLDB_SAVESRC_INVALID) {
4494 /* Retain the filegv we created. */
4495 } else if (!saved_delete) {
4496 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4498 return PL_op->op_next;
4503 /* also tail-called by pp_return */
4518 assert(CxTYPE(cx) == CXt_EVAL);
4520 oldsp = PL_stack_base + cx->blk_oldsp;
4521 gimme = cx->blk_gimme;
4523 /* did require return a false value? */
4524 failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE
4525 && !(gimme == G_SCALAR
4526 ? SvTRUE_NN(*PL_stack_sp)
4527 : PL_stack_sp > oldsp);
4529 if (gimme == G_VOID) {
4530 PL_stack_sp = oldsp;
4531 /* free now to avoid late-called destructors clobbering $@ */
4535 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4537 /* the cx_popeval does a leavescope, which frees the optree associated
4538 * with eval, which if it frees the nextstate associated with
4539 * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
4540 * regex when running under 'use re Debug' because it needs PL_curcop
4541 * to get the current hints. So restore it early.
4543 PL_curcop = cx->blk_oldcop;
4545 /* grab this value before cx_popeval restores the old PL_in_eval */
4546 keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4547 retop = cx->blk_eval.retop;
4548 evalcv = cx->blk_eval.cv;
4550 assert(CvDEPTH(evalcv) == 1);
4552 CvDEPTH(evalcv) = 0;
4554 /* pop the CXt_EVAL, and if a require failed, croak */
4555 S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
4563 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4564 close to the related Perl_create_eval_scope. */
4566 Perl_delete_eval_scope(pTHX)
4577 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4578 also needed by Perl_fold_constants. */
4580 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
4583 const U8 gimme = GIMME_V;
4585 cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
4586 PL_stack_sp, PL_savestack_ix);
4587 cx_pusheval(cx, retop, NULL);
4589 PL_in_eval = EVAL_INEVAL;
4590 if (flags & G_KEEPERR)
4591 PL_in_eval |= EVAL_KEEPERR;
4594 if (flags & G_FAKINGEVAL) {
4595 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4601 RUN_PP_CATCHABLY(Perl_pp_entertry);
4604 create_eval_scope(cLOGOP->op_other->op_next, 0);
4605 return PL_op->op_next;
4609 /* also tail-called by pp_return */
4621 assert(CxTYPE(cx) == CXt_EVAL);
4622 oldsp = PL_stack_base + cx->blk_oldsp;
4623 gimme = cx->blk_gimme;
4625 if (gimme == G_VOID) {
4626 PL_stack_sp = oldsp;
4627 /* free now to avoid late-called destructors clobbering $@ */
4631 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4635 retop = cx->blk_eval.retop;
4646 const U8 gimme = GIMME_V;
4650 assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4651 GvSV(PL_defgv) = SvREFCNT_inc(newsv);
4653 cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
4654 cx_pushgiven(cx, origsv);
4664 PERL_UNUSED_CONTEXT;
4667 assert(CxTYPE(cx) == CXt_GIVEN);
4668 oldsp = PL_stack_base + cx->blk_oldsp;
4669 gimme = cx->blk_gimme;
4671 if (gimme == G_VOID)
4672 PL_stack_sp = oldsp;
4674 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4684 /* Helper routines used by pp_smartmatch */
4686 S_make_matcher(pTHX_ REGEXP *re)
4688 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4690 PERL_ARGS_ASSERT_MAKE_MATCHER;
4692 PM_SETRE(matcher, ReREFCNT_inc(re));
4694 SAVEFREEOP((OP *) matcher);
4695 ENTER_with_name("matcher"); SAVETMPS;
4701 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4706 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4708 PL_op = (OP *) matcher;
4711 (void) Perl_pp_match(aTHX);
4713 result = SvTRUEx(POPs);
4720 S_destroy_matcher(pTHX_ PMOP *matcher)
4722 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4723 PERL_UNUSED_ARG(matcher);
4726 LEAVE_with_name("matcher");
4729 /* Do a smart match */
4732 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4733 return do_smartmatch(NULL, NULL, 0);
4736 /* This version of do_smartmatch() implements the
4737 * table of smart matches that is found in perlsyn.
4740 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4744 bool object_on_left = FALSE;
4745 SV *e = TOPs; /* e is for 'expression' */
4746 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4748 /* Take care only to invoke mg_get() once for each argument.
4749 * Currently we do this by copying the SV if it's magical. */
4751 if (!copied && SvGMAGICAL(d))
4752 d = sv_mortalcopy(d);
4759 e = sv_mortalcopy(e);
4761 /* First of all, handle overload magic of the rightmost argument */
4764 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4765 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4767 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4774 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4777 SP -= 2; /* Pop the values */
4782 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4789 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4790 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4791 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4793 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4794 object_on_left = TRUE;
4797 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4799 if (object_on_left) {
4800 goto sm_any_sub; /* Treat objects like scalars */
4802 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4803 /* Test sub truth for each key */
4805 bool andedresults = TRUE;
4806 HV *hv = (HV*) SvRV(d);
4807 I32 numkeys = hv_iterinit(hv);
4808 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4811 while ( (he = hv_iternext(hv)) ) {
4812 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4813 ENTER_with_name("smartmatch_hash_key_test");
4816 PUSHs(hv_iterkeysv(he));
4818 c = call_sv(e, G_SCALAR);
4821 andedresults = FALSE;
4823 andedresults = SvTRUEx(POPs) && andedresults;
4825 LEAVE_with_name("smartmatch_hash_key_test");
4832 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4833 /* Test sub truth for each element */
4835 bool andedresults = TRUE;
4836 AV *av = (AV*) SvRV(d);
4837 const I32 len = av_tindex(av);
4838 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4841 for (i = 0; i <= len; ++i) {
4842 SV * const * const svp = av_fetch(av, i, FALSE);
4843 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4844 ENTER_with_name("smartmatch_array_elem_test");
4850 c = call_sv(e, G_SCALAR);
4853 andedresults = FALSE;
4855 andedresults = SvTRUEx(POPs) && andedresults;
4857 LEAVE_with_name("smartmatch_array_elem_test");
4866 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4867 ENTER_with_name("smartmatch_coderef");
4872 c = call_sv(e, G_SCALAR);
4876 else if (SvTEMP(TOPs))
4877 SvREFCNT_inc_void(TOPs);
4879 LEAVE_with_name("smartmatch_coderef");
4884 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4885 if (object_on_left) {
4886 goto sm_any_hash; /* Treat objects like scalars */
4888 else if (!SvOK(d)) {
4889 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4892 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4893 /* Check that the key-sets are identical */
4895 HV *other_hv = MUTABLE_HV(SvRV(d));
4898 U32 this_key_count = 0,
4899 other_key_count = 0;
4900 HV *hv = MUTABLE_HV(SvRV(e));
4902 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4903 /* Tied hashes don't know how many keys they have. */
4904 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4905 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4909 HV * const temp = other_hv;
4915 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4919 /* The hashes have the same number of keys, so it suffices
4920 to check that one is a subset of the other. */
4921 (void) hv_iterinit(hv);
4922 while ( (he = hv_iternext(hv)) ) {
4923 SV *key = hv_iterkeysv(he);
4925 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4928 if(!hv_exists_ent(other_hv, key, 0)) {
4929 (void) hv_iterinit(hv); /* reset iterator */
4935 (void) hv_iterinit(other_hv);
4936 while ( hv_iternext(other_hv) )
4940 other_key_count = HvUSEDKEYS(other_hv);
4942 if (this_key_count != other_key_count)
4947 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4948 AV * const other_av = MUTABLE_AV(SvRV(d));
4949 const SSize_t other_len = av_tindex(other_av) + 1;
4951 HV *hv = MUTABLE_HV(SvRV(e));
4953 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4954 for (i = 0; i < other_len; ++i) {
4955 SV ** const svp = av_fetch(other_av, i, FALSE);
4956 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4957 if (svp) { /* ??? When can this not happen? */
4958 if (hv_exists_ent(hv, *svp, 0))
4964 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4965 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4968 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4970 HV *hv = MUTABLE_HV(SvRV(e));
4972 (void) hv_iterinit(hv);
4973 while ( (he = hv_iternext(hv)) ) {
4974 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4976 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4978 (void) hv_iterinit(hv);
4979 destroy_matcher(matcher);
4984 destroy_matcher(matcher);
4990 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4991 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4998 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4999 if (object_on_left) {
5000 goto sm_any_array; /* Treat objects like scalars */
5002 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5003 AV * const other_av = MUTABLE_AV(SvRV(e));
5004 const SSize_t other_len = av_tindex(other_av) + 1;
5007 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
5008 for (i = 0; i < other_len; ++i) {
5009 SV ** const svp = av_fetch(other_av, i, FALSE);
5011 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
5012 if (svp) { /* ??? When can this not happen? */
5013 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
5019 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5020 AV *other_av = MUTABLE_AV(SvRV(d));
5021 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
5022 if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
5026 const SSize_t other_len = av_tindex(other_av);
5028 if (NULL == seen_this) {
5029 seen_this = newHV();
5030 (void) sv_2mortal(MUTABLE_SV(seen_this));
5032 if (NULL == seen_other) {
5033 seen_other = newHV();
5034 (void) sv_2mortal(MUTABLE_SV(seen_other));
5036 for(i = 0; i <= other_len; ++i) {
5037 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5038 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
5040 if (!this_elem || !other_elem) {
5041 if ((this_elem && SvOK(*this_elem))
5042 || (other_elem && SvOK(*other_elem)))
5045 else if (hv_exists_ent(seen_this,
5046 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
5047 hv_exists_ent(seen_other,
5048 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
5050 if (*this_elem != *other_elem)
5054 (void)hv_store_ent(seen_this,
5055 sv_2mortal(newSViv(PTR2IV(*this_elem))),
5057 (void)hv_store_ent(seen_other,
5058 sv_2mortal(newSViv(PTR2IV(*other_elem))),
5064 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
5065 (void) do_smartmatch(seen_this, seen_other, 0);
5067 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
5076 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
5077 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
5080 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
5081 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5084 for(i = 0; i <= this_len; ++i) {
5085 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5086 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
5088 if (svp && matcher_matches_sv(matcher, *svp)) {
5090 destroy_matcher(matcher);
5095 destroy_matcher(matcher);
5099 else if (!SvOK(d)) {
5100 /* undef ~~ array */
5101 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5104 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
5105 for (i = 0; i <= this_len; ++i) {
5106 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5107 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
5108 if (!svp || !SvOK(*svp))
5117 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
5119 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
5120 for (i = 0; i <= this_len; ++i) {
5121 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5128 /* infinite recursion isn't supposed to happen here */
5129 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
5130 (void) do_smartmatch(NULL, NULL, 1);
5132 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
5141 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
5142 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5143 SV *t = d; d = e; e = t;
5144 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
5147 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5148 SV *t = d; d = e; e = t;
5149 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
5150 goto sm_regex_array;
5153 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
5156 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
5158 result = matcher_matches_sv(matcher, d);
5160 PUSHs(result ? &PL_sv_yes : &PL_sv_no);
5161 destroy_matcher(matcher);
5166 /* See if there is overload magic on left */
5167 else if (object_on_left && SvAMAGIC(d)) {
5169 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
5170 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
5173 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
5181 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
5184 else if (!SvOK(d)) {
5185 /* undef ~~ scalar ; we already know that the scalar is SvOK */
5186 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
5191 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
5192 DEBUG_M(if (SvNIOK(e))
5193 Perl_deb(aTHX_ " applying rule Any-Num\n");
5195 Perl_deb(aTHX_ " applying rule Num-numish\n");
5197 /* numeric comparison */
5200 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
5201 (void) Perl_pp_i_eq(aTHX);
5203 (void) Perl_pp_eq(aTHX);
5211 /* As a last resort, use string comparison */
5212 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
5215 return Perl_pp_seq(aTHX);
5222 const U8 gimme = GIMME_V;
5224 /* This is essentially an optimization: if the match
5225 fails, we don't want to push a context and then
5226 pop it again right away, so we skip straight
5227 to the op that follows the leavewhen.
5228 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5230 if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) {
5231 if (gimme == G_SCALAR)
5232 PUSHs(&PL_sv_undef);
5233 RETURNOP(cLOGOP->op_other->op_next);
5236 cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
5250 assert(CxTYPE(cx) == CXt_WHEN);
5251 gimme = cx->blk_gimme;
5253 cxix = dopoptogivenfor(cxstack_ix);
5255 /* diag_listed_as: Can't "when" outside a topicalizer */
5256 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5257 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5259 oldsp = PL_stack_base + cx->blk_oldsp;
5260 if (gimme == G_VOID)
5261 PL_stack_sp = oldsp;
5263 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5265 /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
5266 assert(cxix < cxstack_ix);
5269 cx = &cxstack[cxix];
5271 if (CxFOREACH(cx)) {
5272 /* emulate pp_next. Note that any stack(s) cleanup will be
5273 * done by the pp_unstack which op_nextop should point to */
5276 PL_curcop = cx->blk_oldcop;
5277 return cx->blk_loop.my_op->op_nextop;
5281 assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
5282 return cx->blk_givwhen.leave_op;
5292 cxix = dopoptowhen(cxstack_ix);
5294 DIE(aTHX_ "Can't \"continue\" outside a when block");
5296 if (cxix < cxstack_ix)
5300 assert(CxTYPE(cx) == CXt_WHEN);
5301 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5305 nextop = cx->blk_givwhen.leave_op->op_next;
5316 cxix = dopoptogivenfor(cxstack_ix);
5318 DIE(aTHX_ "Can't \"break\" outside a given block");
5320 cx = &cxstack[cxix];
5322 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5324 if (cxix < cxstack_ix)
5327 /* Restore the sp at the time we entered the given block */
5329 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5331 return cx->blk_givwhen.leave_op;
5335 S_doparseform(pTHX_ SV *sv)
5338 char *s = SvPV(sv, len);
5340 char *base = NULL; /* start of current field */
5341 I32 skipspaces = 0; /* number of contiguous spaces seen */
5342 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5343 bool repeat = FALSE; /* ~~ seen on this line */
5344 bool postspace = FALSE; /* a text field may need right padding */
5347 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5349 bool ischop; /* it's a ^ rather than a @ */
5350 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5351 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5355 PERL_ARGS_ASSERT_DOPARSEFORM;
5358 Perl_croak(aTHX_ "Null picture in formline");
5360 if (SvTYPE(sv) >= SVt_PVMG) {
5361 /* This might, of course, still return NULL. */
5362 mg = mg_find(sv, PERL_MAGIC_fm);
5364 sv_upgrade(sv, SVt_PVMG);
5368 /* still the same as previously-compiled string? */
5369 SV *old = mg->mg_obj;
5370 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5371 && len == SvCUR(old)
5372 && strnEQ(SvPVX(old), s, len)
5374 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5378 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5379 Safefree(mg->mg_ptr);
5385 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5386 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5389 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5390 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5394 /* estimate the buffer size needed */
5395 for (base = s; s <= send; s++) {
5396 if (*s == '\n' || *s == '@' || *s == '^')
5402 Newx(fops, maxops, U32);
5407 *fpc++ = FF_LINEMARK;
5408 noblank = repeat = FALSE;
5426 case ' ': case '\t':
5442 *fpc++ = FF_LITERAL;
5450 *fpc++ = (U32)skipspaces;
5454 *fpc++ = FF_NEWLINE;
5458 arg = fpc - linepc + 1;
5465 *fpc++ = FF_LINEMARK;
5466 noblank = repeat = FALSE;
5475 ischop = s[-1] == '^';
5481 arg = (s - base) - 1;
5483 *fpc++ = FF_LITERAL;
5489 if (*s == '*') { /* @* or ^* */
5491 *fpc++ = 2; /* skip the @* or ^* */
5493 *fpc++ = FF_LINESNGL;
5496 *fpc++ = FF_LINEGLOB;
5498 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5499 arg = ischop ? FORM_NUM_BLANK : 0;
5504 const char * const f = ++s;
5507 arg |= FORM_NUM_POINT + (s - f);
5509 *fpc++ = s - base; /* fieldsize for FETCH */
5510 *fpc++ = FF_DECIMAL;
5512 unchopnum |= ! ischop;
5514 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5515 arg = ischop ? FORM_NUM_BLANK : 0;
5517 s++; /* skip the '0' first */
5521 const char * const f = ++s;
5524 arg |= FORM_NUM_POINT + (s - f);
5526 *fpc++ = s - base; /* fieldsize for FETCH */
5527 *fpc++ = FF_0DECIMAL;
5529 unchopnum |= ! ischop;
5531 else { /* text field */
5533 bool ismore = FALSE;
5536 while (*++s == '>') ;
5537 prespace = FF_SPACE;
5539 else if (*s == '|') {
5540 while (*++s == '|') ;
5541 prespace = FF_HALFSPACE;
5546 while (*++s == '<') ;
5549 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5553 *fpc++ = s - base; /* fieldsize for FETCH */
5555 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5558 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5572 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5575 mg->mg_ptr = (char *) fops;
5576 mg->mg_len = arg * sizeof(U32);
5577 mg->mg_obj = sv_copy;
5578 mg->mg_flags |= MGf_REFCOUNTED;
5580 if (unchopnum && repeat)
5581 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5588 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5590 /* Can value be printed in fldsize chars, using %*.*f ? */
5594 int intsize = fldsize - (value < 0 ? 1 : 0);
5596 if (frcsize & FORM_NUM_POINT)
5598 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5601 while (intsize--) pwr *= 10.0;
5602 while (frcsize--) eps /= 10.0;
5605 if (value + eps >= pwr)
5608 if (value - eps <= -pwr)
5615 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5617 SV * const datasv = FILTER_DATA(idx);
5618 const int filter_has_file = IoLINES(datasv);
5619 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5620 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5625 char *prune_from = NULL;
5626 bool read_from_cache = FALSE;
5630 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5632 assert(maxlen >= 0);
5635 /* I was having segfault trouble under Linux 2.2.5 after a
5636 parse error occurred. (Had to hack around it with a test
5637 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5638 not sure where the trouble is yet. XXX */
5641 SV *const cache = datasv;
5644 const char *cache_p = SvPV(cache, cache_len);
5648 /* Running in block mode and we have some cached data already.
5650 if (cache_len >= umaxlen) {
5651 /* In fact, so much data we don't even need to call
5656 const char *const first_nl =
5657 (const char *)memchr(cache_p, '\n', cache_len);
5659 take = first_nl + 1 - cache_p;
5663 sv_catpvn(buf_sv, cache_p, take);
5664 sv_chop(cache, cache_p + take);
5665 /* Definitely not EOF */
5669 sv_catsv(buf_sv, cache);
5671 umaxlen -= cache_len;
5674 read_from_cache = TRUE;
5678 /* Filter API says that the filter appends to the contents of the buffer.
5679 Usually the buffer is "", so the details don't matter. But if it's not,
5680 then clearly what it contains is already filtered by this filter, so we
5681 don't want to pass it in a second time.
5682 I'm going to use a mortal in case the upstream filter croaks. */
5683 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5684 ? sv_newmortal() : buf_sv;
5685 SvUPGRADE(upstream, SVt_PV);
5687 if (filter_has_file) {
5688 status = FILTER_READ(idx+1, upstream, 0);
5691 if (filter_sub && status >= 0) {
5695 ENTER_with_name("call_filter_sub");
5700 DEFSV_set(upstream);
5704 PUSHs(filter_state);
5707 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5717 SV * const errsv = ERRSV;
5718 if (SvTRUE_NN(errsv))
5719 err = newSVsv(errsv);
5725 LEAVE_with_name("call_filter_sub");
5728 if (SvGMAGICAL(upstream)) {
5730 if (upstream == buf_sv) mg_free(buf_sv);
5732 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5733 if(!err && SvOK(upstream)) {
5734 got_p = SvPV_nomg(upstream, got_len);
5736 if (got_len > umaxlen) {
5737 prune_from = got_p + umaxlen;
5740 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5741 if (first_nl && first_nl + 1 < got_p + got_len) {
5742 /* There's a second line here... */
5743 prune_from = first_nl + 1;
5747 if (!err && prune_from) {
5748 /* Oh. Too long. Stuff some in our cache. */
5749 STRLEN cached_len = got_p + got_len - prune_from;
5750 SV *const cache = datasv;
5753 /* Cache should be empty. */
5754 assert(!SvCUR(cache));
5757 sv_setpvn(cache, prune_from, cached_len);
5758 /* If you ask for block mode, you may well split UTF-8 characters.
5759 "If it breaks, you get to keep both parts"
5760 (Your code is broken if you don't put them back together again
5761 before something notices.) */
5762 if (SvUTF8(upstream)) {
5765 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5767 /* Cannot just use sv_setpvn, as that could free the buffer
5768 before we have a chance to assign it. */
5769 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5770 got_len - cached_len);
5772 /* Can't yet be EOF */
5777 /* If they are at EOF but buf_sv has something in it, then they may never
5778 have touched the SV upstream, so it may be undefined. If we naively
5779 concatenate it then we get a warning about use of uninitialised value.
5781 if (!err && upstream != buf_sv &&
5783 sv_catsv_nomg(buf_sv, upstream);
5785 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5788 IoLINES(datasv) = 0;
5790 SvREFCNT_dec(filter_state);
5791 IoTOP_GV(datasv) = NULL;
5794 SvREFCNT_dec(filter_sub);
5795 IoBOTTOM_GV(datasv) = NULL;
5797 filter_del(S_run_user_filter);
5803 if (status == 0 && read_from_cache) {
5804 /* If we read some data from the cache (and by getting here it implies
5805 that we emptied the cache) then we aren't yet at EOF, and mustn't
5806 report that to our caller. */
5813 * ex: set ts=8 sts=4 sw=4 et: