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 DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
39 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
45 const PERL_CONTEXT *cx;
48 if (PL_op->op_private & OPpOFFBYONE) {
49 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
52 cxix = dopoptosub(cxstack_ix);
58 switch (cx->blk_gimme) {
77 PMOP *pm = (PMOP*)cLOGOP->op_other;
82 const regexp_engine *eng;
83 bool is_bare_re= FALSE;
85 if (PL_op->op_flags & OPf_STACKED) {
95 /* prevent recompiling under /o and ithreads. */
96 #if defined(USE_ITHREADS)
97 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
104 assert (re != (REGEXP*) &PL_sv_undef);
105 eng = re ? RX_ENGINE(re) : current_re_engine();
108 In the below logic: these are basically the same - check if this regcomp is part of a split.
110 (PL_op->op_pmflags & PMf_split )
111 (PL_op->op_next->op_type == OP_PUSHRE)
113 We could add a new mask for this and copy the PMf_split, if we did
114 some bit definition fiddling first.
116 For now we leave this
119 new_re = (eng->op_comp
121 : &Perl_re_op_compile
122 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
124 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
126 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
128 if (pm->op_pmflags & PMf_HAS_CV)
129 ReANY(new_re)->qr_anoncv
130 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
134 /* The match's LHS's get-magic might need to access this op's regexp
135 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
136 get-magic now before we replace the regexp. Hopefully this hack can
137 be replaced with the approach described at
138 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
140 if (pm->op_type == OP_MATCH) {
142 const bool was_tainted = TAINT_get;
143 if (pm->op_flags & OPf_STACKED)
145 else if (pm->op_targ)
146 lhs = PAD_SV(pm->op_targ);
149 /* Restore the previous value of PL_tainted (which may have been
150 modified by get-magic), to avoid incorrectly setting the
151 RXf_TAINTED flag with RX_TAINT_on further down. */
152 TAINT_set(was_tainted);
153 #ifdef NO_TAINT_SUPPORT
154 PERL_UNUSED_VAR(was_tainted);
157 tmp = reg_temp_copy(NULL, new_re);
158 ReREFCNT_dec(new_re);
164 PM_SETRE(pm, new_re);
168 assert(TAINTING_get || !TAINT_get);
170 SvTAINTED_on((SV*)new_re);
174 #if !defined(USE_ITHREADS)
175 /* can't change the optree at runtime either */
176 /* PMf_KEEP is handled differently under threads to avoid these problems */
177 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
179 if (pm->op_pmflags & PMf_KEEP) {
180 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
181 cLOGOP->op_first->op_next = PL_op->op_next;
193 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
194 PMOP * const pm = (PMOP*) cLOGOP->op_other;
195 SV * const dstr = cx->sb_dstr;
198 char *orig = cx->sb_orig;
199 REGEXP * const rx = cx->sb_rx;
201 REGEXP *old = PM_GETRE(pm);
208 PM_SETRE(pm,ReREFCNT_inc(rx));
211 rxres_restore(&cx->sb_rxres, rx);
213 if (cx->sb_iters++) {
214 const SSize_t saviters = cx->sb_iters;
215 if (cx->sb_iters > cx->sb_maxiters)
216 DIE(aTHX_ "Substitution loop");
218 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
220 /* See "how taint works" above pp_subst() */
222 cx->sb_rxtainted |= SUBST_TAINT_REPL;
223 sv_catsv_nomg(dstr, POPs);
224 if (CxONCE(cx) || s < orig ||
225 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
226 (s == m), cx->sb_targ, NULL,
227 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
229 SV *targ = cx->sb_targ;
231 assert(cx->sb_strend >= s);
232 if(cx->sb_strend > s) {
233 if (DO_UTF8(dstr) && !SvUTF8(targ))
234 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
236 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
238 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
239 cx->sb_rxtainted |= SUBST_TAINT_PAT;
241 if (pm->op_pmflags & PMf_NONDESTRUCT) {
243 /* From here on down we're using the copy, and leaving the
244 original untouched. */
248 SV_CHECK_THINKFIRST_COW_DROP(targ);
249 if (isGV(targ)) Perl_croak_no_modify();
251 SvPV_set(targ, SvPVX(dstr));
252 SvCUR_set(targ, SvCUR(dstr));
253 SvLEN_set(targ, SvLEN(dstr));
256 SvPV_set(dstr, NULL);
259 mPUSHi(saviters - 1);
261 (void)SvPOK_only_UTF8(targ);
264 /* update the taint state of various various variables in
265 * preparation for final exit.
266 * See "how taint works" above pp_subst() */
268 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
269 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
270 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
272 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
274 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
275 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
277 SvTAINTED_on(TOPs); /* taint return value */
278 /* needed for mg_set below */
280 cBOOL(cx->sb_rxtainted &
281 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
285 /* PL_tainted must be correctly set for this mg_set */
288 LEAVE_SCOPE(cx->sb_oldsave);
291 RETURNOP(pm->op_next);
292 NOT_REACHED; /* NOTREACHED */
294 cx->sb_iters = saviters;
296 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
299 assert(!RX_SUBOFFSET(rx));
300 cx->sb_orig = orig = RX_SUBBEG(rx);
302 cx->sb_strend = s + (cx->sb_strend - m);
304 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
306 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
307 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
309 sv_catpvn_nomg(dstr, s, m-s);
311 cx->sb_s = RX_OFFS(rx)[0].end + orig;
312 { /* Update the pos() information. */
314 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
317 /* the string being matched against may no longer be a string,
318 * e.g. $_=0; s/.../$_++/ge */
321 SvPV_force_nomg_nolen(sv);
323 if (!(mg = mg_find_mglob(sv))) {
324 mg = sv_magicext_mglob(sv);
326 MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
329 (void)ReREFCNT_inc(rx);
330 /* update the taint state of various various variables in preparation
331 * for calling the code block.
332 * See "how taint works" above pp_subst() */
334 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
335 cx->sb_rxtainted |= SUBST_TAINT_PAT;
337 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
338 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
339 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
341 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
343 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
344 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
345 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
346 ? cx->sb_dstr : cx->sb_targ);
349 rxres_save(&cx->sb_rxres, rx);
351 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
355 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
360 PERL_ARGS_ASSERT_RXRES_SAVE;
363 if (!p || p[1] < RX_NPARENS(rx)) {
365 i = 7 + (RX_NPARENS(rx)+1) * 2;
367 i = 6 + (RX_NPARENS(rx)+1) * 2;
376 /* what (if anything) to free on croak */
377 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
378 RX_MATCH_COPIED_off(rx);
379 *p++ = RX_NPARENS(rx);
382 *p++ = PTR2UV(RX_SAVED_COPY(rx));
383 RX_SAVED_COPY(rx) = NULL;
386 *p++ = PTR2UV(RX_SUBBEG(rx));
387 *p++ = (UV)RX_SUBLEN(rx);
388 *p++ = (UV)RX_SUBOFFSET(rx);
389 *p++ = (UV)RX_SUBCOFFSET(rx);
390 for (i = 0; i <= RX_NPARENS(rx); ++i) {
391 *p++ = (UV)RX_OFFS(rx)[i].start;
392 *p++ = (UV)RX_OFFS(rx)[i].end;
397 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
402 PERL_ARGS_ASSERT_RXRES_RESTORE;
405 RX_MATCH_COPY_FREE(rx);
406 RX_MATCH_COPIED_set(rx, *p);
408 RX_NPARENS(rx) = *p++;
411 if (RX_SAVED_COPY(rx))
412 SvREFCNT_dec (RX_SAVED_COPY(rx));
413 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
417 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
418 RX_SUBLEN(rx) = (I32)(*p++);
419 RX_SUBOFFSET(rx) = (I32)*p++;
420 RX_SUBCOFFSET(rx) = (I32)*p++;
421 for (i = 0; i <= RX_NPARENS(rx); ++i) {
422 RX_OFFS(rx)[i].start = (I32)(*p++);
423 RX_OFFS(rx)[i].end = (I32)(*p++);
428 S_rxres_free(pTHX_ void **rsp)
430 UV * const p = (UV*)*rsp;
432 PERL_ARGS_ASSERT_RXRES_FREE;
436 void *tmp = INT2PTR(char*,*p);
439 U32 i = 9 + p[1] * 2;
441 U32 i = 8 + p[1] * 2;
446 SvREFCNT_dec (INT2PTR(SV*,p[2]));
449 PoisonFree(p, i, sizeof(UV));
458 #define FORM_NUM_BLANK (1<<30)
459 #define FORM_NUM_POINT (1<<29)
463 dSP; dMARK; dORIGMARK;
464 SV * const tmpForm = *++MARK;
465 SV *formsv; /* contains text of original format */
466 U32 *fpc; /* format ops program counter */
467 char *t; /* current append position in target string */
468 const char *f; /* current position in format string */
470 SV *sv = NULL; /* current item */
471 const char *item = NULL;/* string value of current item */
472 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
473 I32 itembytes = 0; /* as itemsize, but length in bytes */
474 I32 fieldsize = 0; /* width of current field */
475 I32 lines = 0; /* number of lines that have been output */
476 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
477 const char *chophere = NULL; /* where to chop current item */
478 STRLEN linemark = 0; /* pos of start of line in output */
480 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
481 STRLEN len; /* length of current sv */
482 STRLEN linemax; /* estimate of output size in bytes */
483 bool item_is_utf8 = FALSE;
484 bool targ_is_utf8 = FALSE;
487 U8 *source; /* source of bytes to append */
488 STRLEN to_copy; /* how may bytes to append */
489 char trans; /* what chars to translate */
491 mg = doparseform(tmpForm);
493 fpc = (U32*)mg->mg_ptr;
494 /* the actual string the format was compiled from.
495 * with overload etc, this may not match tmpForm */
499 SvPV_force(PL_formtarget, len);
500 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
501 SvTAINTED_on(PL_formtarget);
502 if (DO_UTF8(PL_formtarget))
504 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
505 t = SvGROW(PL_formtarget, len + linemax + 1);
506 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
508 f = SvPV_const(formsv, len);
512 const char *name = "???";
515 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
516 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
517 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
518 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
519 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
521 case FF_CHECKNL: name = "CHECKNL"; break;
522 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
523 case FF_SPACE: name = "SPACE"; break;
524 case FF_HALFSPACE: name = "HALFSPACE"; break;
525 case FF_ITEM: name = "ITEM"; break;
526 case FF_CHOP: name = "CHOP"; break;
527 case FF_LINEGLOB: name = "LINEGLOB"; break;
528 case FF_NEWLINE: name = "NEWLINE"; break;
529 case FF_MORE: name = "MORE"; break;
530 case FF_LINEMARK: name = "LINEMARK"; break;
531 case FF_END: name = "END"; break;
532 case FF_0DECIMAL: name = "0DECIMAL"; break;
533 case FF_LINESNGL: name = "LINESNGL"; break;
536 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
538 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
541 case FF_LINEMARK: /* start (or end) of a line */
542 linemark = t - SvPVX(PL_formtarget);
547 case FF_LITERAL: /* append <arg> literal chars */
552 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
555 case FF_SKIP: /* skip <arg> chars in format */
559 case FF_FETCH: /* get next item and set field size to <arg> */
568 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
571 SvTAINTED_on(PL_formtarget);
574 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
576 const char *s = item = SvPV_const(sv, len);
577 const char *send = s + len;
580 item_is_utf8 = DO_UTF8(sv);
592 if (itemsize == fieldsize)
595 itembytes = s - item;
600 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
602 const char *s = item = SvPV_const(sv, len);
603 const char *send = s + len;
607 item_is_utf8 = DO_UTF8(sv);
609 /* look for a legal split position */
617 /* provisional split point */
621 /* we delay testing fieldsize until after we've
622 * processed the possible split char directly
623 * following the last field char; so if fieldsize=3
624 * and item="a b cdef", we consume "a b", not "a".
625 * Ditto further down.
627 if (size == fieldsize)
631 if (strchr(PL_chopset, *s)) {
632 /* provisional split point */
633 /* for a non-space split char, we include
634 * the split char; hence the '+1' */
638 if (size == fieldsize)
650 if (!chophere || s == send) {
654 itembytes = chophere - item;
659 case FF_SPACE: /* append padding space (diff of field, item size) */
660 arg = fieldsize - itemsize;
668 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
669 arg = fieldsize - itemsize;
678 case FF_ITEM: /* append a text item, while blanking ctrl chars */
684 case FF_CHOP: /* (for ^*) chop the current item */
685 if (sv != &PL_sv_no) {
686 const char *s = chophere;
694 /* tied, overloaded or similar strangeness.
695 * Do it the hard way */
696 sv_setpvn(sv, s, len - (s-item));
701 case FF_LINESNGL: /* process ^* */
705 case FF_LINEGLOB: /* process @* */
707 const bool oneline = fpc[-1] == FF_LINESNGL;
708 const char *s = item = SvPV_const(sv, len);
709 const char *const send = s + len;
711 item_is_utf8 = DO_UTF8(sv);
722 to_copy = s - item - 1;
736 /* append to_copy bytes from source to PL_formstring.
737 * item_is_utf8 implies source is utf8.
738 * if trans, translate certain characters during the copy */
743 SvCUR_set(PL_formtarget,
744 t - SvPVX_const(PL_formtarget));
746 if (targ_is_utf8 && !item_is_utf8) {
747 source = tmp = bytes_to_utf8(source, &to_copy);
749 if (item_is_utf8 && !targ_is_utf8) {
751 /* Upgrade targ to UTF8, and then we reduce it to
752 a problem we have a simple solution for.
753 Don't need get magic. */
754 sv_utf8_upgrade_nomg(PL_formtarget);
756 /* re-calculate linemark */
757 s = (U8*)SvPVX(PL_formtarget);
758 /* the bytes we initially allocated to append the
759 * whole line may have been gobbled up during the
760 * upgrade, so allocate a whole new line's worth
765 linemark = s - (U8*)SvPVX(PL_formtarget);
767 /* Easy. They agree. */
768 assert (item_is_utf8 == targ_is_utf8);
771 /* @* and ^* are the only things that can exceed
772 * the linemax, so grow by the output size, plus
773 * a whole new form's worth in case of any further
775 grow = linemax + to_copy;
777 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
778 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
780 Copy(source, t, to_copy, char);
782 /* blank out ~ or control chars, depending on trans.
783 * works on bytes not chars, so relies on not
784 * matching utf8 continuation bytes */
786 U8 *send = s + to_copy;
789 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
796 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
802 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
805 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
808 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
811 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
813 /* If the field is marked with ^ and the value is undefined,
815 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
823 /* overflow evidence */
824 if (num_overflow(value, fieldsize, arg)) {
830 /* Formats aren't yet marked for locales, so assume "yes". */
832 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
834 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
835 STORE_LC_NUMERIC_SET_TO_NEEDED();
836 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
839 const char* qfmt = quadmath_format_single(fmt);
842 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
843 len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
845 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
850 /* we generate fmt ourselves so it is safe */
851 GCC_DIAG_IGNORE(-Wformat-nonliteral);
852 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
855 PERL_MY_SNPRINTF_POST_GUARD(len, max);
856 RESTORE_LC_NUMERIC();
861 case FF_NEWLINE: /* delete trailing spaces, then append \n */
863 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
868 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
871 if (arg) { /* repeat until fields exhausted? */
877 t = SvPVX(PL_formtarget) + linemark;
882 case FF_MORE: /* replace long end of string with '...' */
884 const char *s = chophere;
885 const char *send = item + len;
887 while (isSPACE(*s) && (s < send))
892 arg = fieldsize - itemsize;
899 if (strnEQ(s1," ",3)) {
900 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
910 case FF_END: /* tidy up, then return */
912 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
914 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
916 SvUTF8_on(PL_formtarget);
917 FmLINES(PL_formtarget) += lines;
919 if (fpc[-1] == FF_BLANK)
920 RETURNOP(cLISTOP->op_first);
932 if (PL_stack_base + TOPMARK == SP) {
934 if (GIMME_V == G_SCALAR)
936 RETURNOP(PL_op->op_next->op_next);
938 PL_stack_sp = PL_stack_base + TOPMARK + 1;
939 Perl_pp_pushmark(aTHX); /* push dst */
940 Perl_pp_pushmark(aTHX); /* push src */
941 ENTER_with_name("grep"); /* enter outer scope */
945 ENTER_with_name("grep_item"); /* enter inner scope */
948 src = PL_stack_base[TOPMARK];
950 src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
957 if (PL_op->op_type == OP_MAPSTART)
958 Perl_pp_pushmark(aTHX); /* push top */
959 return ((LOGOP*)PL_op->op_next)->op_other;
965 const I32 gimme = GIMME_V;
966 I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
972 /* first, move source pointer to the next item in the source list */
973 ++PL_markstack_ptr[-1];
975 /* if there are new items, push them into the destination list */
976 if (items && gimme != G_VOID) {
977 /* might need to make room back there first */
978 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
979 /* XXX this implementation is very pessimal because the stack
980 * is repeatedly extended for every set of items. Is possible
981 * to do this without any stack extension or copying at all
982 * by maintaining a separate list over which the map iterates
983 * (like foreach does). --gsar */
985 /* everything in the stack after the destination list moves
986 * towards the end the stack by the amount of room needed */
987 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
989 /* items to shift up (accounting for the moved source pointer) */
990 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
992 /* This optimization is by Ben Tilly and it does
993 * things differently from what Sarathy (gsar)
994 * is describing. The downside of this optimization is
995 * that leaves "holes" (uninitialized and hopefully unused areas)
996 * to the Perl stack, but on the other hand this
997 * shouldn't be a problem. If Sarathy's idea gets
998 * implemented, this optimization should become
999 * irrelevant. --jhi */
1001 shift = count; /* Avoid shifting too often --Ben Tilly */
1005 dst = (SP += shift);
1006 PL_markstack_ptr[-1] += shift;
1007 *PL_markstack_ptr += shift;
1011 /* copy the new items down to the destination list */
1012 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1013 if (gimme == G_ARRAY) {
1014 /* add returned items to the collection (making mortal copies
1015 * if necessary), then clear the current temps stack frame
1016 * *except* for those items. We do this splicing the items
1017 * into the start of the tmps frame (so some items may be on
1018 * the tmps stack twice), then moving PL_tmps_floor above
1019 * them, then freeing the frame. That way, the only tmps that
1020 * accumulate over iterations are the return values for map.
1021 * We have to do to this way so that everything gets correctly
1022 * freed if we die during the map.
1026 /* make space for the slice */
1027 EXTEND_MORTAL(items);
1028 tmpsbase = PL_tmps_floor + 1;
1029 Move(PL_tmps_stack + tmpsbase,
1030 PL_tmps_stack + tmpsbase + items,
1031 PL_tmps_ix - PL_tmps_floor,
1033 PL_tmps_ix += items;
1038 sv = sv_mortalcopy(sv);
1040 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1042 /* clear the stack frame except for the items */
1043 PL_tmps_floor += items;
1045 /* FREETMPS may have cleared the TEMP flag on some of the items */
1048 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1051 /* scalar context: we don't care about which values map returns
1052 * (we use undef here). And so we certainly don't want to do mortal
1053 * copies of meaningless values. */
1054 while (items-- > 0) {
1056 *dst-- = &PL_sv_undef;
1064 LEAVE_with_name("grep_item"); /* exit inner scope */
1067 if (PL_markstack_ptr[-1] > TOPMARK) {
1069 (void)POPMARK; /* pop top */
1070 LEAVE_with_name("grep"); /* exit outer scope */
1071 (void)POPMARK; /* pop src */
1072 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1073 (void)POPMARK; /* pop dst */
1074 SP = PL_stack_base + POPMARK; /* pop original mark */
1075 if (gimme == G_SCALAR) {
1079 else if (gimme == G_ARRAY)
1086 ENTER_with_name("grep_item"); /* enter inner scope */
1089 /* set $_ to the new source item */
1090 src = PL_stack_base[PL_markstack_ptr[-1]];
1091 if (SvPADTMP(src)) {
1092 src = sv_mortalcopy(src);
1097 RETURNOP(cLOGOP->op_other);
1105 if (GIMME_V == G_ARRAY)
1107 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1108 return cLOGOP->op_other;
1117 if (GIMME_V == G_ARRAY) {
1118 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1122 SV * const targ = PAD_SV(PL_op->op_targ);
1125 if (PL_op->op_private & OPpFLIP_LINENUM) {
1126 if (GvIO(PL_last_in_gv)) {
1127 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1130 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1132 flip = SvIV(sv) == SvIV(GvSV(gv));
1138 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1139 if (PL_op->op_flags & OPf_SPECIAL) {
1147 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1150 sv_setpvs(TARG, "");
1156 /* This code tries to decide if "$left .. $right" should use the
1157 magical string increment, or if the range is numeric (we make
1158 an exception for .."0" [#18165]). AMS 20021031. */
1160 #define RANGE_IS_NUMERIC(left,right) ( \
1161 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1162 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1163 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1164 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1165 && (!SvOK(right) || looks_like_number(right))))
1171 if (GIMME_V == G_ARRAY) {
1177 if (RANGE_IS_NUMERIC(left,right)) {
1179 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1180 (SvOK(right) && (SvIOK(right)
1181 ? SvIsUV(right) && SvUV(right) > IV_MAX
1182 : SvNV_nomg(right) > IV_MAX)))
1183 DIE(aTHX_ "Range iterator outside integer range");
1184 i = SvIV_nomg(left);
1185 j = SvIV_nomg(right);
1187 /* Dance carefully around signed max. */
1188 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1191 /* The wraparound of signed integers is undefined
1192 * behavior, but here we aim for count >=1, and
1193 * negative count is just wrong. */
1195 #if IVSIZE > Size_t_size
1202 Perl_croak(aTHX_ "Out of memory during list extend");
1209 SV * const sv = sv_2mortal(newSViv(i));
1211 if (n) /* avoid incrementing above IV_MAX */
1217 const char * const lpv = SvPV_nomg_const(left, llen);
1218 const char * const tmps = SvPV_nomg_const(right, len);
1220 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1221 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1223 if (strEQ(SvPVX_const(sv),tmps))
1225 sv = sv_2mortal(newSVsv(sv));
1232 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1236 if (PL_op->op_private & OPpFLIP_LINENUM) {
1237 if (GvIO(PL_last_in_gv)) {
1238 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1241 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1242 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1250 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1251 sv_catpvs(targ, "E0");
1261 static const char * const context_name[] = {
1263 NULL, /* CXt_WHEN never actually needs "block" */
1264 NULL, /* CXt_BLOCK never actually needs "block" */
1265 NULL, /* CXt_GIVEN never actually needs "block" */
1266 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1267 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1268 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1269 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1277 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1281 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1283 for (i = cxstack_ix; i >= 0; i--) {
1284 const PERL_CONTEXT * const cx = &cxstack[i];
1285 switch (CxTYPE(cx)) {
1291 /* diag_listed_as: Exiting subroutine via %s */
1292 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1293 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1294 if (CxTYPE(cx) == CXt_NULL)
1297 case CXt_LOOP_LAZYIV:
1298 case CXt_LOOP_LAZYSV:
1300 case CXt_LOOP_PLAIN:
1302 STRLEN cx_label_len = 0;
1303 U32 cx_label_flags = 0;
1304 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1306 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1309 (const U8*)cx_label, cx_label_len,
1310 (const U8*)label, len) == 0)
1312 (const U8*)label, len,
1313 (const U8*)cx_label, cx_label_len) == 0)
1314 : (len == cx_label_len && ((cx_label == label)
1315 || memEQ(cx_label, label, len))) )) {
1316 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1317 (long)i, cx_label));
1320 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1331 Perl_dowantarray(pTHX)
1333 const I32 gimme = block_gimme();
1334 return (gimme == G_VOID) ? G_SCALAR : gimme;
1338 Perl_block_gimme(pTHX)
1340 const I32 cxix = dopoptosub(cxstack_ix);
1345 gimme = (cxstack[cxix].blk_gimme & G_WANT);
1347 Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1353 Perl_is_lvalue_sub(pTHX)
1355 const I32 cxix = dopoptosub(cxstack_ix);
1356 assert(cxix >= 0); /* We should only be called from inside subs */
1358 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1359 return CxLVAL(cxstack + cxix);
1364 /* only used by PUSHSUB */
1366 Perl_was_lvalue_sub(pTHX)
1368 const I32 cxix = dopoptosub(cxstack_ix-1);
1369 assert(cxix >= 0); /* We should only be called from inside subs */
1371 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1372 return CxLVAL(cxstack + cxix);
1378 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1382 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1384 PERL_UNUSED_CONTEXT;
1387 for (i = startingblock; i >= 0; i--) {
1388 const PERL_CONTEXT * const cx = &cxstk[i];
1389 switch (CxTYPE(cx)) {
1393 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1394 * twice; the first for the normal foo() call, and the second
1395 * for a faked up re-entry into the sub to execute the
1396 * code block. Hide this faked entry from the world. */
1397 if (cx->cx_type & CXp_SUB_RE_FAKE)
1402 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1410 S_dopoptoeval(pTHX_ I32 startingblock)
1413 for (i = startingblock; i >= 0; i--) {
1414 const PERL_CONTEXT *cx = &cxstack[i];
1415 switch (CxTYPE(cx)) {
1419 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1427 S_dopoptoloop(pTHX_ I32 startingblock)
1430 for (i = startingblock; i >= 0; i--) {
1431 const PERL_CONTEXT * const cx = &cxstack[i];
1432 switch (CxTYPE(cx)) {
1438 /* diag_listed_as: Exiting subroutine via %s */
1439 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1440 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1441 if ((CxTYPE(cx)) == CXt_NULL)
1444 case CXt_LOOP_LAZYIV:
1445 case CXt_LOOP_LAZYSV:
1447 case CXt_LOOP_PLAIN:
1448 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1456 S_dopoptogiven(pTHX_ I32 startingblock)
1459 for (i = startingblock; i >= 0; i--) {
1460 const PERL_CONTEXT *cx = &cxstack[i];
1461 switch (CxTYPE(cx)) {
1465 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1467 case CXt_LOOP_PLAIN:
1468 assert(!CxFOREACHDEF(cx));
1470 case CXt_LOOP_LAZYIV:
1471 case CXt_LOOP_LAZYSV:
1473 if (CxFOREACHDEF(cx)) {
1474 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1483 S_dopoptowhen(pTHX_ I32 startingblock)
1486 for (i = startingblock; i >= 0; i--) {
1487 const PERL_CONTEXT *cx = &cxstack[i];
1488 switch (CxTYPE(cx)) {
1492 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1500 Perl_dounwind(pTHX_ I32 cxix)
1504 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1507 while (cxstack_ix > cxix) {
1509 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1510 DEBUG_CX("UNWIND"); \
1511 /* Note: we don't need to restore the base context info till the end. */
1512 switch (CxTYPE(cx)) {
1515 continue; /* not break */
1523 case CXt_LOOP_LAZYIV:
1524 case CXt_LOOP_LAZYSV:
1526 case CXt_LOOP_PLAIN:
1537 PERL_UNUSED_VAR(optype);
1541 Perl_qerror(pTHX_ SV *err)
1543 PERL_ARGS_ASSERT_QERROR;
1546 if (PL_in_eval & EVAL_KEEPERR) {
1547 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1551 sv_catsv(ERRSV, err);
1554 sv_catsv(PL_errors, err);
1556 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1558 ++PL_parser->error_count;
1562 Perl_die_unwind(pTHX_ SV *msv)
1564 SV *exceptsv = sv_mortalcopy(msv);
1565 U8 in_eval = PL_in_eval;
1566 PERL_ARGS_ASSERT_DIE_UNWIND;
1573 * Historically, perl used to set ERRSV ($@) early in the die
1574 * process and rely on it not getting clobbered during unwinding.
1575 * That sucked, because it was liable to get clobbered, so the
1576 * setting of ERRSV used to emit the exception from eval{} has
1577 * been moved to much later, after unwinding (see just before
1578 * JMPENV_JUMP below). However, some modules were relying on the
1579 * early setting, by examining $@ during unwinding to use it as
1580 * a flag indicating whether the current unwinding was caused by
1581 * an exception. It was never a reliable flag for that purpose,
1582 * being totally open to false positives even without actual
1583 * clobberage, but was useful enough for production code to
1584 * semantically rely on it.
1586 * We'd like to have a proper introspective interface that
1587 * explicitly describes the reason for whatever unwinding
1588 * operations are currently in progress, so that those modules
1589 * work reliably and $@ isn't further overloaded. But we don't
1590 * have one yet. In its absence, as a stopgap measure, ERRSV is
1591 * now *additionally* set here, before unwinding, to serve as the
1592 * (unreliable) flag that it used to.
1594 * This behaviour is temporary, and should be removed when a
1595 * proper way to detect exceptional unwinding has been developed.
1596 * As of 2010-12, the authors of modules relying on the hack
1597 * are aware of the issue, because the modules failed on
1598 * perls 5.13.{1..7} which had late setting of $@ without this
1599 * early-setting hack.
1601 if (!(in_eval & EVAL_KEEPERR)) {
1602 SvTEMP_off(exceptsv);
1603 sv_setsv(ERRSV, exceptsv);
1606 if (in_eval & EVAL_KEEPERR) {
1607 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1611 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1612 && PL_curstackinfo->si_prev)
1626 JMPENV *restartjmpenv;
1629 if (cxix < cxstack_ix)
1632 POPBLOCK(cx,PL_curpm);
1633 if (CxTYPE(cx) != CXt_EVAL) {
1635 const char* message = SvPVx_const(exceptsv, msglen);
1636 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1637 PerlIO_write(Perl_error_log, message, msglen);
1641 namesv = cx->blk_eval.old_namesv;
1643 oldcop = cx->blk_oldcop;
1645 restartjmpenv = cx->blk_eval.cur_top_env;
1646 restartop = cx->blk_eval.retop;
1648 if (gimme == G_SCALAR)
1649 *++newsp = &PL_sv_undef;
1650 PL_stack_sp = newsp;
1654 if (optype == OP_REQUIRE) {
1655 assert (PL_curcop == oldcop);
1656 (void)hv_store(GvHVn(PL_incgv),
1657 SvPVX_const(namesv),
1658 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1660 /* note that unlike pp_entereval, pp_require isn't
1661 * supposed to trap errors. So now that we've popped the
1662 * EVAL that pp_require pushed, and processed the error
1663 * message, rethrow the error */
1664 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1665 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1668 if (!(in_eval & EVAL_KEEPERR))
1669 sv_setsv(ERRSV, exceptsv);
1670 PL_restartjmpenv = restartjmpenv;
1671 PL_restartop = restartop;
1673 NOT_REACHED; /* NOTREACHED */
1677 write_to_stderr(exceptsv);
1679 NOT_REACHED; /* NOTREACHED */
1685 if (SvTRUE(left) != SvTRUE(right))
1693 =head1 CV Manipulation Functions
1695 =for apidoc caller_cx
1697 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1698 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1699 information returned to Perl by C<caller>. Note that XSUBs don't get a
1700 stack frame, so C<caller_cx(0, NULL)> will return information for the
1701 immediately-surrounding Perl code.
1703 This function skips over the automatic calls to C<&DB::sub> made on the
1704 behalf of the debugger. If the stack frame requested was a sub called by
1705 C<DB::sub>, the return value will be the frame for the call to
1706 C<DB::sub>, since that has the correct line number/etc. for the call
1707 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1708 frame for the sub call itself.
1713 const PERL_CONTEXT *
1714 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1716 I32 cxix = dopoptosub(cxstack_ix);
1717 const PERL_CONTEXT *cx;
1718 const PERL_CONTEXT *ccstack = cxstack;
1719 const PERL_SI *top_si = PL_curstackinfo;
1722 /* we may be in a higher stacklevel, so dig down deeper */
1723 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1724 top_si = top_si->si_prev;
1725 ccstack = top_si->si_cxstack;
1726 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1730 /* caller() should not report the automatic calls to &DB::sub */
1731 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1732 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1736 cxix = dopoptosub_at(ccstack, cxix - 1);
1739 cx = &ccstack[cxix];
1740 if (dbcxp) *dbcxp = cx;
1742 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1743 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1744 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1745 field below is defined for any cx. */
1746 /* caller() should not report the automatic calls to &DB::sub */
1747 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1748 cx = &ccstack[dbcxix];
1757 const PERL_CONTEXT *cx;
1758 const PERL_CONTEXT *dbcx;
1759 I32 gimme = GIMME_V;
1760 const HEK *stash_hek;
1762 bool has_arg = MAXARG && TOPs;
1771 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1773 if (gimme != G_ARRAY) {
1781 assert(CopSTASH(cx->blk_oldcop));
1782 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1783 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1785 if (gimme != G_ARRAY) {
1788 PUSHs(&PL_sv_undef);
1791 sv_sethek(TARG, stash_hek);
1800 PUSHs(&PL_sv_undef);
1803 sv_sethek(TARG, stash_hek);
1806 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1807 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1808 cx->blk_sub.retop, TRUE);
1810 lcop = cx->blk_oldcop;
1811 mPUSHu(CopLINE(lcop));
1814 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1815 /* So is ccstack[dbcxix]. */
1816 if (CvHASGV(dbcx->blk_sub.cv)) {
1817 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1818 PUSHs(boolSV(CxHASARGS(cx)));
1821 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1822 PUSHs(boolSV(CxHASARGS(cx)));
1826 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1829 gimme = (I32)cx->blk_gimme;
1830 if (gimme == G_VOID)
1831 PUSHs(&PL_sv_undef);
1833 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1834 if (CxTYPE(cx) == CXt_EVAL) {
1836 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1837 SV *cur_text = cx->blk_eval.cur_text;
1838 if (SvCUR(cur_text) >= 2) {
1839 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1840 SvUTF8(cur_text)|SVs_TEMP));
1843 /* I think this is will always be "", but be sure */
1844 PUSHs(sv_2mortal(newSVsv(cur_text)));
1850 else if (cx->blk_eval.old_namesv) {
1851 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1854 /* eval BLOCK (try blocks have old_namesv == 0) */
1856 PUSHs(&PL_sv_undef);
1857 PUSHs(&PL_sv_undef);
1861 PUSHs(&PL_sv_undef);
1862 PUSHs(&PL_sv_undef);
1864 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1865 && CopSTASH_eq(PL_curcop, PL_debstash))
1867 AV * const ary = cx->blk_sub.argarray;
1868 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1870 Perl_init_dbargs(aTHX);
1872 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1873 av_extend(PL_dbargs, AvFILLp(ary) + off);
1874 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1875 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1877 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1880 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1882 if (old_warnings == pWARN_NONE)
1883 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1884 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1885 mask = &PL_sv_undef ;
1886 else if (old_warnings == pWARN_ALL ||
1887 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1888 /* Get the bit mask for $warnings::Bits{all}, because
1889 * it could have been extended by warnings::register */
1891 HV * const bits = get_hv("warnings::Bits", 0);
1892 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1893 mask = newSVsv(*bits_all);
1896 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1900 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1904 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1905 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1915 if (MAXARG < 1 || (!TOPs && !POPs))
1916 tmps = NULL, len = 0;
1918 tmps = SvPVx_const(POPs, len);
1919 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1924 /* like pp_nextstate, but used instead when the debugger is active */
1928 PL_curcop = (COP*)PL_op;
1929 TAINT_NOT; /* Each statement is presumed innocent */
1930 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1935 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1936 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
1940 const I32 gimme = G_ARRAY;
1942 GV * const gv = PL_DBgv;
1945 if (gv && isGV_with_GP(gv))
1948 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1949 DIE(aTHX_ "No DB::DB routine defined");
1951 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1952 /* don't do recursive DB::DB call */
1966 (void)(*CvXSUB(cv))(aTHX_ cv);
1972 PUSHBLOCK(cx, CXt_SUB, SP);
1974 cx->blk_sub.retop = PL_op->op_next;
1976 if (CvDEPTH(cv) >= 2) {
1977 PERL_STACK_OVERFLOW_CHECK();
1978 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1980 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1981 RETURNOP(CvSTART(cv));
1988 /* S_leave_common: Common code that many functions in this file use on
1991 /* SVs on the stack that have any of the flags passed in are left as is.
1992 Other SVs are protected via the mortals stack if lvalue is true, and
1995 Also, taintedness is cleared.
1999 S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
2000 U32 flags, bool lvalue)
2003 PERL_ARGS_ASSERT_LEAVE_COMMON;
2006 if (flags & SVs_PADTMP) {
2007 flags &= ~SVs_PADTMP;
2010 if (gimme == G_SCALAR) {
2012 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2015 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2016 : sv_mortalcopy(*SP);
2018 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2021 *++MARK = &PL_sv_undef;
2025 else if (gimme == G_ARRAY) {
2026 /* in case LEAVE wipes old return values */
2027 while (++MARK <= SP) {
2028 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2032 ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
2033 : sv_mortalcopy(*MARK);
2034 TAINT_NOT; /* Each item is independent */
2037 /* When this function was called with MARK == newsp, we reach this
2038 * point with SP == newsp. */
2048 I32 gimme = GIMME_V;
2050 ENTER_with_name("block");
2053 PUSHBLOCK(cx, CXt_BLOCK, SP);
2066 if (PL_op->op_flags & OPf_SPECIAL) {
2067 cx = &cxstack[cxstack_ix];
2068 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2073 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2075 SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
2076 PL_op->op_private & OPpLVALUE);
2077 PL_curpm = newpm; /* Don't pop $1 et al till now */
2079 LEAVE_with_name("block");
2085 S_outside_integer(pTHX_ SV *sv)
2088 const NV nv = SvNV_nomg(sv);
2089 if (Perl_isinfnan(nv))
2091 #ifdef NV_PRESERVES_UV
2092 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2095 if (nv <= (NV)IV_MIN)
2098 ((nv > (NV)UV_MAX ||
2099 SvUV_nomg(sv) > (UV)IV_MAX)))
2110 const I32 gimme = GIMME_V;
2111 void *itervar; /* location of the iteration variable */
2112 U8 cxtype = CXt_LOOP_FOR;
2114 ENTER_with_name("loop1");
2117 if (PL_op->op_targ) { /* "my" variable */
2118 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2119 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2120 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2121 SVs_PADSTALE, SVs_PADSTALE);
2123 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2124 itervar = &PAD_SVl(PL_op->op_targ);
2126 else if (LIKELY(isGV(TOPs))) { /* symbol table variable */
2127 GV * const gv = MUTABLE_GV(POPs);
2128 SV** svp = &GvSV(gv);
2129 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2131 itervar = (void *)gv;
2134 SV * const sv = POPs;
2135 assert(SvTYPE(sv) == SVt_PVMG);
2136 assert(SvMAGIC(sv));
2137 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2138 itervar = (void *)sv;
2139 cxtype |= CXp_FOR_LVREF;
2142 if (PL_op->op_private & OPpITER_DEF)
2143 cxtype |= CXp_FOR_DEF;
2145 ENTER_with_name("loop2");
2147 PUSHBLOCK(cx, cxtype, SP);
2148 PUSHLOOP_FOR(cx, itervar, MARK);
2149 if (PL_op->op_flags & OPf_STACKED) {
2150 SV *maybe_ary = POPs;
2151 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2153 SV * const right = maybe_ary;
2154 if (UNLIKELY(cxtype & CXp_FOR_LVREF))
2155 DIE(aTHX_ "Assigned value is not a reference");
2158 if (RANGE_IS_NUMERIC(sv,right)) {
2159 cx->cx_type &= ~CXTYPEMASK;
2160 cx->cx_type |= CXt_LOOP_LAZYIV;
2161 /* Make sure that no-one re-orders cop.h and breaks our
2163 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2164 if (S_outside_integer(aTHX_ sv) ||
2165 S_outside_integer(aTHX_ right))
2166 DIE(aTHX_ "Range iterator outside integer range");
2167 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2168 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2170 /* for correct -Dstv display */
2171 cx->blk_oldsp = sp - PL_stack_base;
2175 cx->cx_type &= ~CXTYPEMASK;
2176 cx->cx_type |= CXt_LOOP_LAZYSV;
2177 /* Make sure that no-one re-orders cop.h and breaks our
2179 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2180 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2181 cx->blk_loop.state_u.lazysv.end = right;
2182 SvREFCNT_inc(right);
2183 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2184 /* This will do the upgrade to SVt_PV, and warn if the value
2185 is uninitialised. */
2186 (void) SvPV_nolen_const(right);
2187 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2188 to replace !SvOK() with a pointer to "". */
2190 SvREFCNT_dec(right);
2191 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2195 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2196 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2197 SvREFCNT_inc(maybe_ary);
2198 cx->blk_loop.state_u.ary.ix =
2199 (PL_op->op_private & OPpITER_REVERSED) ?
2200 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2204 else { /* iterating over items on the stack */
2205 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2206 if (PL_op->op_private & OPpITER_REVERSED) {
2207 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2210 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2221 const I32 gimme = GIMME_V;
2223 ENTER_with_name("loop1");
2225 ENTER_with_name("loop2");
2227 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2228 PUSHLOOP_PLAIN(cx, SP);
2243 assert(CxTYPE_is_LOOP(cx));
2245 newsp = PL_stack_base + cx->blk_loop.resetsp;
2247 SP = leave_common(newsp, SP, MARK, gimme, 0,
2248 PL_op->op_private & OPpLVALUE);
2251 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2252 PL_curpm = newpm; /* ... and pop $1 et al */
2254 LEAVE_with_name("loop2");
2255 LEAVE_with_name("loop1");
2261 /* This duplicates most of pp_leavesub, but with additional code to handle
2262 * return args in lvalue context. It was forked from pp_leavesub to
2263 * avoid slowing down that function any further.
2265 * Any changes made to this function may need to be copied to pp_leavesub
2279 const char *what = NULL;
2281 if (CxMULTICALL(&cxstack[cxstack_ix])) {
2282 /* entry zero of a stack is always PL_sv_undef, which
2283 * simplifies converting a '()' return into undef in scalar context */
2284 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2289 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2294 ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2295 if (gimme == G_SCALAR) {
2296 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2300 if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
2301 !SvSMAGICAL(TOPs)) {
2303 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2304 : "a readonly value" : "a temporary";
2309 /* sub:lvalue{} will take us here. */
2319 "Can't return %s from lvalue subroutine", what
2324 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2325 if (!SvPADTMP(*SP)) {
2326 *MARK = SvREFCNT_inc(*SP);
2331 /* FREETMPS could clobber it */
2332 SV *sv = SvREFCNT_inc(*SP);
2334 *MARK = sv_mortalcopy(sv);
2341 ? sv_mortalcopy(*SP)
2343 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2348 *MARK = &PL_sv_undef;
2352 if (CxLVAL(cx) & OPpDEREF) {
2355 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2359 else if (gimme == G_ARRAY) {
2360 assert (!(CxLVAL(cx) & OPpDEREF));
2361 if (ref || !CxLVAL(cx))
2362 for (; MARK <= SP; MARK++)
2364 SvFLAGS(*MARK) & SVs_PADTMP
2365 ? sv_mortalcopy(*MARK)
2368 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2369 else for (; MARK <= SP; MARK++) {
2370 if (*MARK != &PL_sv_undef
2371 && (SvPADTMP(*MARK) || SvREADONLY(*MARK))
2373 /* Might be flattened array after $#array = */
2374 what = SvREADONLY(*MARK)
2375 ? "a readonly value" : "a temporary";
2378 else if (!SvTEMP(*MARK))
2379 *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2385 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2387 PL_curpm = newpm; /* ... and pop $1 et al */
2390 return cx->blk_sub.retop;
2399 const I32 cxix = dopoptosub(cxstack_ix);
2401 assert(cxstack_ix >= 0);
2402 if (cxix < cxstack_ix) {
2404 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2405 * sort block, which is a CXt_NULL
2408 /* if we were in list context, we would have to splice out
2409 * any junk before the return args, like we do in the general
2410 * pp_return case, e.g.
2411 * sub f { for (junk1, junk2) { return arg1, arg2 }}
2413 assert(cxstack[0].blk_gimme == G_SCALAR);
2417 DIE(aTHX_ "Can't return outside a subroutine");
2422 cx = &cxstack[cxix];
2424 oldsp = PL_stack_base + cx->blk_oldsp;
2425 if (oldsp != MARK) {
2426 /* Handle extra junk on the stack. For example,
2427 * for (1,2) { return 3,4 }
2428 * leaves 1,2,3,4 on the stack. In list context we
2429 * have to splice out the 1,2; In scalar context for
2430 * for (1,2) { return }
2431 * we need to set sp = oldsp so that pp_leavesub knows
2432 * to push &PL_sv_undef onto the stack.
2433 * Note that in pp_return we only do the extra processing
2434 * required to handle junk; everything else we leave to
2437 SSize_t nargs = SP - MARK;
2439 if (cx->blk_gimme == G_ARRAY) {
2440 /* shift return args to base of call stack frame */
2441 Move(MARK + 1, oldsp + 1, nargs, SV*);
2442 PL_stack_sp = oldsp + nargs;
2446 PL_stack_sp = oldsp;
2449 /* fall through to a normal exit */
2450 switch (CxTYPE(cx)) {
2452 return CxTRYBLOCK(cx)
2453 ? Perl_pp_leavetry(aTHX)
2454 : Perl_pp_leaveeval(aTHX);
2456 return CvLVALUE(cx->blk_sub.cv)
2457 ? Perl_pp_leavesublv(aTHX)
2458 : Perl_pp_leavesub(aTHX);
2460 return Perl_pp_leavewrite(aTHX);
2462 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2468 S_unwind_loop(pTHX_ const char * const opname)
2471 if (PL_op->op_flags & OPf_SPECIAL) {
2472 cxix = dopoptoloop(cxstack_ix);
2474 /* diag_listed_as: Can't "last" outside a loop block */
2475 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2480 const char * const label =
2481 PL_op->op_flags & OPf_STACKED
2482 ? SvPV(TOPs,label_len)
2483 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2484 const U32 label_flags =
2485 PL_op->op_flags & OPf_STACKED
2487 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2489 cxix = dopoptolabel(label, label_len, label_flags);
2491 /* diag_listed_as: Label not found for "last %s" */
2492 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2494 SVfARG(PL_op->op_flags & OPf_STACKED
2495 && !SvGMAGICAL(TOPp1s)
2497 : newSVpvn_flags(label,
2499 label_flags | SVs_TEMP)));
2501 if (cxix < cxstack_ix)
2514 S_unwind_loop(aTHX_ "last");
2517 cxstack_ix++; /* temporarily protect top context */
2519 CxTYPE(cx) == CXt_LOOP_LAZYIV
2520 || CxTYPE(cx) == CXt_LOOP_LAZYSV
2521 || CxTYPE(cx) == CXt_LOOP_FOR
2522 || CxTYPE(cx) == CXt_LOOP_PLAIN
2524 newsp = PL_stack_base + cx->blk_loop.resetsp;
2525 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2528 PL_stack_sp = newsp;
2532 /* Stack values are safe: */
2533 POPLOOP(cx); /* release loop vars ... */
2535 PL_curpm = newpm; /* ... and pop $1 et al */
2537 PERL_UNUSED_VAR(gimme);
2544 const I32 inner = PL_scopestack_ix;
2546 S_unwind_loop(aTHX_ "next");
2548 /* clear off anything above the scope we're re-entering, but
2549 * save the rest until after a possible continue block */
2551 if (PL_scopestack_ix < inner)
2552 leave_scope(PL_scopestack[PL_scopestack_ix]);
2553 PL_curcop = cx->blk_oldcop;
2555 return (cx)->blk_loop.my_op->op_nextop;
2560 const I32 cxix = S_unwind_loop(aTHX_ "redo");
2563 OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2565 if (redo_op->op_type == OP_ENTER) {
2566 /* pop one less context to avoid $x being freed in while (my $x..) */
2568 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2569 redo_op = redo_op->op_next;
2573 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2574 LEAVE_SCOPE(oldsave);
2576 PL_curcop = cx->blk_oldcop;
2582 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2585 static const char* const too_deep = "Target of goto is too deeply nested";
2587 PERL_ARGS_ASSERT_DOFINDLABEL;
2590 Perl_croak(aTHX_ "%s", too_deep);
2591 if (o->op_type == OP_LEAVE ||
2592 o->op_type == OP_SCOPE ||
2593 o->op_type == OP_LEAVELOOP ||
2594 o->op_type == OP_LEAVESUB ||
2595 o->op_type == OP_LEAVETRY)
2597 *ops++ = cUNOPo->op_first;
2599 Perl_croak(aTHX_ "%s", too_deep);
2602 if (o->op_flags & OPf_KIDS) {
2604 /* First try all the kids at this level, since that's likeliest. */
2605 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2606 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2607 STRLEN kid_label_len;
2608 U32 kid_label_flags;
2609 const char *kid_label = CopLABEL_len_flags(kCOP,
2610 &kid_label_len, &kid_label_flags);
2612 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2615 (const U8*)kid_label, kid_label_len,
2616 (const U8*)label, len) == 0)
2618 (const U8*)label, len,
2619 (const U8*)kid_label, kid_label_len) == 0)
2620 : ( len == kid_label_len && ((kid_label == label)
2621 || memEQ(kid_label, label, len)))))
2625 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2626 if (kid == PL_lastgotoprobe)
2628 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2631 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2632 ops[-1]->op_type == OP_DBSTATE)
2637 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2646 /* also used for: pp_dump() */
2654 #define GOTO_DEPTH 64
2655 OP *enterops[GOTO_DEPTH];
2656 const char *label = NULL;
2657 STRLEN label_len = 0;
2658 U32 label_flags = 0;
2659 const bool do_dump = (PL_op->op_type == OP_DUMP);
2660 static const char* const must_have_label = "goto must have label";
2662 if (PL_op->op_flags & OPf_STACKED) {
2663 /* goto EXPR or goto &foo */
2665 SV * const sv = POPs;
2668 /* This egregious kludge implements goto &subroutine */
2669 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2672 CV *cv = MUTABLE_CV(SvRV(sv));
2673 AV *arg = GvAV(PL_defgv);
2677 if (!CvROOT(cv) && !CvXSUB(cv)) {
2678 const GV * const gv = CvGV(cv);
2682 /* autoloaded stub? */
2683 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2685 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2687 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2688 if (autogv && (cv = GvCV(autogv)))
2690 tmpstr = sv_newmortal();
2691 gv_efullname3(tmpstr, gv, NULL);
2692 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2694 DIE(aTHX_ "Goto undefined subroutine");
2697 /* First do some returnish stuff. */
2698 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2700 cxix = dopoptosub(cxstack_ix);
2701 if (cxix < cxstack_ix) {
2704 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2710 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2711 if (CxTYPE(cx) == CXt_EVAL) {
2714 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2715 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2717 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2718 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2720 else if (CxMULTICALL(cx))
2723 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2726 /* partial unrolled POPSUB(): */
2728 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2729 AV* av = cx->blk_sub.argarray;
2731 /* abandon the original @_ if it got reified or if it is
2732 the same as the current @_ */
2733 if (AvREAL(av) || av == arg) {
2737 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2739 else CLEAR_ARGARRAY(av);
2742 /* We donate this refcount later to the callee’s pad. */
2743 SvREFCNT_inc_simple_void(arg);
2745 assert(PL_scopestack_ix == cx->blk_oldscopesp);
2746 oldsave = PL_scopestack[cx->blk_oldscopesp - 1];
2747 LEAVE_SCOPE(oldsave);
2748 PL_comppad = cx->blk_sub.prevcomppad;
2749 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2751 /* A destructor called during LEAVE_SCOPE could have undefined
2752 * our precious cv. See bug #99850. */
2753 if (!CvROOT(cv) && !CvXSUB(cv)) {
2754 const GV * const gv = CvGV(cv);
2757 SV * const tmpstr = sv_newmortal();
2758 gv_efullname3(tmpstr, gv, NULL);
2759 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2762 DIE(aTHX_ "Goto undefined subroutine");
2765 if (CxTYPE(cx) == CXt_SUB) {
2766 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2767 SvREFCNT_dec_NN(cx->blk_sub.cv);
2770 /* Now do some callish stuff. */
2772 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2776 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2777 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2780 PERL_UNUSED_VAR(newsp);
2781 PERL_UNUSED_VAR(gimme);
2783 /* put GvAV(defgv) back onto stack */
2785 EXTEND(SP, items+1); /* @_ could have been extended. */
2790 bool r = cBOOL(AvREAL(arg));
2791 for (index=0; index<items; index++)
2795 SV ** const svp = av_fetch(arg, index, 0);
2796 sv = svp ? *svp : NULL;
2798 else sv = AvARRAY(arg)[index];
2800 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2801 : sv_2mortal(newSVavdefelem(arg, index, 1));
2806 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2807 /* Restore old @_ */
2808 arg = GvAV(PL_defgv);
2809 GvAV(PL_defgv) = cx->blk_sub.savearray;
2813 retop = cx->blk_sub.retop;
2814 /* XS subs don't have a CxSUB, so pop it */
2815 POPBLOCK(cx, PL_curpm);
2816 /* Push a mark for the start of arglist */
2819 (void)(*CvXSUB(cv))(aTHX_ cv);
2824 PADLIST * const padlist = CvPADLIST(cv);
2826 /* partial unrolled PUSHSUB(): */
2828 cx->blk_sub.cv = cv;
2829 cx->blk_sub.olddepth = CvDEPTH(cv);
2832 SvREFCNT_inc_simple_void_NN(cv);
2833 if (CvDEPTH(cv) > 1) {
2834 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2835 sub_crush_depth(cv);
2836 pad_push(padlist, CvDEPTH(cv));
2838 PL_curcop = cx->blk_oldcop;
2839 cx->blk_sub.prevcomppad = PL_comppad;
2840 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2843 /* cx->blk_sub.argarray has no reference count, so we
2844 need something to hang on to our argument array so
2845 that cx->blk_sub.argarray does not end up pointing
2846 to freed memory as the result of undef *_. So put
2847 it in the callee’s pad, donating our refer-
2850 SvREFCNT_dec(PAD_SVl(0));
2851 PAD_SVl(0) = (SV *)arg;
2853 cx->blk_sub.argarray = (AV*)PAD_SVl(0);
2855 /* GvAV(PL_defgv) might have been modified on scope
2856 exit, so restore it. */
2857 if (arg != GvAV(PL_defgv)) {
2858 AV * const av = GvAV(PL_defgv);
2859 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2863 else SvREFCNT_dec(arg);
2864 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2865 Perl_get_db_sub(aTHX_ NULL, cv);
2867 CV * const gotocv = get_cvs("DB::goto", 0);
2869 PUSHMARK( PL_stack_sp );
2870 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2875 retop = CvSTART(cv);
2876 goto putback_return;
2881 label = SvPV_nomg_const(sv, label_len);
2882 label_flags = SvUTF8(sv);
2885 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2886 /* goto LABEL or dump LABEL */
2887 label = cPVOP->op_pv;
2888 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2889 label_len = strlen(label);
2891 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2896 OP *gotoprobe = NULL;
2897 bool leaving_eval = FALSE;
2898 bool in_block = FALSE;
2899 PERL_CONTEXT *last_eval_cx = NULL;
2903 PL_lastgotoprobe = NULL;
2905 for (ix = cxstack_ix; ix >= 0; ix--) {
2907 switch (CxTYPE(cx)) {
2909 leaving_eval = TRUE;
2910 if (!CxTRYBLOCK(cx)) {
2911 gotoprobe = (last_eval_cx ?
2912 last_eval_cx->blk_eval.old_eval_root :
2917 /* else fall through */
2918 case CXt_LOOP_LAZYIV:
2919 case CXt_LOOP_LAZYSV:
2921 case CXt_LOOP_PLAIN:
2924 gotoprobe = OpSIBLING(cx->blk_oldcop);
2930 gotoprobe = OpSIBLING(cx->blk_oldcop);
2933 gotoprobe = PL_main_root;
2936 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2937 gotoprobe = CvROOT(cx->blk_sub.cv);
2943 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2946 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
2947 CxTYPE(cx), (long) ix);
2948 gotoprobe = PL_main_root;
2954 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
2955 enterops, enterops + GOTO_DEPTH);
2958 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
2959 sibl1->op_type == OP_UNSTACK &&
2960 (sibl2 = OpSIBLING(sibl1)))
2962 retop = dofindlabel(sibl2,
2963 label, label_len, label_flags, enterops,
2964 enterops + GOTO_DEPTH);
2969 PL_lastgotoprobe = gotoprobe;
2972 DIE(aTHX_ "Can't find label %"UTF8f,
2973 UTF8fARG(label_flags, label_len, label));
2975 /* if we're leaving an eval, check before we pop any frames
2976 that we're not going to punt, otherwise the error
2979 if (leaving_eval && *enterops && enterops[1]) {
2981 for (i = 1; enterops[i]; i++)
2982 if (enterops[i]->op_type == OP_ENTERITER)
2983 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2986 if (*enterops && enterops[1]) {
2987 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2989 deprecate("\"goto\" to jump into a construct");
2992 /* pop unwanted frames */
2994 if (ix < cxstack_ix) {
2998 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3001 oldsave = PL_scopestack[PL_scopestack_ix];
3002 LEAVE_SCOPE(oldsave);
3005 /* push wanted frames */
3007 if (*enterops && enterops[1]) {
3008 OP * const oldop = PL_op;
3009 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3010 for (; enterops[ix]; ix++) {
3011 PL_op = enterops[ix];
3012 /* Eventually we may want to stack the needed arguments
3013 * for each op. For now, we punt on the hard ones. */
3014 if (PL_op->op_type == OP_ENTERITER)
3015 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3016 PL_op->op_ppaddr(aTHX);
3024 if (!retop) retop = PL_main_start;
3026 PL_restartop = retop;
3027 PL_do_undump = TRUE;
3031 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3032 PL_do_undump = FALSE;
3050 anum = 0; (void)POPs;
3056 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3059 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3062 PL_exit_flags |= PERL_EXIT_EXPECTED;
3064 PUSHs(&PL_sv_undef);
3071 S_save_lines(pTHX_ AV *array, SV *sv)
3073 const char *s = SvPVX_const(sv);
3074 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3077 PERL_ARGS_ASSERT_SAVE_LINES;
3079 while (s && s < send) {
3081 SV * const tmpstr = newSV_type(SVt_PVMG);
3083 t = (const char *)memchr(s, '\n', send - s);
3089 sv_setpvn(tmpstr, s, t - s);
3090 av_store(array, line++, tmpstr);
3098 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3100 0 is used as continue inside eval,
3102 3 is used for a die caught by an inner eval - continue inner loop
3104 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3105 establish a local jmpenv to handle exception traps.
3110 S_docatch(pTHX_ OP *o)
3113 OP * const oldop = PL_op;
3117 assert(CATCH_GET == TRUE);
3124 assert(cxstack_ix >= 0);
3125 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3126 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3131 /* die caught by an inner eval - continue inner loop */
3132 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3133 PL_restartjmpenv = NULL;
3134 PL_op = PL_restartop;
3143 NOT_REACHED; /* NOTREACHED */
3152 =for apidoc find_runcv
3154 Locate the CV corresponding to the currently executing sub or eval.
3155 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3156 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3157 entered. (This allows debuggers to eval in the scope of the breakpoint
3158 rather than in the scope of the debugger itself.)
3164 Perl_find_runcv(pTHX_ U32 *db_seqp)
3166 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3169 /* If this becomes part of the API, it might need a better name. */
3171 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3178 PL_curcop == &PL_compiling
3180 : PL_curcop->cop_seq;
3182 for (si = PL_curstackinfo; si; si = si->si_prev) {
3184 for (ix = si->si_cxix; ix >= 0; ix--) {
3185 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3187 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3188 cv = cx->blk_sub.cv;
3189 /* skip DB:: code */
3190 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3191 *db_seqp = cx->blk_oldcop->cop_seq;
3194 if (cx->cx_type & CXp_SUB_RE)
3197 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3198 cv = cx->blk_eval.cv;
3201 case FIND_RUNCV_padid_eq:
3203 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3206 case FIND_RUNCV_level_eq:
3207 if (level++ != arg) continue;
3215 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3219 /* Run yyparse() in a setjmp wrapper. Returns:
3220 * 0: yyparse() successful
3221 * 1: yyparse() failed
3225 S_try_yyparse(pTHX_ int gramtype)
3230 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3234 ret = yyparse(gramtype) ? 1 : 0;
3241 NOT_REACHED; /* NOTREACHED */
3248 /* Compile a require/do or an eval ''.
3250 * outside is the lexically enclosing CV (if any) that invoked us.
3251 * seq is the current COP scope value.
3252 * hh is the saved hints hash, if any.
3254 * Returns a bool indicating whether the compile was successful; if so,
3255 * PL_eval_start contains the first op of the compiled code; otherwise,
3258 * This function is called from two places: pp_require and pp_entereval.
3259 * These can be distinguished by whether PL_op is entereval.
3263 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3266 OP * const saveop = PL_op;
3267 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3268 COP * const oldcurcop = PL_curcop;
3269 bool in_require = (saveop->op_type == OP_REQUIRE);
3273 PL_in_eval = (in_require
3274 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3276 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3277 ? EVAL_RE_REPARSING : 0)));
3281 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3283 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3284 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3285 cxstack[cxstack_ix].blk_gimme = gimme;
3287 CvOUTSIDE_SEQ(evalcv) = seq;
3288 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3290 /* set up a scratch pad */
3292 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3293 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3296 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3298 /* make sure we compile in the right package */
3300 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3301 SAVEGENERICSV(PL_curstash);
3302 PL_curstash = (HV *)CopSTASH(PL_curcop);
3303 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3304 else SvREFCNT_inc_simple_void(PL_curstash);
3306 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3307 SAVESPTR(PL_beginav);
3308 PL_beginav = newAV();
3309 SAVEFREESV(PL_beginav);
3310 SAVESPTR(PL_unitcheckav);
3311 PL_unitcheckav = newAV();
3312 SAVEFREESV(PL_unitcheckav);
3315 ENTER_with_name("evalcomp");
3316 SAVESPTR(PL_compcv);
3319 /* try to compile it */
3321 PL_eval_root = NULL;
3322 PL_curcop = &PL_compiling;
3323 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3324 PL_in_eval |= EVAL_KEEPERR;
3331 hv_clear(GvHV(PL_hintgv));
3334 PL_hints = saveop->op_private & OPpEVAL_COPHH
3335 ? oldcurcop->cop_hints : saveop->op_targ;
3337 /* making 'use re eval' not be in scope when compiling the
3338 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3339 * infinite recursion when S_has_runtime_code() gives a false
3340 * positive: the second time round, HINT_RE_EVAL isn't set so we
3341 * don't bother calling S_has_runtime_code() */
3342 if (PL_in_eval & EVAL_RE_REPARSING)
3343 PL_hints &= ~HINT_RE_EVAL;
3346 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3347 SvREFCNT_dec(GvHV(PL_hintgv));
3348 GvHV(PL_hintgv) = hh;
3351 SAVECOMPILEWARNINGS();
3353 if (PL_dowarn & G_WARN_ALL_ON)
3354 PL_compiling.cop_warnings = pWARN_ALL ;
3355 else if (PL_dowarn & G_WARN_ALL_OFF)
3356 PL_compiling.cop_warnings = pWARN_NONE ;
3358 PL_compiling.cop_warnings = pWARN_STD ;
3361 PL_compiling.cop_warnings =
3362 DUP_WARNINGS(oldcurcop->cop_warnings);
3363 cophh_free(CopHINTHASH_get(&PL_compiling));
3364 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3365 /* The label, if present, is the first entry on the chain. So rather
3366 than writing a blank label in front of it (which involves an
3367 allocation), just use the next entry in the chain. */
3368 PL_compiling.cop_hints_hash
3369 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3370 /* Check the assumption that this removed the label. */
3371 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3374 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3377 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3379 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3380 * so honour CATCH_GET and trap it here if necessary */
3382 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3384 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3385 SV **newsp; /* Used by POPBLOCK. */
3387 I32 optype; /* Used by POPEVAL. */
3393 PERL_UNUSED_VAR(newsp);
3394 PERL_UNUSED_VAR(optype);
3396 /* note that if yystatus == 3, then the EVAL CX block has already
3397 * been popped, and various vars restored */
3399 if (yystatus != 3) {
3401 op_free(PL_eval_root);
3402 PL_eval_root = NULL;
3404 SP = PL_stack_base + POPMARK; /* pop original mark */
3405 POPBLOCK(cx,PL_curpm);
3407 namesv = cx->blk_eval.old_namesv;
3408 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3409 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3415 /* If cx is still NULL, it means that we didn't go in the
3416 * POPEVAL branch. */
3417 cx = &cxstack[cxstack_ix];
3418 assert(CxTYPE(cx) == CXt_EVAL);
3419 namesv = cx->blk_eval.old_namesv;
3421 (void)hv_store(GvHVn(PL_incgv),
3422 SvPVX_const(namesv),
3423 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3425 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3428 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3431 if (!*(SvPV_nolen_const(errsv))) {
3432 sv_setpvs(errsv, "Compilation error");
3435 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3440 LEAVE_with_name("evalcomp");
3442 CopLINE_set(&PL_compiling, 0);
3443 SAVEFREEOP(PL_eval_root);
3444 cv_forget_slab(evalcv);
3446 DEBUG_x(dump_eval());
3448 /* Register with debugger: */
3449 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3450 CV * const cv = get_cvs("DB::postponed", 0);
3454 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3456 call_sv(MUTABLE_SV(cv), G_DISCARD);
3460 if (PL_unitcheckav) {
3461 OP *es = PL_eval_start;
3462 call_list(PL_scopestack_ix, PL_unitcheckav);
3466 /* compiled okay, so do it */
3468 CvDEPTH(evalcv) = 1;
3469 SP = PL_stack_base + POPMARK; /* pop original mark */
3470 PL_op = saveop; /* The caller may need it. */
3471 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3478 S_check_type_and_open(pTHX_ SV *name)
3483 const char *p = SvPV_const(name, len);
3486 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3488 /* checking here captures a reasonable error message when
3489 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3490 * user gets a confusing message about looking for the .pmc file
3491 * rather than for the .pm file so do the check in S_doopen_pm when
3492 * PMC is on instead of here. S_doopen_pm calls this func.
3493 * This check prevents a \0 in @INC causing problems.
3495 #ifdef PERL_DISABLE_PMC
3496 if (!IS_SAFE_PATHNAME(p, len, "require"))
3500 /* on Win32 stat is expensive (it does an open() and close() twice and
3501 a couple other IO calls), the open will fail with a dir on its own with
3502 errno EACCES, so only do a stat to separate a dir from a real EACCES
3503 caused by user perms */
3505 /* we use the value of errno later to see how stat() or open() failed.
3506 * We don't want it set if the stat succeeded but we still failed,
3507 * such as if the name exists, but is a directory */
3510 st_rc = PerlLIO_stat(p, &st);
3512 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3517 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3519 /* EACCES stops the INC search early in pp_require to implement
3520 feature RT #113422 */
3521 if(!retio && errno == EACCES) { /* exists but probably a directory */
3523 st_rc = PerlLIO_stat(p, &st);
3525 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3536 #ifndef PERL_DISABLE_PMC
3538 S_doopen_pm(pTHX_ SV *name)
3541 const char *p = SvPV_const(name, namelen);
3543 PERL_ARGS_ASSERT_DOOPEN_PM;
3545 /* check the name before trying for the .pmc name to avoid the
3546 * warning referring to the .pmc which the user probably doesn't
3547 * know or care about
3549 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3552 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3553 SV *const pmcsv = sv_newmortal();
3556 SvSetSV_nosteal(pmcsv,name);
3557 sv_catpvs(pmcsv, "c");
3559 pmcio = check_type_and_open(pmcsv);
3563 return check_type_and_open(name);
3566 # define doopen_pm(name) check_type_and_open(name)
3567 #endif /* !PERL_DISABLE_PMC */
3569 /* require doesn't search for absolute names, or when the name is
3570 explicitly relative the current directory */
3571 PERL_STATIC_INLINE bool
3572 S_path_is_searchable(const char *name)
3574 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3576 if (PERL_FILE_IS_ABSOLUTE(name)
3578 || (*name == '.' && ((name[1] == '/' ||
3579 (name[1] == '.' && name[2] == '/'))
3580 || (name[1] == '\\' ||
3581 ( name[1] == '.' && name[2] == '\\')))
3584 || (*name == '.' && (name[1] == '/' ||
3585 (name[1] == '.' && name[2] == '/')))
3596 /* also used for: pp_dofile() */
3608 int vms_unixname = 0;
3611 const char *tryname = NULL;
3613 const I32 gimme = GIMME_V;
3614 int filter_has_file = 0;
3615 PerlIO *tryrsfp = NULL;
3616 SV *filter_cache = NULL;
3617 SV *filter_state = NULL;
3618 SV *filter_sub = NULL;
3622 bool path_searchable;
3626 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3627 sv = sv_2mortal(new_version(sv));
3628 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3629 upg_version(PL_patchlevel, TRUE);
3630 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3631 if ( vcmp(sv,PL_patchlevel) <= 0 )
3632 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3633 SVfARG(sv_2mortal(vnormal(sv))),
3634 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3638 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3641 SV * const req = SvRV(sv);
3642 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3644 /* get the left hand term */
3645 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3647 first = SvIV(*av_fetch(lav,0,0));
3648 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3649 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3650 || av_tindex(lav) > 1 /* FP with > 3 digits */
3651 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3653 DIE(aTHX_ "Perl %"SVf" required--this is only "
3655 SVfARG(sv_2mortal(vnormal(req))),
3656 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3659 else { /* probably 'use 5.10' or 'use 5.8' */
3663 if (av_tindex(lav)>=1)
3664 second = SvIV(*av_fetch(lav,1,0));
3666 second /= second >= 600 ? 100 : 10;
3667 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3668 (int)first, (int)second);
3669 upg_version(hintsv, TRUE);
3671 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3672 "--this is only %"SVf", stopped",
3673 SVfARG(sv_2mortal(vnormal(req))),
3674 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3675 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3684 DIE(aTHX_ "Missing or undefined argument to require");
3685 name = SvPV_nomg_const(sv, len);
3686 if (!(name && len > 0 && *name))
3687 DIE(aTHX_ "Missing or undefined argument to require");
3689 if (!IS_SAFE_PATHNAME(name, len, "require")) {
3690 DIE(aTHX_ "Can't locate %s: %s",
3691 pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3692 SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3695 TAINT_PROPER("require");
3697 path_searchable = path_is_searchable(name);
3700 /* The key in the %ENV hash is in the syntax of file passed as the argument
3701 * usually this is in UNIX format, but sometimes in VMS format, which
3702 * can result in a module being pulled in more than once.
3703 * To prevent this, the key must be stored in UNIX format if the VMS
3704 * name can be translated to UNIX.
3708 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3710 unixlen = strlen(unixname);
3716 /* if not VMS or VMS name can not be translated to UNIX, pass it
3719 unixname = (char *) name;
3722 if (PL_op->op_type == OP_REQUIRE) {
3723 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3724 unixname, unixlen, 0);
3726 if (*svp != &PL_sv_undef)
3729 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3730 "Compilation failed in require", unixname);
3734 LOADING_FILE_PROBE(unixname);
3736 /* prepare to compile file */
3738 if (!path_searchable) {
3739 /* At this point, name is SvPVX(sv) */
3741 tryrsfp = doopen_pm(sv);
3743 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3744 AV * const ar = GvAVn(PL_incgv);
3751 namesv = newSV_type(SVt_PV);
3752 for (i = 0; i <= AvFILL(ar); i++) {
3753 SV * const dirsv = *av_fetch(ar, i, TRUE);
3761 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3762 && !SvOBJECT(SvRV(loader)))
3764 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3768 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3769 PTR2UV(SvRV(dirsv)), name);
3770 tryname = SvPVX_const(namesv);
3773 if (SvPADTMP(nsv)) {
3774 nsv = sv_newmortal();
3775 SvSetSV_nosteal(nsv,sv);
3778 ENTER_with_name("call_INC");
3786 if (SvGMAGICAL(loader)) {
3787 SV *l = sv_newmortal();
3788 sv_setsv_nomg(l, loader);
3791 if (sv_isobject(loader))
3792 count = call_method("INC", G_ARRAY);
3794 count = call_sv(loader, G_ARRAY);
3804 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3805 && !isGV_with_GP(SvRV(arg))) {
3806 filter_cache = SvRV(arg);
3813 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3817 if (isGV_with_GP(arg)) {
3818 IO * const io = GvIO((const GV *)arg);
3823 tryrsfp = IoIFP(io);
3824 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3825 PerlIO_close(IoOFP(io));
3836 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3838 SvREFCNT_inc_simple_void_NN(filter_sub);
3841 filter_state = SP[i];
3842 SvREFCNT_inc_simple_void(filter_state);
3846 if (!tryrsfp && (filter_cache || filter_sub)) {
3847 tryrsfp = PerlIO_open(BIT_BUCKET,
3853 /* FREETMPS may free our filter_cache */
3854 SvREFCNT_inc_simple_void(filter_cache);
3858 LEAVE_with_name("call_INC");
3860 /* Now re-mortalize it. */
3861 sv_2mortal(filter_cache);
3863 /* Adjust file name if the hook has set an %INC entry.
3864 This needs to happen after the FREETMPS above. */
3865 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3867 tryname = SvPV_nolen_const(*svp);
3874 filter_has_file = 0;
3875 filter_cache = NULL;
3877 SvREFCNT_dec_NN(filter_state);
3878 filter_state = NULL;
3881 SvREFCNT_dec_NN(filter_sub);
3886 if (path_searchable) {
3891 dir = SvPV_nomg_const(dirsv, dirlen);
3897 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
3901 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3904 sv_setpv(namesv, unixdir);
3905 sv_catpv(namesv, unixname);
3907 # ifdef __SYMBIAN32__
3908 if (PL_origfilename[0] &&
3909 PL_origfilename[1] == ':' &&
3910 !(dir[0] && dir[1] == ':'))
3911 Perl_sv_setpvf(aTHX_ namesv,
3916 Perl_sv_setpvf(aTHX_ namesv,
3920 /* The equivalent of
3921 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3922 but without the need to parse the format string, or
3923 call strlen on either pointer, and with the correct
3924 allocation up front. */
3926 char *tmp = SvGROW(namesv, dirlen + len + 2);
3928 memcpy(tmp, dir, dirlen);
3931 /* Avoid '<dir>//<file>' */
3932 if (!dirlen || *(tmp-1) != '/') {
3935 /* So SvCUR_set reports the correct length below */
3939 /* name came from an SV, so it will have a '\0' at the
3940 end that we can copy as part of this memcpy(). */
3941 memcpy(tmp, name, len + 1);
3943 SvCUR_set(namesv, dirlen + len + 1);
3948 TAINT_PROPER("require");
3949 tryname = SvPVX_const(namesv);
3950 tryrsfp = doopen_pm(namesv);
3952 if (tryname[0] == '.' && tryname[1] == '/') {
3954 while (*++tryname == '/') {}
3958 else if (errno == EMFILE || errno == EACCES) {
3959 /* no point in trying other paths if out of handles;
3960 * on the other hand, if we couldn't open one of the
3961 * files, then going on with the search could lead to
3962 * unexpected results; see perl #113422
3971 saved_errno = errno; /* sv_2mortal can realloc things */
3974 if (PL_op->op_type == OP_REQUIRE) {
3975 if(saved_errno == EMFILE || saved_errno == EACCES) {
3976 /* diag_listed_as: Can't locate %s */
3977 DIE(aTHX_ "Can't locate %s: %s: %s",
3978 name, tryname, Strerror(saved_errno));
3980 if (namesv) { /* did we lookup @INC? */
3981 AV * const ar = GvAVn(PL_incgv);
3983 SV *const msg = newSVpvs_flags("", SVs_TEMP);
3984 SV *const inc = newSVpvs_flags("", SVs_TEMP);
3985 for (i = 0; i <= AvFILL(ar); i++) {
3986 sv_catpvs(inc, " ");
3987 sv_catsv(inc, *av_fetch(ar, i, TRUE));
3989 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
3990 const char *c, *e = name + len - 3;
3991 sv_catpv(msg, " (you may need to install the ");
3992 for (c = name; c < e; c++) {
3994 sv_catpvs(msg, "::");
3997 sv_catpvn(msg, c, 1);
4000 sv_catpv(msg, " module)");
4002 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4003 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4005 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4006 sv_catpv(msg, " (did you run h2ph?)");
4009 /* diag_listed_as: Can't locate %s */
4011 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4015 DIE(aTHX_ "Can't locate %s", name);
4022 SETERRNO(0, SS_NORMAL);
4024 /* Assume success here to prevent recursive requirement. */
4025 /* name is never assigned to again, so len is still strlen(name) */
4026 /* Check whether a hook in @INC has already filled %INC */
4028 (void)hv_store(GvHVn(PL_incgv),
4029 unixname, unixlen, newSVpv(tryname,0),0);
4031 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4033 (void)hv_store(GvHVn(PL_incgv),
4034 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4037 ENTER_with_name("eval");
4039 SAVECOPFILE_FREE(&PL_compiling);
4040 CopFILE_set(&PL_compiling, tryname);
4041 lex_start(NULL, tryrsfp, 0);
4043 if (filter_sub || filter_cache) {
4044 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4045 than hanging another SV from it. In turn, filter_add() optionally
4046 takes the SV to use as the filter (or creates a new SV if passed
4047 NULL), so simply pass in whatever value filter_cache has. */
4048 SV * const fc = filter_cache ? newSV(0) : NULL;
4050 if (fc) sv_copypv(fc, filter_cache);
4051 datasv = filter_add(S_run_user_filter, fc);
4052 IoLINES(datasv) = filter_has_file;
4053 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4054 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4057 /* switch to eval mode */
4058 PUSHBLOCK(cx, CXt_EVAL, SP);
4060 cx->blk_eval.retop = PL_op->op_next;
4062 SAVECOPLINE(&PL_compiling);
4063 CopLINE_set(&PL_compiling, 0);
4067 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4068 op = DOCATCH(PL_eval_start);
4070 op = PL_op->op_next;
4072 LOADED_FILE_PROBE(unixname);
4077 /* This is a op added to hold the hints hash for
4078 pp_entereval. The hash can be modified by the code
4079 being eval'ed, so we return a copy instead. */
4084 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4094 const I32 gimme = GIMME_V;
4095 const U32 was = PL_breakable_sub_gen;
4096 char tbuf[TYPE_DIGITS(long) + 12];
4097 bool saved_delete = FALSE;
4098 char *tmpbuf = tbuf;
4101 U32 seq, lex_flags = 0;
4102 HV *saved_hh = NULL;
4103 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4105 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4106 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4108 else if (PL_hints & HINT_LOCALIZE_HH || (
4109 PL_op->op_private & OPpEVAL_COPHH
4110 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4112 saved_hh = cop_hints_2hv(PL_curcop, 0);
4113 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4117 /* make sure we've got a plain PV (no overload etc) before testing
4118 * for taint. Making a copy here is probably overkill, but better
4119 * safe than sorry */
4121 const char * const p = SvPV_const(sv, len);
4123 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4124 lex_flags |= LEX_START_COPIED;
4126 if (bytes && SvUTF8(sv))
4127 SvPVbyte_force(sv, len);
4129 else if (bytes && SvUTF8(sv)) {
4130 /* Don't modify someone else's scalar */
4133 (void)sv_2mortal(sv);
4134 SvPVbyte_force(sv,len);
4135 lex_flags |= LEX_START_COPIED;
4138 TAINT_IF(SvTAINTED(sv));
4139 TAINT_PROPER("eval");
4141 ENTER_with_name("eval");
4142 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4143 ? LEX_IGNORE_UTF8_HINTS
4144 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4149 /* switch to eval mode */
4151 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4152 SV * const temp_sv = sv_newmortal();
4153 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4154 (unsigned long)++PL_evalseq,
4155 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4156 tmpbuf = SvPVX(temp_sv);
4157 len = SvCUR(temp_sv);
4160 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4161 SAVECOPFILE_FREE(&PL_compiling);
4162 CopFILE_set(&PL_compiling, tmpbuf+2);
4163 SAVECOPLINE(&PL_compiling);
4164 CopLINE_set(&PL_compiling, 1);
4165 /* special case: an eval '' executed within the DB package gets lexically
4166 * placed in the first non-DB CV rather than the current CV - this
4167 * allows the debugger to execute code, find lexicals etc, in the
4168 * scope of the code being debugged. Passing &seq gets find_runcv
4169 * to do the dirty work for us */
4170 runcv = find_runcv(&seq);
4172 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4174 cx->blk_eval.retop = PL_op->op_next;
4176 /* prepare to compile string */
4178 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4179 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4181 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4182 deleting the eval's FILEGV from the stash before gv_check() runs
4183 (i.e. before run-time proper). To work around the coredump that
4184 ensues, we always turn GvMULTI_on for any globals that were
4185 introduced within evals. See force_ident(). GSAR 96-10-12 */
4186 char *const safestr = savepvn(tmpbuf, len);
4187 SAVEDELETE(PL_defstash, safestr, len);
4188 saved_delete = TRUE;
4193 if (doeval(gimme, runcv, seq, saved_hh)) {
4194 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4195 ? PERLDB_LINE_OR_SAVESRC
4196 : PERLDB_SAVESRC_NOSUBS) {
4197 /* Retain the filegv we created. */
4198 } else if (!saved_delete) {
4199 char *const safestr = savepvn(tmpbuf, len);
4200 SAVEDELETE(PL_defstash, safestr, len);
4202 return DOCATCH(PL_eval_start);
4204 /* We have already left the scope set up earlier thanks to the LEAVE
4206 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4207 ? PERLDB_LINE_OR_SAVESRC
4208 : PERLDB_SAVESRC_INVALID) {
4209 /* Retain the filegv we created. */
4210 } else if (!saved_delete) {
4211 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4213 return PL_op->op_next;
4228 /* grab this value before POPEVAL restores old PL_in_eval */
4229 bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4234 namesv = cx->blk_eval.old_namesv;
4235 retop = cx->blk_eval.retop;
4236 evalcv = cx->blk_eval.cv;
4238 SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
4239 gimme, SVs_TEMP, FALSE);
4240 PL_curpm = newpm; /* Don't pop $1 et al till now */
4243 assert(CvDEPTH(evalcv) == 1);
4245 CvDEPTH(evalcv) = 0;
4247 if (optype == OP_REQUIRE &&
4248 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4250 /* Unassume the success we assumed earlier. */
4251 (void)hv_delete(GvHVn(PL_incgv),
4252 SvPVX_const(namesv),
4253 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4255 Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4256 NOT_REACHED; /* NOTREACHED */
4257 /* die_unwind() did LEAVE, or we won't be here */
4260 LEAVE_with_name("eval");
4268 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4269 close to the related Perl_create_eval_scope. */
4271 Perl_delete_eval_scope(pTHX)
4282 LEAVE_with_name("eval_scope");
4283 PERL_UNUSED_VAR(newsp);
4284 PERL_UNUSED_VAR(gimme);
4285 PERL_UNUSED_VAR(optype);
4288 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4289 also needed by Perl_fold_constants. */
4291 Perl_create_eval_scope(pTHX_ U32 flags)
4294 const I32 gimme = GIMME_V;
4296 ENTER_with_name("eval_scope");
4299 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4302 PL_in_eval = EVAL_INEVAL;
4303 if (flags & G_KEEPERR)
4304 PL_in_eval |= EVAL_KEEPERR;
4307 if (flags & G_FAKINGEVAL) {
4308 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4315 PERL_CONTEXT * const cx = create_eval_scope(0);
4316 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4317 return DOCATCH(PL_op->op_next);
4332 retop = cx->blk_eval.retop;
4334 PERL_UNUSED_VAR(optype);
4336 SP = leave_common(newsp, SP, newsp, gimme,
4337 SVs_PADTMP|SVs_TEMP, FALSE);
4338 PL_curpm = newpm; /* Don't pop $1 et al till now */
4340 LEAVE_with_name("eval_scope");
4349 const I32 gimme = GIMME_V;
4351 ENTER_with_name("given");
4354 assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4358 PUSHBLOCK(cx, CXt_GIVEN, SP);
4371 PERL_UNUSED_CONTEXT;
4374 assert(CxTYPE(cx) == CXt_GIVEN);
4376 SP = leave_common(newsp, SP, newsp, gimme,
4377 SVs_PADTMP|SVs_TEMP, FALSE);
4378 PL_curpm = newpm; /* Don't pop $1 et al till now */
4380 LEAVE_with_name("given");
4384 /* Helper routines used by pp_smartmatch */
4386 S_make_matcher(pTHX_ REGEXP *re)
4388 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4390 PERL_ARGS_ASSERT_MAKE_MATCHER;
4392 PM_SETRE(matcher, ReREFCNT_inc(re));
4394 SAVEFREEOP((OP *) matcher);
4395 ENTER_with_name("matcher"); SAVETMPS;
4401 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4406 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4408 PL_op = (OP *) matcher;
4411 (void) Perl_pp_match(aTHX);
4413 result = SvTRUEx(POPs);
4420 S_destroy_matcher(pTHX_ PMOP *matcher)
4422 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4423 PERL_UNUSED_ARG(matcher);
4426 LEAVE_with_name("matcher");
4429 /* Do a smart match */
4432 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4433 return do_smartmatch(NULL, NULL, 0);
4436 /* This version of do_smartmatch() implements the
4437 * table of smart matches that is found in perlsyn.
4440 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4444 bool object_on_left = FALSE;
4445 SV *e = TOPs; /* e is for 'expression' */
4446 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4448 /* Take care only to invoke mg_get() once for each argument.
4449 * Currently we do this by copying the SV if it's magical. */
4451 if (!copied && SvGMAGICAL(d))
4452 d = sv_mortalcopy(d);
4459 e = sv_mortalcopy(e);
4461 /* First of all, handle overload magic of the rightmost argument */
4464 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4465 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4467 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4474 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4477 SP -= 2; /* Pop the values */
4482 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4489 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4490 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4491 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4493 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4494 object_on_left = TRUE;
4497 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {