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
38 #define RUN_PP_CATCHABLY(thispp) \
39 STMT_START { if (CATCH_GET) return docatch(thispp); } STMT_END
41 #define dopopto_cursub() \
42 (PL_curstackinfo->si_cxsubix >= 0 \
43 ? PL_curstackinfo->si_cxsubix \
44 : dopoptosub_at(cxstack, cxstack_ix))
46 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
52 const PERL_CONTEXT *cx;
55 if (PL_op->op_private & OPpOFFBYONE) {
56 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
59 cxix = dopopto_cursub();
65 switch (cx->blk_gimme) {
84 PMOP *pm = (PMOP*)cLOGOP->op_other;
89 const regexp_engine *eng;
90 bool is_bare_re= FALSE;
92 if (PL_op->op_flags & OPf_STACKED) {
102 /* prevent recompiling under /o and ithreads. */
103 #if defined(USE_ITHREADS)
104 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
111 assert (re != (REGEXP*) &PL_sv_undef);
112 eng = re ? RX_ENGINE(re) : current_re_engine();
114 new_re = (eng->op_comp
116 : &Perl_re_op_compile
117 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
119 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
121 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
123 if (pm->op_pmflags & PMf_HAS_CV)
124 ReANY(new_re)->qr_anoncv
125 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
129 /* The match's LHS's get-magic might need to access this op's regexp
130 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
131 get-magic now before we replace the regexp. Hopefully this hack can
132 be replaced with the approach described at
133 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
135 if (pm->op_type == OP_MATCH) {
137 const bool was_tainted = TAINT_get;
138 if (pm->op_flags & OPf_STACKED)
140 else if (pm->op_targ)
141 lhs = PAD_SV(pm->op_targ);
144 /* Restore the previous value of PL_tainted (which may have been
145 modified by get-magic), to avoid incorrectly setting the
146 RXf_TAINTED flag with RX_TAINT_on further down. */
147 TAINT_set(was_tainted);
148 #ifdef NO_TAINT_SUPPORT
149 PERL_UNUSED_VAR(was_tainted);
152 tmp = reg_temp_copy(NULL, new_re);
153 ReREFCNT_dec(new_re);
159 PM_SETRE(pm, new_re);
163 assert(TAINTING_get || !TAINT_get);
165 SvTAINTED_on((SV*)new_re);
169 /* handle the empty pattern */
170 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) {
171 if (PL_curpm == PL_reg_curpm) {
172 if (PL_curpm_under && PL_curpm_under == PL_reg_curpm) {
173 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
178 #if !defined(USE_ITHREADS)
179 /* can't change the optree at runtime either */
180 /* PMf_KEEP is handled differently under threads to avoid these problems */
181 if (pm->op_pmflags & PMf_KEEP) {
182 cLOGOP->op_first->op_next = PL_op->op_next;
194 PERL_CONTEXT *cx = CX_CUR();
195 PMOP * const pm = (PMOP*) cLOGOP->op_other;
196 SV * const dstr = cx->sb_dstr;
199 char *orig = cx->sb_orig;
200 REGEXP * const rx = cx->sb_rx;
202 REGEXP *old = PM_GETRE(pm);
209 PM_SETRE(pm,ReREFCNT_inc(rx));
212 rxres_restore(&cx->sb_rxres, rx);
214 if (cx->sb_iters++) {
215 const SSize_t saviters = cx->sb_iters;
216 if (cx->sb_iters > cx->sb_maxiters)
217 DIE(aTHX_ "Substitution loop");
219 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
221 /* See "how taint works" above pp_subst() */
222 sv_catsv_nomg(dstr, POPs);
223 if (UNLIKELY(TAINT_get))
224 cx->sb_rxtainted |= SUBST_TAINT_REPL;
225 if (CxONCE(cx) || s < orig ||
226 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
227 (s == m), cx->sb_targ, NULL,
228 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
230 SV *targ = cx->sb_targ;
232 assert(cx->sb_strend >= s);
233 if(cx->sb_strend > s) {
234 if (DO_UTF8(dstr) && !SvUTF8(targ))
235 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
237 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
239 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
240 cx->sb_rxtainted |= SUBST_TAINT_PAT;
242 if (pm->op_pmflags & PMf_NONDESTRUCT) {
244 /* From here on down we're using the copy, and leaving the
245 original untouched. */
249 SV_CHECK_THINKFIRST_COW_DROP(targ);
250 if (isGV(targ)) Perl_croak_no_modify();
252 SvPV_set(targ, SvPVX(dstr));
253 SvCUR_set(targ, SvCUR(dstr));
254 SvLEN_set(targ, SvLEN(dstr));
257 SvPV_set(dstr, NULL);
260 mPUSHi(saviters - 1);
262 (void)SvPOK_only_UTF8(targ);
265 /* update the taint state of various variables in
266 * preparation for final exit.
267 * See "how taint works" above pp_subst() */
269 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
270 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
271 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
273 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
275 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
276 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
278 SvTAINTED_on(TOPs); /* taint return value */
279 /* needed for mg_set below */
281 cBOOL(cx->sb_rxtainted &
282 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
285 /* sv_magic(), when adding magic (e.g.taint magic), also
286 * recalculates any pos() magic, converting any byte offset
287 * to utf8 offset. Make sure pos() is reset before this
288 * happens rather than using the now invalid value (since
289 * we've just replaced targ's pvx buffer with the
290 * potentially shorter dstr buffer). Normally (i.e. in
291 * non-taint cases), pos() gets removed a few lines later
292 * with the SvSETMAGIC().
296 mg = mg_find_mglob(targ);
298 MgBYTEPOS_set(mg, targ, SvPVX(targ), -1);
304 /* PL_tainted must be correctly set for this mg_set */
313 RETURNOP(pm->op_next);
314 NOT_REACHED; /* NOTREACHED */
316 cx->sb_iters = saviters;
318 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
321 assert(!RX_SUBOFFSET(rx));
322 cx->sb_orig = orig = RX_SUBBEG(rx);
324 cx->sb_strend = s + (cx->sb_strend - m);
326 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
328 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
329 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
331 sv_catpvn_nomg(dstr, s, m-s);
333 cx->sb_s = RX_OFFS(rx)[0].end + orig;
334 { /* Update the pos() information. */
336 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
339 /* the string being matched against may no longer be a string,
340 * e.g. $_=0; s/.../$_++/ge */
343 SvPV_force_nomg_nolen(sv);
345 if (!(mg = mg_find_mglob(sv))) {
346 mg = sv_magicext_mglob(sv);
348 MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
351 (void)ReREFCNT_inc(rx);
352 /* update the taint state of various variables in preparation
353 * for calling the code block.
354 * See "how taint works" above pp_subst() */
356 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
357 cx->sb_rxtainted |= SUBST_TAINT_PAT;
359 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
360 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
361 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
363 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
365 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
366 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
367 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
368 ? cx->sb_dstr : cx->sb_targ);
371 rxres_save(&cx->sb_rxres, rx);
373 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
377 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
382 PERL_ARGS_ASSERT_RXRES_SAVE;
385 if (!p || p[1] < RX_NPARENS(rx)) {
387 i = 7 + (RX_NPARENS(rx)+1) * 2;
389 i = 6 + (RX_NPARENS(rx)+1) * 2;
398 /* what (if anything) to free on croak */
399 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
400 RX_MATCH_COPIED_off(rx);
401 *p++ = RX_NPARENS(rx);
404 *p++ = PTR2UV(RX_SAVED_COPY(rx));
405 RX_SAVED_COPY(rx) = NULL;
408 *p++ = PTR2UV(RX_SUBBEG(rx));
409 *p++ = (UV)RX_SUBLEN(rx);
410 *p++ = (UV)RX_SUBOFFSET(rx);
411 *p++ = (UV)RX_SUBCOFFSET(rx);
412 for (i = 0; i <= RX_NPARENS(rx); ++i) {
413 *p++ = (UV)RX_OFFS(rx)[i].start;
414 *p++ = (UV)RX_OFFS(rx)[i].end;
419 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
424 PERL_ARGS_ASSERT_RXRES_RESTORE;
427 RX_MATCH_COPY_FREE(rx);
428 RX_MATCH_COPIED_set(rx, *p);
430 RX_NPARENS(rx) = *p++;
433 if (RX_SAVED_COPY(rx))
434 SvREFCNT_dec (RX_SAVED_COPY(rx));
435 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
439 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
440 RX_SUBLEN(rx) = (I32)(*p++);
441 RX_SUBOFFSET(rx) = (I32)*p++;
442 RX_SUBCOFFSET(rx) = (I32)*p++;
443 for (i = 0; i <= RX_NPARENS(rx); ++i) {
444 RX_OFFS(rx)[i].start = (I32)(*p++);
445 RX_OFFS(rx)[i].end = (I32)(*p++);
450 S_rxres_free(pTHX_ void **rsp)
452 UV * const p = (UV*)*rsp;
454 PERL_ARGS_ASSERT_RXRES_FREE;
458 void *tmp = INT2PTR(char*,*p);
461 U32 i = 9 + p[1] * 2;
463 U32 i = 8 + p[1] * 2;
468 SvREFCNT_dec (INT2PTR(SV*,p[2]));
471 PoisonFree(p, i, sizeof(UV));
480 #define FORM_NUM_BLANK (1<<30)
481 #define FORM_NUM_POINT (1<<29)
485 dSP; dMARK; dORIGMARK;
486 SV * const tmpForm = *++MARK;
487 SV *formsv; /* contains text of original format */
488 U32 *fpc; /* format ops program counter */
489 char *t; /* current append position in target string */
490 const char *f; /* current position in format string */
492 SV *sv = NULL; /* current item */
493 const char *item = NULL;/* string value of current item */
494 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
495 I32 itembytes = 0; /* as itemsize, but length in bytes */
496 I32 fieldsize = 0; /* width of current field */
497 I32 lines = 0; /* number of lines that have been output */
498 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
499 const char *chophere = NULL; /* where to chop current item */
500 STRLEN linemark = 0; /* pos of start of line in output */
502 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
503 STRLEN len; /* length of current sv */
504 STRLEN linemax; /* estimate of output size in bytes */
505 bool item_is_utf8 = FALSE;
506 bool targ_is_utf8 = FALSE;
509 U8 *source; /* source of bytes to append */
510 STRLEN to_copy; /* how may bytes to append */
511 char trans; /* what chars to translate */
512 bool copied_form = FALSE; /* have we duplicated the form? */
514 mg = doparseform(tmpForm);
516 fpc = (U32*)mg->mg_ptr;
517 /* the actual string the format was compiled from.
518 * with overload etc, this may not match tmpForm */
522 SvPV_force(PL_formtarget, len);
523 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
524 SvTAINTED_on(PL_formtarget);
525 if (DO_UTF8(PL_formtarget))
527 /* this is an initial estimate of how much output buffer space
528 * to allocate. It may be exceeded later */
529 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
530 t = SvGROW(PL_formtarget, len + linemax + 1);
531 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
533 f = SvPV_const(formsv, len);
537 const char *name = "???";
540 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
541 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
542 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
543 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
544 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
546 case FF_CHECKNL: name = "CHECKNL"; break;
547 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
548 case FF_SPACE: name = "SPACE"; break;
549 case FF_HALFSPACE: name = "HALFSPACE"; break;
550 case FF_ITEM: name = "ITEM"; break;
551 case FF_CHOP: name = "CHOP"; break;
552 case FF_LINEGLOB: name = "LINEGLOB"; break;
553 case FF_NEWLINE: name = "NEWLINE"; break;
554 case FF_MORE: name = "MORE"; break;
555 case FF_LINEMARK: name = "LINEMARK"; break;
556 case FF_END: name = "END"; break;
557 case FF_0DECIMAL: name = "0DECIMAL"; break;
558 case FF_LINESNGL: name = "LINESNGL"; break;
561 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
563 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
566 case FF_LINEMARK: /* start (or end) of a line */
567 linemark = t - SvPVX(PL_formtarget);
572 case FF_LITERAL: /* append <arg> literal chars */
577 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
580 case FF_SKIP: /* skip <arg> chars in format */
584 case FF_FETCH: /* get next item and set field size to <arg> */
593 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
596 SvTAINTED_on(PL_formtarget);
599 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
601 const char *s = item = SvPV_const(sv, len);
602 const char *send = s + len;
605 item_is_utf8 = DO_UTF8(sv);
617 if (itemsize == fieldsize)
620 itembytes = s - item;
625 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
627 const char *s = item = SvPV_const(sv, len);
628 const char *send = s + len;
632 item_is_utf8 = DO_UTF8(sv);
634 /* look for a legal split position */
642 /* provisional split point */
646 /* we delay testing fieldsize until after we've
647 * processed the possible split char directly
648 * following the last field char; so if fieldsize=3
649 * and item="a b cdef", we consume "a b", not "a".
650 * Ditto further down.
652 if (size == fieldsize)
656 if (strchr(PL_chopset, *s)) {
657 /* provisional split point */
658 /* for a non-space split char, we include
659 * the split char; hence the '+1' */
663 if (size == fieldsize)
675 if (!chophere || s == send) {
679 itembytes = chophere - item;
684 case FF_SPACE: /* append padding space (diff of field, item size) */
685 arg = fieldsize - itemsize;
693 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
694 arg = fieldsize - itemsize;
703 case FF_ITEM: /* append a text item, while blanking ctrl chars */
709 case FF_CHOP: /* (for ^*) chop the current item */
710 if (sv != &PL_sv_no) {
711 const char *s = chophere;
713 ((sv == tmpForm || SvSMAGICAL(sv))
714 || (SvGMAGICAL(tmpForm) && !sv_only_taint_gmagic(tmpForm))) ) {
715 /* sv and tmpForm are either the same SV, or magic might allow modification
716 of tmpForm when sv is modified, so copy */
717 SV *newformsv = sv_mortalcopy(formsv);
720 f = SvPV_nolen(newformsv) + (f - SvPV_nolen(formsv));
721 Newx(new_compiled, mg->mg_len / sizeof(U32), U32);
722 memcpy(new_compiled, mg->mg_ptr, mg->mg_len);
723 SAVEFREEPV(new_compiled);
724 fpc = new_compiled + (fpc - (U32*)mg->mg_ptr);
736 /* tied, overloaded or similar strangeness.
737 * Do it the hard way */
738 sv_setpvn(sv, s, len - (s-item));
744 case FF_LINESNGL: /* process ^* */
748 case FF_LINEGLOB: /* process @* */
750 const bool oneline = fpc[-1] == FF_LINESNGL;
751 const char *s = item = SvPV_const(sv, len);
752 const char *const send = s + len;
754 item_is_utf8 = DO_UTF8(sv);
765 to_copy = s - item - 1;
779 /* append to_copy bytes from source to PL_formstring.
780 * item_is_utf8 implies source is utf8.
781 * if trans, translate certain characters during the copy */
786 SvCUR_set(PL_formtarget,
787 t - SvPVX_const(PL_formtarget));
789 if (targ_is_utf8 && !item_is_utf8) {
790 source = tmp = bytes_to_utf8(source, &to_copy);
793 if (item_is_utf8 && !targ_is_utf8) {
795 /* Upgrade targ to UTF8, and then we reduce it to
796 a problem we have a simple solution for.
797 Don't need get magic. */
798 sv_utf8_upgrade_nomg(PL_formtarget);
800 /* re-calculate linemark */
801 s = (U8*)SvPVX(PL_formtarget);
802 /* the bytes we initially allocated to append the
803 * whole line may have been gobbled up during the
804 * upgrade, so allocate a whole new line's worth
808 s += UTF8_SAFE_SKIP(s,
809 (U8 *) SvEND(PL_formtarget));
810 linemark = s - (U8*)SvPVX(PL_formtarget);
812 /* Easy. They agree. */
813 assert (item_is_utf8 == targ_is_utf8);
816 /* @* and ^* are the only things that can exceed
817 * the linemax, so grow by the output size, plus
818 * a whole new form's worth in case of any further
820 grow = linemax + to_copy;
822 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
823 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
825 Copy(source, t, to_copy, char);
827 /* blank out ~ or control chars, depending on trans.
828 * works on bytes not chars, so relies on not
829 * matching utf8 continuation bytes */
831 U8 *send = s + to_copy;
834 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
841 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
847 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
850 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
853 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
856 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
858 /* If the field is marked with ^ and the value is undefined,
860 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
868 /* overflow evidence */
869 if (num_overflow(value, fieldsize, arg)) {
875 /* Formats aren't yet marked for locales, so assume "yes". */
877 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
879 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
880 STORE_LC_NUMERIC_SET_TO_NEEDED();
881 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
885 if (!quadmath_format_valid(fmt))
886 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
887 len = quadmath_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
889 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", fmt);
892 /* we generate fmt ourselves so it is safe */
893 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
894 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
895 GCC_DIAG_RESTORE_STMT;
897 PERL_MY_SNPRINTF_POST_GUARD(len, max);
898 RESTORE_LC_NUMERIC();
903 case FF_NEWLINE: /* delete trailing spaces, then append \n */
905 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
910 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
913 if (arg) { /* repeat until fields exhausted? */
919 t = SvPVX(PL_formtarget) + linemark;
924 case FF_MORE: /* replace long end of string with '...' */
926 const char *s = chophere;
927 const char *send = item + len;
929 while (isSPACE(*s) && (s < send))
934 arg = fieldsize - itemsize;
941 if (strBEGINs(s1," ")) {
942 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
952 case FF_END: /* tidy up, then return */
954 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
956 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
958 SvUTF8_on(PL_formtarget);
959 FmLINES(PL_formtarget) += lines;
961 if (fpc[-1] == FF_BLANK)
962 RETURNOP(cLISTOP->op_first);
969 /* also used for: pp_mapstart() */
975 if (PL_stack_base + TOPMARK == SP) {
977 if (GIMME_V == G_SCALAR)
979 RETURNOP(PL_op->op_next->op_next);
981 PL_stack_sp = PL_stack_base + TOPMARK + 1;
982 Perl_pp_pushmark(aTHX); /* push dst */
983 Perl_pp_pushmark(aTHX); /* push src */
984 ENTER_with_name("grep"); /* enter outer scope */
988 ENTER_with_name("grep_item"); /* enter inner scope */
991 src = PL_stack_base[TOPMARK];
993 src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
1000 if (PL_op->op_type == OP_MAPSTART)
1001 Perl_pp_pushmark(aTHX); /* push top */
1002 return ((LOGOP*)PL_op->op_next)->op_other;
1008 const U8 gimme = GIMME_V;
1009 I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
1015 /* first, move source pointer to the next item in the source list */
1016 ++PL_markstack_ptr[-1];
1018 /* if there are new items, push them into the destination list */
1019 if (items && gimme != G_VOID) {
1020 /* might need to make room back there first */
1021 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1022 /* XXX this implementation is very pessimal because the stack
1023 * is repeatedly extended for every set of items. Is possible
1024 * to do this without any stack extension or copying at all
1025 * by maintaining a separate list over which the map iterates
1026 * (like foreach does). --gsar */
1028 /* everything in the stack after the destination list moves
1029 * towards the end the stack by the amount of room needed */
1030 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1032 /* items to shift up (accounting for the moved source pointer) */
1033 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1035 /* This optimization is by Ben Tilly and it does
1036 * things differently from what Sarathy (gsar)
1037 * is describing. The downside of this optimization is
1038 * that leaves "holes" (uninitialized and hopefully unused areas)
1039 * to the Perl stack, but on the other hand this
1040 * shouldn't be a problem. If Sarathy's idea gets
1041 * implemented, this optimization should become
1042 * irrelevant. --jhi */
1044 shift = count; /* Avoid shifting too often --Ben Tilly */
1048 dst = (SP += shift);
1049 PL_markstack_ptr[-1] += shift;
1050 *PL_markstack_ptr += shift;
1054 /* copy the new items down to the destination list */
1055 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1056 if (gimme == G_ARRAY) {
1057 /* add returned items to the collection (making mortal copies
1058 * if necessary), then clear the current temps stack frame
1059 * *except* for those items. We do this splicing the items
1060 * into the start of the tmps frame (so some items may be on
1061 * the tmps stack twice), then moving PL_tmps_floor above
1062 * them, then freeing the frame. That way, the only tmps that
1063 * accumulate over iterations are the return values for map.
1064 * We have to do to this way so that everything gets correctly
1065 * freed if we die during the map.
1069 /* make space for the slice */
1070 EXTEND_MORTAL(items);
1071 tmpsbase = PL_tmps_floor + 1;
1072 Move(PL_tmps_stack + tmpsbase,
1073 PL_tmps_stack + tmpsbase + items,
1074 PL_tmps_ix - PL_tmps_floor,
1076 PL_tmps_ix += items;
1081 sv = sv_mortalcopy(sv);
1083 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1085 /* clear the stack frame except for the items */
1086 PL_tmps_floor += items;
1088 /* FREETMPS may have cleared the TEMP flag on some of the items */
1091 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1094 /* scalar context: we don't care about which values map returns
1095 * (we use undef here). And so we certainly don't want to do mortal
1096 * copies of meaningless values. */
1097 while (items-- > 0) {
1099 *dst-- = &PL_sv_undef;
1107 LEAVE_with_name("grep_item"); /* exit inner scope */
1110 if (PL_markstack_ptr[-1] > TOPMARK) {
1112 (void)POPMARK; /* pop top */
1113 LEAVE_with_name("grep"); /* exit outer scope */
1114 (void)POPMARK; /* pop src */
1115 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1116 (void)POPMARK; /* pop dst */
1117 SP = PL_stack_base + POPMARK; /* pop original mark */
1118 if (gimme == G_SCALAR) {
1122 else if (gimme == G_ARRAY)
1129 ENTER_with_name("grep_item"); /* enter inner scope */
1132 /* set $_ to the new source item */
1133 src = PL_stack_base[PL_markstack_ptr[-1]];
1134 if (SvPADTMP(src)) {
1135 src = sv_mortalcopy(src);
1140 RETURNOP(cLOGOP->op_other);
1149 if (GIMME_V == G_ARRAY)
1152 if (SvTRUE_NN(targ))
1153 return cLOGOP->op_other;
1162 if (GIMME_V == G_ARRAY) {
1163 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1167 SV * const targ = PAD_SV(PL_op->op_targ);
1170 if (PL_op->op_private & OPpFLIP_LINENUM) {
1171 if (GvIO(PL_last_in_gv)) {
1172 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1175 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1177 flip = SvIV(sv) == SvIV(GvSV(gv));
1180 flip = SvTRUE_NN(sv);
1183 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1184 if (PL_op->op_flags & OPf_SPECIAL) {
1192 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1201 /* This code tries to decide if "$left .. $right" should use the
1202 magical string increment, or if the range is numeric. Initially,
1203 an exception was made for *any* string beginning with "0" (see
1204 [#18165], AMS 20021031), but now that is only applied when the
1205 string's length is also >1 - see the rules now documented in
1208 #define RANGE_IS_NUMERIC(left,right) ( \
1209 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1210 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1211 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1212 looks_like_number(left)) && SvPOKp(left) \
1213 && !(*SvPVX_const(left) == '0' && SvCUR(left)>1 ) )) \
1214 && (!SvOK(right) || looks_like_number(right))))
1220 if (GIMME_V == G_ARRAY) {
1226 if (RANGE_IS_NUMERIC(left,right)) {
1228 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1229 (SvOK(right) && (SvIOK(right)
1230 ? SvIsUV(right) && SvUV(right) > IV_MAX
1231 : SvNV_nomg(right) > (NV) IV_MAX)))
1232 DIE(aTHX_ "Range iterator outside integer range");
1233 i = SvIV_nomg(left);
1234 j = SvIV_nomg(right);
1236 /* Dance carefully around signed max. */
1237 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1240 /* The wraparound of signed integers is undefined
1241 * behavior, but here we aim for count >=1, and
1242 * negative count is just wrong. */
1244 #if IVSIZE > Size_t_size
1251 Perl_croak(aTHX_ "Out of memory during list extend");
1258 SV * const sv = sv_2mortal(newSViv(i));
1260 if (n) /* avoid incrementing above IV_MAX */
1266 const char * const lpv = SvPV_nomg_const(left, llen);
1267 const char * const tmps = SvPV_nomg_const(right, len);
1269 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1270 if (DO_UTF8(right) && IN_UNI_8_BIT)
1271 len = sv_len_utf8_nomg(right);
1272 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1274 if (strEQ(SvPVX_const(sv),tmps))
1276 sv = sv_2mortal(newSVsv(sv));
1283 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1287 if (PL_op->op_private & OPpFLIP_LINENUM) {
1288 if (GvIO(PL_last_in_gv)) {
1289 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1292 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1293 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1297 flop = SvTRUE_NN(sv);
1301 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1302 sv_catpvs(targ, "E0");
1312 static const char * const context_name[] = {
1314 NULL, /* CXt_WHEN never actually needs "block" */
1315 NULL, /* CXt_BLOCK never actually needs "block" */
1316 NULL, /* CXt_GIVEN never actually needs "block" */
1317 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1318 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1319 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1320 NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1321 NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1329 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1333 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1335 for (i = cxstack_ix; i >= 0; i--) {
1336 const PERL_CONTEXT * const cx = &cxstack[i];
1337 switch (CxTYPE(cx)) {
1343 /* diag_listed_as: Exiting subroutine via %s */
1344 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1345 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1346 if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1349 case CXt_LOOP_PLAIN:
1350 case CXt_LOOP_LAZYIV:
1351 case CXt_LOOP_LAZYSV:
1355 STRLEN cx_label_len = 0;
1356 U32 cx_label_flags = 0;
1357 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1359 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1362 (const U8*)cx_label, cx_label_len,
1363 (const U8*)label, len) == 0)
1365 (const U8*)label, len,
1366 (const U8*)cx_label, cx_label_len) == 0)
1367 : (len == cx_label_len && ((cx_label == label)
1368 || memEQ(cx_label, label, len))) )) {
1369 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1370 (long)i, cx_label));
1373 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1384 Perl_dowantarray(pTHX)
1386 const U8 gimme = block_gimme();
1387 return (gimme == G_VOID) ? G_SCALAR : gimme;
1390 /* note that this function has mostly been superseded by Perl_gimme_V */
1393 Perl_block_gimme(pTHX)
1395 const I32 cxix = dopopto_cursub();
1400 gimme = (cxstack[cxix].blk_gimme & G_WANT);
1402 Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1408 Perl_is_lvalue_sub(pTHX)
1410 const I32 cxix = dopopto_cursub();
1411 assert(cxix >= 0); /* We should only be called from inside subs */
1413 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1414 return CxLVAL(cxstack + cxix);
1419 /* only used by cx_pushsub() */
1421 Perl_was_lvalue_sub(pTHX)
1423 const I32 cxix = dopoptosub(cxstack_ix-1);
1424 assert(cxix >= 0); /* We should only be called from inside subs */
1426 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1427 return CxLVAL(cxstack + cxix);
1433 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1437 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1439 PERL_UNUSED_CONTEXT;
1442 for (i = startingblock; i >= 0; i--) {
1443 const PERL_CONTEXT * const cx = &cxstk[i];
1444 switch (CxTYPE(cx)) {
1448 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1449 * twice; the first for the normal foo() call, and the second
1450 * for a faked up re-entry into the sub to execute the
1451 * code block. Hide this faked entry from the world. */
1452 if (cx->cx_type & CXp_SUB_RE_FAKE)
1457 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1465 S_dopoptoeval(pTHX_ I32 startingblock)
1468 for (i = startingblock; i >= 0; i--) {
1469 const PERL_CONTEXT *cx = &cxstack[i];
1470 switch (CxTYPE(cx)) {
1474 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1482 S_dopoptoloop(pTHX_ I32 startingblock)
1485 for (i = startingblock; i >= 0; i--) {
1486 const PERL_CONTEXT * const cx = &cxstack[i];
1487 switch (CxTYPE(cx)) {
1493 /* diag_listed_as: Exiting subroutine via %s */
1494 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1495 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1496 if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1499 case CXt_LOOP_PLAIN:
1500 case CXt_LOOP_LAZYIV:
1501 case CXt_LOOP_LAZYSV:
1504 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1511 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1514 S_dopoptogivenfor(pTHX_ I32 startingblock)
1517 for (i = startingblock; i >= 0; i--) {
1518 const PERL_CONTEXT *cx = &cxstack[i];
1519 switch (CxTYPE(cx)) {
1523 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1525 case CXt_LOOP_PLAIN:
1526 assert(!(cx->cx_type & CXp_FOR_DEF));
1528 case CXt_LOOP_LAZYIV:
1529 case CXt_LOOP_LAZYSV:
1532 if (cx->cx_type & CXp_FOR_DEF) {
1533 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1542 S_dopoptowhen(pTHX_ I32 startingblock)
1545 for (i = startingblock; i >= 0; i--) {
1546 const PERL_CONTEXT *cx = &cxstack[i];
1547 switch (CxTYPE(cx)) {
1551 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1558 /* dounwind(): pop all contexts above (but not including) cxix.
1559 * Note that it clears the savestack frame associated with each popped
1560 * context entry, but doesn't free any temps.
1561 * It does a cx_popblock() of the last frame that it pops, and leaves
1562 * cxstack_ix equal to cxix.
1566 Perl_dounwind(pTHX_ I32 cxix)
1568 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1571 while (cxstack_ix > cxix) {
1572 PERL_CONTEXT *cx = CX_CUR();
1574 CX_DEBUG(cx, "UNWIND");
1575 /* Note: we don't need to restore the base context info till the end. */
1579 switch (CxTYPE(cx)) {
1582 /* CXt_SUBST is not a block context type, so skip the
1583 * cx_popblock(cx) below */
1584 if (cxstack_ix == cxix + 1) {
1595 case CXt_LOOP_PLAIN:
1596 case CXt_LOOP_LAZYIV:
1597 case CXt_LOOP_LAZYSV:
1610 /* these two don't have a POPFOO() */
1616 if (cxstack_ix == cxix + 1) {
1625 Perl_qerror(pTHX_ SV *err)
1627 PERL_ARGS_ASSERT_QERROR;
1630 if (PL_in_eval & EVAL_KEEPERR) {
1631 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1635 sv_catsv(ERRSV, err);
1638 sv_catsv(PL_errors, err);
1640 Perl_warn(aTHX_ "%" SVf, SVfARG(err));
1642 ++PL_parser->error_count;
1647 /* pop a CXt_EVAL context and in addition, if it was a require then
1649 * 0: do nothing extra;
1650 * 1: undef $INC{$name}; croak "$name did not return a true value";
1651 * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1655 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1657 SV *namesv = NULL; /* init to avoid dumb compiler warning */
1661 do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1663 /* keep namesv alive after cx_popeval() */
1664 namesv = cx->blk_eval.old_namesv;
1665 cx->blk_eval.old_namesv = NULL;
1674 HV *inc_hv = GvHVn(PL_incgv);
1675 I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv);
1676 const char *key = SvPVX_const(namesv);
1679 (void)hv_delete(inc_hv, key, klen, G_DISCARD);
1680 fmt = "%" SVf " did not return a true value";
1684 (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0);
1685 fmt = "%" SVf "Compilation failed in require";
1687 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1690 Perl_croak(aTHX_ fmt, SVfARG(errsv));
1695 /* die_unwind(): this is the final destination for the various croak()
1696 * functions. If we're in an eval, unwind the context and other stacks
1697 * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1698 * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1699 * to is a require the exception will be rethrown, as requires don't
1700 * actually trap exceptions.
1704 Perl_die_unwind(pTHX_ SV *msv)
1707 U8 in_eval = PL_in_eval;
1708 PERL_ARGS_ASSERT_DIE_UNWIND;
1713 /* We need to keep this SV alive through all the stack unwinding
1714 * and FREETMPSing below, while ensuing that it doesn't leak
1715 * if we call out to something which then dies (e.g. sub STORE{die}
1716 * when unlocalising a tied var). So we do a dance with
1717 * mortalising and SAVEFREEing.
1719 if (PL_phase == PERL_PHASE_DESTRUCT) {
1720 exceptsv = sv_mortalcopy(exceptsv);
1722 exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1726 * Historically, perl used to set ERRSV ($@) early in the die
1727 * process and rely on it not getting clobbered during unwinding.
1728 * That sucked, because it was liable to get clobbered, so the
1729 * setting of ERRSV used to emit the exception from eval{} has
1730 * been moved to much later, after unwinding (see just before
1731 * JMPENV_JUMP below). However, some modules were relying on the
1732 * early setting, by examining $@ during unwinding to use it as
1733 * a flag indicating whether the current unwinding was caused by
1734 * an exception. It was never a reliable flag for that purpose,
1735 * being totally open to false positives even without actual
1736 * clobberage, but was useful enough for production code to
1737 * semantically rely on it.
1739 * We'd like to have a proper introspective interface that
1740 * explicitly describes the reason for whatever unwinding
1741 * operations are currently in progress, so that those modules
1742 * work reliably and $@ isn't further overloaded. But we don't
1743 * have one yet. In its absence, as a stopgap measure, ERRSV is
1744 * now *additionally* set here, before unwinding, to serve as the
1745 * (unreliable) flag that it used to.
1747 * This behaviour is temporary, and should be removed when a
1748 * proper way to detect exceptional unwinding has been developed.
1749 * As of 2010-12, the authors of modules relying on the hack
1750 * are aware of the issue, because the modules failed on
1751 * perls 5.13.{1..7} which had late setting of $@ without this
1752 * early-setting hack.
1754 if (!(in_eval & EVAL_KEEPERR)) {
1755 /* remove any read-only/magic from the SV, so we don't
1756 get infinite recursion when setting ERRSV */
1758 sv_setsv_flags(ERRSV, exceptsv,
1759 (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
1762 if (in_eval & EVAL_KEEPERR) {
1763 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1767 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1768 && PL_curstackinfo->si_prev)
1778 JMPENV *restartjmpenv;
1781 if (cxix < cxstack_ix)
1785 assert(CxTYPE(cx) == CXt_EVAL);
1787 /* return false to the caller of eval */
1788 oldsp = PL_stack_base + cx->blk_oldsp;
1789 gimme = cx->blk_gimme;
1790 if (gimme == G_SCALAR)
1791 *++oldsp = &PL_sv_undef;
1792 PL_stack_sp = oldsp;
1794 restartjmpenv = cx->blk_eval.cur_top_env;
1795 restartop = cx->blk_eval.retop;
1797 /* We need a FREETMPS here to avoid late-called destructors
1798 * clobbering $@ *after* we set it below, e.g.
1799 * sub DESTROY { eval { die "X" } }
1800 * eval { my $x = bless []; die $x = 0, "Y" };
1802 * Here the clearing of the $x ref mortalises the anon array,
1803 * which needs to be freed *before* $& is set to "Y",
1804 * otherwise it gets overwritten with "X".
1806 * However, the FREETMPS will clobber exceptsv, so preserve it
1807 * on the savestack for now.
1809 SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv));
1811 /* now we're about to pop the savestack, so re-mortalise it */
1812 sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1814 /* Note that unlike pp_entereval, pp_require isn't supposed to
1815 * trap errors. So if we're a require, after we pop the
1816 * CXt_EVAL that pp_require pushed, rethrow the error with
1817 * croak(exceptsv). This is all handled by the call below when
1820 S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
1822 if (!(in_eval & EVAL_KEEPERR)) {
1824 sv_setsv(ERRSV, exceptsv);
1826 PL_restartjmpenv = restartjmpenv;
1827 PL_restartop = restartop;
1829 NOT_REACHED; /* NOTREACHED */
1833 write_to_stderr(exceptsv);
1835 NOT_REACHED; /* NOTREACHED */
1841 if (SvTRUE_NN(left) != SvTRUE_NN(right))
1849 =for apidoc_section $CV
1851 =for apidoc caller_cx
1853 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1854 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1855 information returned to Perl by C<caller>. Note that XSUBs don't get a
1856 stack frame, so C<caller_cx(0, NULL)> will return information for the
1857 immediately-surrounding Perl code.
1859 This function skips over the automatic calls to C<&DB::sub> made on the
1860 behalf of the debugger. If the stack frame requested was a sub called by
1861 C<DB::sub>, the return value will be the frame for the call to
1862 C<DB::sub>, since that has the correct line number/etc. for the call
1863 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1864 frame for the sub call itself.
1869 const PERL_CONTEXT *
1870 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1872 I32 cxix = dopopto_cursub();
1873 const PERL_CONTEXT *cx;
1874 const PERL_CONTEXT *ccstack = cxstack;
1875 const PERL_SI *top_si = PL_curstackinfo;
1878 /* we may be in a higher stacklevel, so dig down deeper */
1879 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1880 top_si = top_si->si_prev;
1881 ccstack = top_si->si_cxstack;
1882 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1886 /* caller() should not report the automatic calls to &DB::sub */
1887 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1888 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1892 cxix = dopoptosub_at(ccstack, cxix - 1);
1895 cx = &ccstack[cxix];
1896 if (dbcxp) *dbcxp = cx;
1898 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1899 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1900 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1901 field below is defined for any cx. */
1902 /* caller() should not report the automatic calls to &DB::sub */
1903 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1904 cx = &ccstack[dbcxix];
1913 const PERL_CONTEXT *cx;
1914 const PERL_CONTEXT *dbcx;
1916 const HEK *stash_hek;
1918 bool has_arg = MAXARG && TOPs;
1927 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1929 if (gimme != G_ARRAY) {
1936 CX_DEBUG(cx, "CALLER");
1937 assert(CopSTASH(cx->blk_oldcop));
1938 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1939 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1941 if (gimme != G_ARRAY) {
1944 PUSHs(&PL_sv_undef);
1947 sv_sethek(TARG, stash_hek);
1956 PUSHs(&PL_sv_undef);
1959 sv_sethek(TARG, stash_hek);
1962 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1963 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1964 cx->blk_sub.retop, TRUE);
1966 lcop = cx->blk_oldcop;
1967 mPUSHu(CopLINE(lcop));
1970 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1971 /* So is ccstack[dbcxix]. */
1972 if (CvHASGV(dbcx->blk_sub.cv)) {
1973 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1974 PUSHs(boolSV(CxHASARGS(cx)));
1977 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1978 PUSHs(boolSV(CxHASARGS(cx)));
1982 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1985 gimme = cx->blk_gimme;
1986 if (gimme == G_VOID)
1987 PUSHs(&PL_sv_undef);
1989 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1990 if (CxTYPE(cx) == CXt_EVAL) {
1992 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1993 SV *cur_text = cx->blk_eval.cur_text;
1994 if (SvCUR(cur_text) >= 2) {
1995 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
1996 SvUTF8(cur_text)|SVs_TEMP));
1999 /* I think this is will always be "", but be sure */
2000 PUSHs(sv_2mortal(newSVsv(cur_text)));
2006 else if (cx->blk_eval.old_namesv) {
2007 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
2010 /* eval BLOCK (try blocks have old_namesv == 0) */
2012 PUSHs(&PL_sv_undef);
2013 PUSHs(&PL_sv_undef);
2017 PUSHs(&PL_sv_undef);
2018 PUSHs(&PL_sv_undef);
2020 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
2021 && CopSTASH_eq(PL_curcop, PL_debstash))
2023 /* slot 0 of the pad contains the original @_ */
2024 AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
2025 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2026 cx->blk_sub.olddepth+1]))[0]);
2027 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
2029 Perl_init_dbargs(aTHX);
2031 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
2032 av_extend(PL_dbargs, AvFILLp(ary) + off);
2033 if (AvFILLp(ary) + 1 + off)
2034 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
2035 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
2037 mPUSHi(CopHINTS_get(cx->blk_oldcop));
2040 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
2042 if (old_warnings == pWARN_NONE)
2043 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
2044 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
2045 mask = &PL_sv_undef ;
2046 else if (old_warnings == pWARN_ALL ||
2047 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
2048 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
2051 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
2055 PUSHs(cx->blk_oldcop->cop_hints_hash ?
2056 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2066 if (MAXARG < 1 || (!TOPs && !POPs)) {
2068 tmps = NULL, len = 0;
2071 tmps = SvPVx_const(POPs, len);
2072 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
2077 /* like pp_nextstate, but used instead when the debugger is active */
2081 PL_curcop = (COP*)PL_op;
2082 TAINT_NOT; /* Each statement is presumed innocent */
2083 PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
2088 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2089 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2093 const U8 gimme = G_ARRAY;
2094 GV * const gv = PL_DBgv;
2097 if (gv && isGV_with_GP(gv))
2100 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2101 DIE(aTHX_ "No DB::DB routine defined");
2103 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2104 /* don't do recursive DB::DB call */
2114 (void)(*CvXSUB(cv))(aTHX_ cv);
2120 cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
2121 cx_pushsub(cx, cv, PL_op->op_next, 0);
2122 /* OP_DBSTATE's op_private holds hint bits rather than
2123 * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2124 * any CxLVAL() flags that have now been mis-calculated */
2131 if (CvDEPTH(cv) >= 2)
2132 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2133 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2134 RETURNOP(CvSTART(cv));
2146 (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2158 assert(CxTYPE(cx) == CXt_BLOCK);
2160 if (PL_op->op_flags & OPf_SPECIAL)
2161 /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */
2162 cx->blk_oldpm = PL_curpm;
2164 oldsp = PL_stack_base + cx->blk_oldsp;
2165 gimme = cx->blk_gimme;
2167 if (gimme == G_VOID)
2168 PL_stack_sp = oldsp;
2170 leave_adjust_stacks(oldsp, oldsp, gimme,
2171 PL_op->op_private & OPpLVALUE ? 3 : 1);
2181 S_outside_integer(pTHX_ SV *sv)
2184 const NV nv = SvNV_nomg(sv);
2185 if (Perl_isinfnan(nv))
2187 #ifdef NV_PRESERVES_UV
2188 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2191 if (nv <= (NV)IV_MIN)
2194 ((nv > (NV)UV_MAX ||
2195 SvUV_nomg(sv) > (UV)IV_MAX)))
2206 const U8 gimme = GIMME_V;
2207 void *itervarp; /* GV or pad slot of the iteration variable */
2208 SV *itersave; /* the old var in the iterator var slot */
2211 if (PL_op->op_targ) { /* "my" variable */
2212 itervarp = &PAD_SVl(PL_op->op_targ);
2213 itersave = *(SV**)itervarp;
2215 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2216 /* the SV currently in the pad slot is never live during
2217 * iteration (the slot is always aliased to one of the items)
2218 * so it's always stale */
2219 SvPADSTALE_on(itersave);
2221 SvREFCNT_inc_simple_void_NN(itersave);
2222 cxflags = CXp_FOR_PAD;
2225 SV * const sv = POPs;
2226 itervarp = (void *)sv;
2227 if (LIKELY(isGV(sv))) { /* symbol table variable */
2228 itersave = GvSV(sv);
2229 SvREFCNT_inc_simple_void(itersave);
2230 cxflags = CXp_FOR_GV;
2231 if (PL_op->op_private & OPpITER_DEF)
2232 cxflags |= CXp_FOR_DEF;
2234 else { /* LV ref: for \$foo (...) */
2235 assert(SvTYPE(sv) == SVt_PVMG);
2236 assert(SvMAGIC(sv));
2237 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2239 cxflags = CXp_FOR_LVREF;
2242 /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2243 assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2245 /* Note that this context is initially set as CXt_NULL. Further on
2246 * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2247 * there mustn't be anything in the blk_loop substruct that requires
2248 * freeing or undoing, in case we die in the meantime. And vice-versa.
2250 cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2251 cx_pushloop_for(cx, itervarp, itersave);
2253 if (PL_op->op_flags & OPf_STACKED) {
2254 /* OPf_STACKED implies either a single array: for(@), with a
2255 * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2257 SV *maybe_ary = POPs;
2258 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2261 SV * const right = maybe_ary;
2262 if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2263 DIE(aTHX_ "Assigned value is not a reference");
2266 if (RANGE_IS_NUMERIC(sv,right)) {
2267 cx->cx_type |= CXt_LOOP_LAZYIV;
2268 if (S_outside_integer(aTHX_ sv) ||
2269 S_outside_integer(aTHX_ right))
2270 DIE(aTHX_ "Range iterator outside integer range");
2271 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2272 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2275 cx->cx_type |= CXt_LOOP_LAZYSV;
2276 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2277 cx->blk_loop.state_u.lazysv.end = right;
2278 SvREFCNT_inc_simple_void_NN(right);
2279 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2280 /* This will do the upgrade to SVt_PV, and warn if the value
2281 is uninitialised. */
2282 (void) SvPV_nolen_const(right);
2283 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2284 to replace !SvOK() with a pointer to "". */
2286 SvREFCNT_dec(right);
2287 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2291 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2292 /* for (@array) {} */
2293 cx->cx_type |= CXt_LOOP_ARY;
2294 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2295 SvREFCNT_inc_simple_void_NN(maybe_ary);
2296 cx->blk_loop.state_u.ary.ix =
2297 (PL_op->op_private & OPpITER_REVERSED) ?
2298 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2301 /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
2303 else { /* iterating over items on the stack */
2304 cx->cx_type |= CXt_LOOP_LIST;
2305 cx->blk_oldsp = SP - PL_stack_base;
2306 cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2307 cx->blk_loop.state_u.stack.ix =
2308 (PL_op->op_private & OPpITER_REVERSED)
2310 : cx->blk_loop.state_u.stack.basesp;
2311 /* pre-extend stack so pp_iter doesn't have to check every time
2312 * it pushes yes/no */
2322 const U8 gimme = GIMME_V;
2324 cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2325 cx_pushloop_plain(cx);
2338 assert(CxTYPE_is_LOOP(cx));
2339 oldsp = PL_stack_base + cx->blk_oldsp;
2340 base = CxTYPE(cx) == CXt_LOOP_LIST
2341 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2343 gimme = cx->blk_gimme;
2345 if (gimme == G_VOID)
2348 leave_adjust_stacks(oldsp, base, gimme,
2349 PL_op->op_private & OPpLVALUE ? 3 : 1);
2352 cx_poploop(cx); /* Stack values are safe: release loop vars ... */
2360 /* This duplicates most of pp_leavesub, but with additional code to handle
2361 * return args in lvalue context. It was forked from pp_leavesub to
2362 * avoid slowing down that function any further.
2364 * Any changes made to this function may need to be copied to pp_leavesub
2367 * also tail-called by pp_return
2378 assert(CxTYPE(cx) == CXt_SUB);
2380 if (CxMULTICALL(cx)) {
2381 /* entry zero of a stack is always PL_sv_undef, which
2382 * simplifies converting a '()' return into undef in scalar context */
2383 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2387 gimme = cx->blk_gimme;
2388 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2390 if (gimme == G_VOID)
2391 PL_stack_sp = oldsp;
2393 U8 lval = CxLVAL(cx);
2394 bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2395 const char *what = NULL;
2397 if (gimme == G_SCALAR) {
2399 /* check for bad return arg */
2400 if (oldsp < PL_stack_sp) {
2401 SV *sv = *PL_stack_sp;
2402 if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2404 SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2405 : "a readonly value" : "a temporary";
2410 /* sub:lvalue{} will take us here. */
2415 "Can't return %s from lvalue subroutine", what);
2419 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2421 if (lval & OPpDEREF) {
2422 /* lval_sub()->{...} and similar */
2426 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2432 assert(gimme == G_ARRAY);
2433 assert (!(lval & OPpDEREF));
2436 /* scan for bad return args */
2438 for (p = PL_stack_sp; p > oldsp; p--) {
2440 /* the PL_sv_undef exception is to allow things like
2441 * this to work, where PL_sv_undef acts as 'skip'
2442 * placeholder on the LHS of list assigns:
2443 * sub foo :lvalue { undef }
2444 * ($a, undef, foo(), $b) = 1..4;
2446 if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2448 /* Might be flattened array after $#array = */
2449 what = SvREADONLY(sv)
2450 ? "a readonly value" : "a temporary";
2456 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2461 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
2463 retop = cx->blk_sub.retop;
2474 const I32 cxix = dopopto_cursub();
2476 assert(cxstack_ix >= 0);
2477 if (cxix < cxstack_ix) {
2479 if (!( PL_curstackinfo->si_type == PERLSI_SORT
2480 || ( PL_curstackinfo->si_type == PERLSI_MULTICALL
2481 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2484 DIE(aTHX_ "Can't return outside a subroutine");
2486 * a sort block, which is a CXt_NULL not a CXt_SUB;
2487 * or a /(?{...})/ block.
2488 * Handle specially. */
2489 assert(CxTYPE(&cxstack[0]) == CXt_NULL
2490 || ( CxTYPE(&cxstack[0]) == CXt_SUB
2491 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2492 if (cxstack_ix > 0) {
2493 /* See comment below about context popping. Since we know
2494 * we're scalar and not lvalue, we can preserve the return
2495 * value in a simpler fashion than there. */
2497 assert(cxstack[0].blk_gimme == G_SCALAR);
2498 if ( (sp != PL_stack_base)
2499 && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2501 *SP = sv_mortalcopy(sv);
2504 /* caller responsible for popping cxstack[0] */
2508 /* There are contexts that need popping. Doing this may free the
2509 * return value(s), so preserve them first: e.g. popping the plain
2510 * loop here would free $x:
2511 * sub f { { my $x = 1; return $x } }
2512 * We may also need to shift the args down; for example,
2513 * for (1,2) { return 3,4 }
2514 * leaves 1,2,3,4 on the stack. Both these actions will be done by
2515 * leave_adjust_stacks(), along with freeing any temps. Note that
2516 * whoever we tail-call (e.g. pp_leaveeval) will also call
2517 * leave_adjust_stacks(); however, the second call is likely to
2518 * just see a bunch of SvTEMPs with a ref count of 1, and so just
2519 * pass them through, rather than copying them again. So this
2520 * isn't as inefficient as it sounds.
2522 cx = &cxstack[cxix];
2524 if (cx->blk_gimme != G_VOID)
2525 leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2527 CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2531 cx = &cxstack[cxix]; /* CX stack may have been realloced */
2534 /* Like in the branch above, we need to handle any extra junk on
2535 * the stack. But because we're not also popping extra contexts, we
2536 * don't have to worry about prematurely freeing args. So we just
2537 * need to do the bare minimum to handle junk, and leave the main
2538 * arg processing in the function we tail call, e.g. pp_leavesub.
2539 * In list context we have to splice out the junk; in scalar
2540 * context we can leave as-is (pp_leavesub will later return the
2541 * top stack element). But for an empty arg list, e.g.
2542 * for (1,2) { return }
2543 * we need to set sp = oldsp so that pp_leavesub knows to push
2544 * &PL_sv_undef onto the stack.
2547 cx = &cxstack[cxix];
2548 oldsp = PL_stack_base + cx->blk_oldsp;
2549 if (oldsp != MARK) {
2550 SSize_t nargs = SP - MARK;
2552 if (cx->blk_gimme == G_ARRAY) {
2553 /* shift return args to base of call stack frame */
2554 Move(MARK + 1, oldsp + 1, nargs, SV*);
2555 PL_stack_sp = oldsp + nargs;
2559 PL_stack_sp = oldsp;
2563 /* fall through to a normal exit */
2564 switch (CxTYPE(cx)) {
2566 return CxTRYBLOCK(cx)
2567 ? Perl_pp_leavetry(aTHX)
2568 : Perl_pp_leaveeval(aTHX);
2570 return CvLVALUE(cx->blk_sub.cv)
2571 ? Perl_pp_leavesublv(aTHX)
2572 : Perl_pp_leavesub(aTHX);
2574 return Perl_pp_leavewrite(aTHX);
2576 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2580 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2582 static PERL_CONTEXT *
2586 if (PL_op->op_flags & OPf_SPECIAL) {
2587 cxix = dopoptoloop(cxstack_ix);
2589 /* diag_listed_as: Can't "last" outside a loop block */
2590 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2596 const char * const label =
2597 PL_op->op_flags & OPf_STACKED
2598 ? SvPV(TOPs,label_len)
2599 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2600 const U32 label_flags =
2601 PL_op->op_flags & OPf_STACKED
2603 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2605 cxix = dopoptolabel(label, label_len, label_flags);
2607 /* diag_listed_as: Label not found for "last %s" */
2608 Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"",
2610 SVfARG(PL_op->op_flags & OPf_STACKED
2611 && !SvGMAGICAL(TOPp1s)
2613 : newSVpvn_flags(label,
2615 label_flags | SVs_TEMP)));
2617 if (cxix < cxstack_ix)
2619 return &cxstack[cxix];
2628 cx = S_unwind_loop(aTHX);
2630 assert(CxTYPE_is_LOOP(cx));
2631 PL_stack_sp = PL_stack_base
2632 + (CxTYPE(cx) == CXt_LOOP_LIST
2633 ? cx->blk_loop.state_u.stack.basesp
2639 /* Stack values are safe: */
2641 cx_poploop(cx); /* release loop vars ... */
2643 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2653 /* if not a bare 'next' in the main scope, search for it */
2655 if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
2656 cx = S_unwind_loop(aTHX);
2659 PL_curcop = cx->blk_oldcop;
2661 return (cx)->blk_loop.my_op->op_nextop;
2666 PERL_CONTEXT *cx = S_unwind_loop(aTHX);
2667 OP* redo_op = cx->blk_loop.my_op->op_redoop;
2669 if (redo_op->op_type == OP_ENTER) {
2670 /* pop one less context to avoid $x being freed in while (my $x..) */
2673 assert(CxTYPE(cx) == CXt_BLOCK);
2674 redo_op = redo_op->op_next;
2680 PL_curcop = cx->blk_oldcop;
2685 #define UNENTERABLE (OP *)1
2686 #define GOTO_DEPTH 64
2689 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2692 static const char* const too_deep = "Target of goto is too deeply nested";
2694 PERL_ARGS_ASSERT_DOFINDLABEL;
2697 Perl_croak(aTHX_ "%s", too_deep);
2698 if (o->op_type == OP_LEAVE ||
2699 o->op_type == OP_SCOPE ||
2700 o->op_type == OP_LEAVELOOP ||
2701 o->op_type == OP_LEAVESUB ||
2702 o->op_type == OP_LEAVETRY ||
2703 o->op_type == OP_LEAVEGIVEN)
2705 *ops++ = cUNOPo->op_first;
2707 else if (oplimit - opstack < GOTO_DEPTH) {
2708 if (o->op_flags & OPf_KIDS
2709 && cUNOPo->op_first->op_type == OP_PUSHMARK) {
2710 *ops++ = UNENTERABLE;
2712 else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type]
2713 && OP_CLASS(o) != OA_LOGOP
2714 && o->op_type != OP_LINESEQ
2715 && o->op_type != OP_SREFGEN
2716 && o->op_type != OP_ENTEREVAL
2717 && o->op_type != OP_GLOB
2718 && o->op_type != OP_RV2CV) {
2719 OP * const kid = cUNOPo->op_first;
2720 if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid))
2721 *ops++ = UNENTERABLE;
2725 Perl_croak(aTHX_ "%s", too_deep);
2727 if (o->op_flags & OPf_KIDS) {
2729 OP * const kid1 = cUNOPo->op_first;
2730 /* First try all the kids at this level, since that's likeliest. */
2731 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2732 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2733 STRLEN kid_label_len;
2734 U32 kid_label_flags;
2735 const char *kid_label = CopLABEL_len_flags(kCOP,
2736 &kid_label_len, &kid_label_flags);
2738 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2741 (const U8*)kid_label, kid_label_len,
2742 (const U8*)label, len) == 0)
2744 (const U8*)label, len,
2745 (const U8*)kid_label, kid_label_len) == 0)
2746 : ( len == kid_label_len && ((kid_label == label)
2747 || memEQ(kid_label, label, len)))))
2751 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2752 bool first_kid_of_binary = FALSE;
2753 if (kid == PL_lastgotoprobe)
2755 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2758 else if (ops[-1] != UNENTERABLE
2759 && (ops[-1]->op_type == OP_NEXTSTATE ||
2760 ops[-1]->op_type == OP_DBSTATE))
2765 if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) {
2766 first_kid_of_binary = TRUE;
2769 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2771 if (first_kid_of_binary)
2772 *ops++ = UNENTERABLE;
2781 S_check_op_type(pTHX_ OP * const o)
2783 /* Eventually we may want to stack the needed arguments
2784 * for each op. For now, we punt on the hard ones. */
2785 /* XXX This comment seems to me like wishful thinking. --sprout */
2786 if (o == UNENTERABLE)
2788 "Can't \"goto\" into a binary or list expression");
2789 if (o->op_type == OP_ENTERITER)
2791 "Can't \"goto\" into the middle of a foreach loop");
2792 if (o->op_type == OP_ENTERGIVEN)
2794 "Can't \"goto\" into a \"given\" block");
2797 /* also used for: pp_dump() */
2805 OP *enterops[GOTO_DEPTH];
2806 const char *label = NULL;
2807 STRLEN label_len = 0;
2808 U32 label_flags = 0;
2809 const bool do_dump = (PL_op->op_type == OP_DUMP);
2810 static const char* const must_have_label = "goto must have label";
2812 if (PL_op->op_flags & OPf_STACKED) {
2813 /* goto EXPR or goto &foo */
2815 SV * const sv = POPs;
2818 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2819 /* This egregious kludge implements goto &subroutine */
2822 CV *cv = MUTABLE_CV(SvRV(sv));
2823 AV *arg = GvAV(PL_defgv);
2825 while (!CvROOT(cv) && !CvXSUB(cv)) {
2826 const GV * const gv = CvGV(cv);
2830 /* autoloaded stub? */
2831 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2833 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2835 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2836 if (autogv && (cv = GvCV(autogv)))
2838 tmpstr = sv_newmortal();
2839 gv_efullname3(tmpstr, gv, NULL);
2840 DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
2842 DIE(aTHX_ "Goto undefined subroutine");
2845 cxix = dopopto_cursub();
2847 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2849 cx = &cxstack[cxix];
2850 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2851 if (CxTYPE(cx) == CXt_EVAL) {
2853 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2854 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2856 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2857 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2859 else if (CxMULTICALL(cx))
2860 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2862 /* First do some returnish stuff. */
2864 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2866 if (cxix < cxstack_ix) {
2873 /* protect @_ during save stack unwind. */
2875 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
2877 assert(PL_scopestack_ix == cx->blk_oldscopesp);
2880 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2881 /* this is part of cx_popsub_args() */
2882 AV* av = MUTABLE_AV(PAD_SVl(0));
2883 assert(AvARRAY(MUTABLE_AV(
2884 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2885 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2887 /* we are going to donate the current @_ from the old sub
2888 * to the new sub. This first part of the donation puts a
2889 * new empty AV in the pad[0] slot of the old sub,
2890 * unless pad[0] and @_ differ (e.g. if the old sub did
2891 * local *_ = []); in which case clear the old pad[0]
2892 * array in the usual way */
2893 if (av == arg || AvREAL(av))
2894 clear_defarray(av, av == arg);
2895 else CLEAR_ARGARRAY(av);
2898 /* don't restore PL_comppad here. It won't be needed if the
2899 * sub we're going to is non-XS, but restoring it early then
2900 * croaking (e.g. the "Goto undefined subroutine" below)
2901 * means the CX block gets processed again in dounwind,
2902 * but this time with the wrong PL_comppad */
2904 /* A destructor called during LEAVE_SCOPE could have undefined
2905 * our precious cv. See bug #99850. */
2906 if (!CvROOT(cv) && !CvXSUB(cv)) {
2907 const GV * const gv = CvGV(cv);
2909 SV * const tmpstr = sv_newmortal();
2910 gv_efullname3(tmpstr, gv, NULL);
2911 DIE(aTHX_ "Goto undefined subroutine &%" SVf,
2914 DIE(aTHX_ "Goto undefined subroutine");
2917 if (CxTYPE(cx) == CXt_SUB) {
2918 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2919 SvREFCNT_dec_NN(cx->blk_sub.cv);
2922 /* Now do some callish stuff. */
2924 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2925 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2930 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2932 /* put GvAV(defgv) back onto stack */
2934 EXTEND(SP, items+1); /* @_ could have been extended. */
2939 bool r = cBOOL(AvREAL(arg));
2940 for (index=0; index<items; index++)
2944 SV ** const svp = av_fetch(arg, index, 0);
2945 sv = svp ? *svp : NULL;
2947 else sv = AvARRAY(arg)[index];
2949 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2950 : sv_2mortal(newSVavdefelem(arg, index, 1));
2954 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2955 /* Restore old @_ */
2956 CX_POP_SAVEARRAY(cx);
2959 retop = cx->blk_sub.retop;
2960 PL_comppad = cx->blk_sub.prevcomppad;
2961 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2963 /* XS subs don't have a CXt_SUB, so pop it;
2964 * this is a cx_popblock(), less all the stuff we already did
2965 * for cx_topblock() earlier */
2966 PL_curcop = cx->blk_oldcop;
2967 /* this is cx_popsub, less all the stuff we already did */
2968 PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
2972 /* Push a mark for the start of arglist */
2975 (void)(*CvXSUB(cv))(aTHX_ cv);
2980 PADLIST * const padlist = CvPADLIST(cv);
2982 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2984 /* partial unrolled cx_pushsub(): */
2986 cx->blk_sub.cv = cv;
2987 cx->blk_sub.olddepth = CvDEPTH(cv);
2990 SvREFCNT_inc_simple_void_NN(cv);
2991 if (CvDEPTH(cv) > 1) {
2992 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2993 sub_crush_depth(cv);
2994 pad_push(padlist, CvDEPTH(cv));
2996 PL_curcop = cx->blk_oldcop;
2997 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
3000 /* second half of donating @_ from the old sub to the
3001 * new sub: abandon the original pad[0] AV in the
3002 * new sub, and replace it with the donated @_.
3003 * pad[0] takes ownership of the extra refcount
3004 * we gave arg earlier */
3006 SvREFCNT_dec(PAD_SVl(0));
3007 PAD_SVl(0) = (SV *)arg;
3008 SvREFCNT_inc_simple_void_NN(arg);
3011 /* GvAV(PL_defgv) might have been modified on scope
3012 exit, so point it at arg again. */
3013 if (arg != GvAV(PL_defgv)) {
3014 AV * const av = GvAV(PL_defgv);
3015 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
3020 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
3021 Perl_get_db_sub(aTHX_ NULL, cv);
3023 CV * const gotocv = get_cvs("DB::goto", 0);
3025 PUSHMARK( PL_stack_sp );
3026 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
3031 retop = CvSTART(cv);
3032 goto putback_return;
3037 label = SvPV_nomg_const(sv, label_len);
3038 label_flags = SvUTF8(sv);
3041 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
3042 /* goto LABEL or dump LABEL */
3043 label = cPVOP->op_pv;
3044 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
3045 label_len = strlen(label);
3047 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
3052 OP *gotoprobe = NULL;
3053 bool leaving_eval = FALSE;
3054 bool in_block = FALSE;
3055 bool pseudo_block = FALSE;
3056 PERL_CONTEXT *last_eval_cx = NULL;
3060 PL_lastgotoprobe = NULL;
3062 for (ix = cxstack_ix; ix >= 0; ix--) {
3064 switch (CxTYPE(cx)) {
3066 leaving_eval = TRUE;
3067 if (!CxTRYBLOCK(cx)) {
3068 gotoprobe = (last_eval_cx ?
3069 last_eval_cx->blk_eval.old_eval_root :
3074 /* else fall through */
3075 case CXt_LOOP_PLAIN:
3076 case CXt_LOOP_LAZYIV:
3077 case CXt_LOOP_LAZYSV:
3082 gotoprobe = OpSIBLING(cx->blk_oldcop);
3088 gotoprobe = OpSIBLING(cx->blk_oldcop);
3091 gotoprobe = PL_main_root;
3094 gotoprobe = CvROOT(cx->blk_sub.cv);
3095 pseudo_block = cBOOL(CxMULTICALL(cx));
3099 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3102 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3103 CxTYPE(cx), (long) ix);
3104 gotoprobe = PL_main_root;
3110 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3111 enterops, enterops + GOTO_DEPTH);
3114 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3115 sibl1->op_type == OP_UNSTACK &&
3116 (sibl2 = OpSIBLING(sibl1)))
3118 retop = dofindlabel(sibl2,
3119 label, label_len, label_flags, enterops,
3120 enterops + GOTO_DEPTH);
3126 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3127 PL_lastgotoprobe = gotoprobe;
3130 DIE(aTHX_ "Can't find label %" UTF8f,
3131 UTF8fARG(label_flags, label_len, label));
3133 /* if we're leaving an eval, check before we pop any frames
3134 that we're not going to punt, otherwise the error
3137 if (leaving_eval && *enterops && enterops[1]) {
3139 for (i = 1; enterops[i]; i++)
3140 S_check_op_type(aTHX_ enterops[i]);
3143 if (*enterops && enterops[1]) {
3144 I32 i = enterops[1] != UNENTERABLE
3145 && enterops[1]->op_type == OP_ENTER && in_block
3149 deprecate("\"goto\" to jump into a construct");
3152 /* pop unwanted frames */
3154 if (ix < cxstack_ix) {
3156 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3162 /* push wanted frames */
3164 if (*enterops && enterops[1]) {
3165 OP * const oldop = PL_op;
3166 ix = enterops[1] != UNENTERABLE
3167 && enterops[1]->op_type == OP_ENTER && in_block
3170 for (; enterops[ix]; ix++) {
3171 PL_op = enterops[ix];
3172 S_check_op_type(aTHX_ PL_op);
3173 DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n",
3175 PL_op->op_ppaddr(aTHX);
3183 if (!retop) retop = PL_main_start;
3185 PL_restartop = retop;
3186 PL_do_undump = TRUE;
3190 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3191 PL_do_undump = FALSE;
3209 anum = 0; (void)POPs;
3215 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3218 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3221 PL_exit_flags |= PERL_EXIT_EXPECTED;
3223 PUSHs(&PL_sv_undef);
3230 S_save_lines(pTHX_ AV *array, SV *sv)
3232 const char *s = SvPVX_const(sv);
3233 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3236 PERL_ARGS_ASSERT_SAVE_LINES;
3238 while (s && s < send) {
3240 SV * const tmpstr = newSV_type(SVt_PVMG);
3242 t = (const char *)memchr(s, '\n', send - s);
3248 sv_setpvn(tmpstr, s, t - s);
3249 av_store(array, line++, tmpstr);
3257 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3259 0 is used as continue inside eval,
3261 3 is used for a die caught by an inner eval - continue inner loop
3263 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3264 establish a local jmpenv to handle exception traps.
3269 S_docatch(pTHX_ Perl_ppaddr_t firstpp)
3272 OP * const oldop = PL_op;
3275 assert(CATCH_GET == TRUE);
3280 PL_op = firstpp(aTHX);
3285 /* die caught by an inner eval - continue inner loop */
3286 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3287 PL_restartjmpenv = NULL;
3288 PL_op = PL_restartop;
3297 NOT_REACHED; /* NOTREACHED */
3306 =for apidoc find_runcv
3308 Locate the CV corresponding to the currently executing sub or eval.
3309 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3310 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3311 entered. (This allows debuggers to eval in the scope of the breakpoint
3312 rather than in the scope of the debugger itself.)
3318 Perl_find_runcv(pTHX_ U32 *db_seqp)
3320 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3323 /* If this becomes part of the API, it might need a better name. */
3325 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3332 PL_curcop == &PL_compiling
3334 : PL_curcop->cop_seq;
3336 for (si = PL_curstackinfo; si; si = si->si_prev) {
3338 for (ix = si->si_cxix; ix >= 0; ix--) {
3339 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3341 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3342 cv = cx->blk_sub.cv;
3343 /* skip DB:: code */
3344 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3345 *db_seqp = cx->blk_oldcop->cop_seq;
3348 if (cx->cx_type & CXp_SUB_RE)
3351 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3352 cv = cx->blk_eval.cv;
3355 case FIND_RUNCV_padid_eq:
3357 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3360 case FIND_RUNCV_level_eq:
3361 if (level++ != arg) continue;
3369 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3373 /* Run yyparse() in a setjmp wrapper. Returns:
3374 * 0: yyparse() successful
3375 * 1: yyparse() failed
3379 S_try_yyparse(pTHX_ int gramtype)
3384 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3388 ret = yyparse(gramtype) ? 1 : 0;
3395 NOT_REACHED; /* NOTREACHED */
3402 /* Compile a require/do or an eval ''.
3404 * outside is the lexically enclosing CV (if any) that invoked us.
3405 * seq is the current COP scope value.
3406 * hh is the saved hints hash, if any.
3408 * Returns a bool indicating whether the compile was successful; if so,
3409 * PL_eval_start contains the first op of the compiled code; otherwise,
3412 * This function is called from two places: pp_require and pp_entereval.
3413 * These can be distinguished by whether PL_op is entereval.
3417 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3420 OP * const saveop = PL_op;
3421 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3422 COP * const oldcurcop = PL_curcop;
3423 bool in_require = (saveop->op_type == OP_REQUIRE);
3427 PL_in_eval = (in_require
3428 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3430 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3431 ? EVAL_RE_REPARSING : 0)));
3435 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3437 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3438 CX_CUR()->blk_eval.cv = evalcv;
3439 CX_CUR()->blk_gimme = gimme;
3441 CvOUTSIDE_SEQ(evalcv) = seq;
3442 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3444 /* set up a scratch pad */
3446 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3447 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3450 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3452 /* make sure we compile in the right package */
3454 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3455 SAVEGENERICSV(PL_curstash);
3456 PL_curstash = (HV *)CopSTASH(PL_curcop);
3457 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3459 SvREFCNT_inc_simple_void(PL_curstash);
3460 save_item(PL_curstname);
3461 sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash));
3464 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3465 SAVESPTR(PL_beginav);
3466 PL_beginav = newAV();
3467 SAVEFREESV(PL_beginav);
3468 SAVESPTR(PL_unitcheckav);
3469 PL_unitcheckav = newAV();
3470 SAVEFREESV(PL_unitcheckav);
3473 ENTER_with_name("evalcomp");
3474 SAVESPTR(PL_compcv);
3477 /* try to compile it */
3479 PL_eval_root = NULL;
3480 PL_curcop = &PL_compiling;
3481 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3482 PL_in_eval |= EVAL_KEEPERR;
3488 PL_hints = HINTS_DEFAULT;
3489 hv_clear(GvHV(PL_hintgv));
3493 PL_hints = saveop->op_private & OPpEVAL_COPHH
3494 ? oldcurcop->cop_hints : (U32)saveop->op_targ;
3496 /* making 'use re eval' not be in scope when compiling the
3497 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3498 * infinite recursion when S_has_runtime_code() gives a false
3499 * positive: the second time round, HINT_RE_EVAL isn't set so we
3500 * don't bother calling S_has_runtime_code() */
3501 if (PL_in_eval & EVAL_RE_REPARSING)
3502 PL_hints &= ~HINT_RE_EVAL;
3505 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3506 SvREFCNT_dec(GvHV(PL_hintgv));
3507 GvHV(PL_hintgv) = hh;
3508 FETCHFEATUREBITSHH(hh);
3511 SAVECOMPILEWARNINGS();
3513 if (PL_dowarn & G_WARN_ALL_ON)
3514 PL_compiling.cop_warnings = pWARN_ALL ;
3515 else if (PL_dowarn & G_WARN_ALL_OFF)
3516 PL_compiling.cop_warnings = pWARN_NONE ;
3518 PL_compiling.cop_warnings = pWARN_STD ;
3521 PL_compiling.cop_warnings =
3522 DUP_WARNINGS(oldcurcop->cop_warnings);
3523 cophh_free(CopHINTHASH_get(&PL_compiling));
3524 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3525 /* The label, if present, is the first entry on the chain. So rather
3526 than writing a blank label in front of it (which involves an
3527 allocation), just use the next entry in the chain. */
3528 PL_compiling.cop_hints_hash
3529 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3530 /* Check the assumption that this removed the label. */
3531 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3534 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3537 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3539 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3540 * so honour CATCH_GET and trap it here if necessary */
3543 /* compile the code */
3544 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3546 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3551 /* note that if yystatus == 3, then the require/eval died during
3552 * compilation, so the EVAL CX block has already been popped, and
3553 * various vars restored */
3554 if (yystatus != 3) {
3556 op_free(PL_eval_root);
3557 PL_eval_root = NULL;
3559 SP = PL_stack_base + POPMARK; /* pop original mark */
3561 assert(CxTYPE(cx) == CXt_EVAL);
3562 /* pop the CXt_EVAL, and if was a require, croak */
3563 S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
3566 /* die_unwind() re-croaks when in require, having popped the
3567 * require EVAL context. So we should never catch a require
3569 assert(!in_require);
3572 if (!*(SvPV_nolen_const(errsv)))
3573 sv_setpvs(errsv, "Compilation error");
3575 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3580 /* Compilation successful. Now clean up */
3582 LEAVE_with_name("evalcomp");
3584 CopLINE_set(&PL_compiling, 0);
3585 SAVEFREEOP(PL_eval_root);
3586 cv_forget_slab(evalcv);
3588 DEBUG_x(dump_eval());
3590 /* Register with debugger: */
3591 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3592 CV * const cv = get_cvs("DB::postponed", 0);
3596 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3598 call_sv(MUTABLE_SV(cv), G_DISCARD);
3602 if (PL_unitcheckav) {
3603 OP *es = PL_eval_start;
3604 call_list(PL_scopestack_ix, PL_unitcheckav);
3608 CvDEPTH(evalcv) = 1;
3609 SP = PL_stack_base + POPMARK; /* pop original mark */
3610 PL_op = saveop; /* The caller may need it. */
3611 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3617 /* Return NULL if the file doesn't exist or isn't a file;
3618 * else return PerlIO_openn().
3622 S_check_type_and_open(pTHX_ SV *name)
3627 const char *p = SvPV_const(name, len);
3630 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3632 /* checking here captures a reasonable error message when
3633 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3634 * user gets a confusing message about looking for the .pmc file
3635 * rather than for the .pm file so do the check in S_doopen_pm when
3636 * PMC is on instead of here. S_doopen_pm calls this func.
3637 * This check prevents a \0 in @INC causing problems.
3639 #ifdef PERL_DISABLE_PMC
3640 if (!IS_SAFE_PATHNAME(p, len, "require"))
3644 /* on Win32 stat is expensive (it does an open() and close() twice and
3645 a couple other IO calls), the open will fail with a dir on its own with
3646 errno EACCES, so only do a stat to separate a dir from a real EACCES
3647 caused by user perms */
3649 st_rc = PerlLIO_stat(p, &st);
3655 if(S_ISBLK(st.st_mode)) {
3659 else if(S_ISDIR(st.st_mode)) {
3668 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3670 /* EACCES stops the INC search early in pp_require to implement
3671 feature RT #113422 */
3672 if(!retio && errno == EACCES) { /* exists but probably a directory */
3674 st_rc = PerlLIO_stat(p, &st);
3676 if(S_ISDIR(st.st_mode))
3678 else if(S_ISBLK(st.st_mode))
3689 /* doopen_pm(): return the equivalent of PerlIO_openn() on the given name,
3690 * but first check for bad names (\0) and non-files.
3691 * Also if the filename ends in .pm and unless PERL_DISABLE_PMC,
3692 * try loading Foo.pmc first.
3694 #ifndef PERL_DISABLE_PMC
3696 S_doopen_pm(pTHX_ SV *name)
3699 const char *p = SvPV_const(name, namelen);
3701 PERL_ARGS_ASSERT_DOOPEN_PM;
3703 /* check the name before trying for the .pmc name to avoid the
3704 * warning referring to the .pmc which the user probably doesn't
3705 * know or care about
3707 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3710 if (memENDPs(p, namelen, ".pm")) {
3711 SV *const pmcsv = sv_newmortal();
3714 SvSetSV_nosteal(pmcsv,name);
3715 sv_catpvs(pmcsv, "c");
3717 pmcio = check_type_and_open(pmcsv);
3721 return check_type_and_open(name);
3724 # define doopen_pm(name) check_type_and_open(name)
3725 #endif /* !PERL_DISABLE_PMC */
3727 /* require doesn't search in @INC for absolute names, or when the name is
3728 explicitly relative the current directory: i.e. ./, ../ */
3729 PERL_STATIC_INLINE bool
3730 S_path_is_searchable(const char *name)
3732 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3734 if (PERL_FILE_IS_ABSOLUTE(name)
3736 || (*name == '.' && ((name[1] == '/' ||
3737 (name[1] == '.' && name[2] == '/'))
3738 || (name[1] == '\\' ||
3739 ( name[1] == '.' && name[2] == '\\')))
3742 || (*name == '.' && (name[1] == '/' ||
3743 (name[1] == '.' && name[2] == '/')))
3754 /* implement 'require 5.010001' */
3757 S_require_version(pTHX_ SV *sv)
3761 sv = sv_2mortal(new_version(sv));
3762 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3763 upg_version(PL_patchlevel, TRUE);
3764 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3765 if ( vcmp(sv,PL_patchlevel) <= 0 )
3766 DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
3767 SVfARG(sv_2mortal(vnormal(sv))),
3768 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3772 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3775 SV * const req = SvRV(sv);
3776 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3778 /* get the left hand term */
3779 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3781 first = SvIV(*av_fetch(lav,0,0));
3782 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3783 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3784 || av_count(lav) > 2 /* FP with > 3 digits */
3785 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3787 DIE(aTHX_ "Perl %" SVf " required--this is only "
3788 "%" SVf ", stopped",
3789 SVfARG(sv_2mortal(vnormal(req))),
3790 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3793 else { /* probably 'use 5.10' or 'use 5.8' */
3797 if (av_count(lav) > 1)
3798 second = SvIV(*av_fetch(lav,1,0));
3800 second /= second >= 600 ? 100 : 10;
3801 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3802 (int)first, (int)second);
3803 upg_version(hintsv, TRUE);
3805 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)"
3806 "--this is only %" SVf ", stopped",
3807 SVfARG(sv_2mortal(vnormal(req))),
3808 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3809 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3818 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
3819 * The first form will have already been converted at compile time to
3820 * the second form */
3823 S_require_file(pTHX_ SV *sv)
3833 int vms_unixname = 0;
3836 /* tryname is the actual pathname (with @INC prefix) which was loaded.
3837 * It's stored as a value in %INC, and used for error messages */
3838 const char *tryname = NULL;
3839 SV *namesv = NULL; /* SV equivalent of tryname */
3840 const U8 gimme = GIMME_V;
3841 int filter_has_file = 0;
3842 PerlIO *tryrsfp = NULL;
3843 SV *filter_cache = NULL;
3844 SV *filter_state = NULL;
3845 SV *filter_sub = NULL;
3849 bool path_searchable;
3850 I32 old_savestack_ix;
3851 const bool op_is_require = PL_op->op_type == OP_REQUIRE;
3852 const char *const op_name = op_is_require ? "require" : "do";
3853 SV ** svp_cached = NULL;
3855 assert(op_is_require || PL_op->op_type == OP_DOFILE);
3858 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3859 name = SvPV_nomg_const(sv, len);
3860 if (!(name && len > 0 && *name))
3861 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3864 /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */
3865 if (op_is_require) {
3866 /* can optimize to only perform one single lookup */
3867 svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0);
3868 if ( svp_cached && (SvGETMAGIC(*svp_cached), SvOK(*svp_cached)) ) RETPUSHYES;
3872 if (!IS_SAFE_PATHNAME(name, len, op_name)) {
3873 if (!op_is_require) {
3877 DIE(aTHX_ "Can't locate %s: %s",
3878 pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
3879 NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3882 TAINT_PROPER(op_name);
3884 path_searchable = path_is_searchable(name);
3887 /* The key in the %ENV hash is in the syntax of file passed as the argument
3888 * usually this is in UNIX format, but sometimes in VMS format, which
3889 * can result in a module being pulled in more than once.
3890 * To prevent this, the key must be stored in UNIX format if the VMS
3891 * name can be translated to UNIX.
3895 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3897 unixlen = strlen(unixname);
3903 /* if not VMS or VMS name can not be translated to UNIX, pass it
3906 unixname = (char *) name;
3909 if (op_is_require) {
3910 /* reuse the previous hv_fetch result if possible */
3911 SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3913 /* we already did a get magic if this was cached */
3919 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3920 "Compilation failed in require", unixname);
3923 /*XXX OPf_KIDS should always be true? -dapm 4/2017 */
3924 if (PL_op->op_flags & OPf_KIDS) {
3925 SVOP * const kid = (SVOP*)cUNOP->op_first;
3927 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3928 /* Make sure that a bareword module name (e.g. ::Foo::Bar)
3929 * doesn't map to a naughty pathname like /Foo/Bar.pm.
3930 * Note that the parser will normally detect such errors
3931 * at compile time before we reach here, but
3932 * Perl_load_module() can fake up an identical optree
3933 * without going near the parser, and being able to put
3934 * anything as the bareword. So we include a duplicate set
3935 * of checks here at runtime.
3937 const STRLEN package_len = len - 3;
3938 const char slashdot[2] = {'/', '.'};
3940 const char backslashdot[2] = {'\\', '.'};
3943 /* Disallow *purported* barewords that map to absolute
3944 filenames, filenames relative to the current or parent
3945 directory, or (*nix) hidden filenames. Also sanity check
3946 that the generated filename ends .pm */
3947 if (!path_searchable || len < 3 || name[0] == '.'
3948 || !memEQs(name + package_len, len - package_len, ".pm"))
3949 DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv);
3950 if (memchr(name, 0, package_len)) {
3951 /* diag_listed_as: Bareword in require contains "%s" */
3952 DIE(aTHX_ "Bareword in require contains \"\\0\"");
3954 if (ninstr(name, name + package_len, slashdot,
3955 slashdot + sizeof(slashdot))) {
3956 /* diag_listed_as: Bareword in require contains "%s" */
3957 DIE(aTHX_ "Bareword in require contains \"/.\"");
3960 if (ninstr(name, name + package_len, backslashdot,
3961 backslashdot + sizeof(backslashdot))) {
3962 /* diag_listed_as: Bareword in require contains "%s" */
3963 DIE(aTHX_ "Bareword in require contains \"\\.\"");
3970 PERL_DTRACE_PROBE_FILE_LOADING(unixname);
3972 /* Try to locate and open a file, possibly using @INC */
3974 /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load
3975 * the file directly rather than via @INC ... */
3976 if (!path_searchable) {
3977 /* At this point, name is SvPVX(sv) */
3979 tryrsfp = doopen_pm(sv);
3982 /* ... but if we fail, still search @INC for code references;
3983 * these are applied even on non-searchable paths (except
3984 * if we got EACESS).
3986 * For searchable paths, just search @INC normally
3988 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3989 AV * const ar = GvAVn(PL_incgv);
3996 namesv = newSV_type(SVt_PV);
3997 for (i = 0; i <= AvFILL(ar); i++) {
3998 SV * const dirsv = *av_fetch(ar, i, TRUE);
4006 if (SvTYPE(SvRV(loader)) == SVt_PVAV
4007 && !SvOBJECT(SvRV(loader)))
4009 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
4013 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
4014 PTR2UV(SvRV(dirsv)), name);
4015 tryname = SvPVX_const(namesv);
4018 if (SvPADTMP(nsv)) {
4019 nsv = sv_newmortal();
4020 SvSetSV_nosteal(nsv,sv);
4023 ENTER_with_name("call_INC");
4031 if (SvGMAGICAL(loader)) {
4032 SV *l = sv_newmortal();
4033 sv_setsv_nomg(l, loader);
4036 if (sv_isobject(loader))
4037 count = call_method("INC", G_ARRAY);
4039 count = call_sv(loader, G_ARRAY);
4049 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
4050 && !isGV_with_GP(SvRV(arg))) {
4051 filter_cache = SvRV(arg);
4058 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
4062 if (isGV_with_GP(arg)) {
4063 IO * const io = GvIO((const GV *)arg);
4068 tryrsfp = IoIFP(io);
4069 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
4070 PerlIO_close(IoOFP(io));
4081 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
4083 SvREFCNT_inc_simple_void_NN(filter_sub);
4086 filter_state = SP[i];
4087 SvREFCNT_inc_simple_void(filter_state);
4091 if (!tryrsfp && (filter_cache || filter_sub)) {
4092 tryrsfp = PerlIO_open(BIT_BUCKET,
4098 /* FREETMPS may free our filter_cache */
4099 SvREFCNT_inc_simple_void(filter_cache);
4103 LEAVE_with_name("call_INC");
4105 /* Now re-mortalize it. */
4106 sv_2mortal(filter_cache);
4108 /* Adjust file name if the hook has set an %INC entry.
4109 This needs to happen after the FREETMPS above. */
4110 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
4112 tryname = SvPV_nolen_const(*svp);
4119 filter_has_file = 0;
4120 filter_cache = NULL;
4122 SvREFCNT_dec_NN(filter_state);
4123 filter_state = NULL;
4126 SvREFCNT_dec_NN(filter_sub);
4130 else if (path_searchable) {
4131 /* match against a plain @INC element (non-searchable
4132 * paths are only matched against refs in @INC) */
4137 dir = SvPV_nomg_const(dirsv, dirlen);
4143 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
4147 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4150 sv_setpv(namesv, unixdir);
4151 sv_catpv(namesv, unixname);
4153 /* The equivalent of
4154 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4155 but without the need to parse the format string, or
4156 call strlen on either pointer, and with the correct
4157 allocation up front. */
4159 char *tmp = SvGROW(namesv, dirlen + len + 2);
4161 memcpy(tmp, dir, dirlen);
4164 /* Avoid '<dir>//<file>' */
4165 if (!dirlen || *(tmp-1) != '/') {
4168 /* So SvCUR_set reports the correct length below */
4172 /* name came from an SV, so it will have a '\0' at the
4173 end that we can copy as part of this memcpy(). */
4174 memcpy(tmp, name, len + 1);
4176 SvCUR_set(namesv, dirlen + len + 1);
4180 TAINT_PROPER(op_name);
4181 tryname = SvPVX_const(namesv);
4182 tryrsfp = doopen_pm(namesv);
4184 if (tryname[0] == '.' && tryname[1] == '/') {
4186 while (*++tryname == '/') {}
4190 else if (errno == EMFILE || errno == EACCES) {
4191 /* no point in trying other paths if out of handles;
4192 * on the other hand, if we couldn't open one of the
4193 * files, then going on with the search could lead to
4194 * unexpected results; see perl #113422
4203 /* at this point we've ether opened a file (tryrsfp) or set errno */
4205 saved_errno = errno; /* sv_2mortal can realloc things */
4208 /* we failed; croak if require() or return undef if do() */
4209 if (op_is_require) {
4210 if(saved_errno == EMFILE || saved_errno == EACCES) {
4211 /* diag_listed_as: Can't locate %s */
4212 DIE(aTHX_ "Can't locate %s: %s: %s",
4213 name, tryname, Strerror(saved_errno));
4215 if (path_searchable) { /* did we lookup @INC? */
4216 AV * const ar = GvAVn(PL_incgv);
4218 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4219 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4220 for (i = 0; i <= AvFILL(ar); i++) {
4221 sv_catpvs(inc, " ");
4222 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4224 if (memENDPs(name, len, ".pm")) {
4225 const char *e = name + len - (sizeof(".pm") - 1);
4227 bool utf8 = cBOOL(SvUTF8(sv));
4229 /* if the filename, when converted from "Foo/Bar.pm"
4230 * form back to Foo::Bar form, makes a valid
4231 * package name (i.e. parseable by C<require
4232 * Foo::Bar>), then emit a hint.
4234 * this loop is modelled after the one in
4238 if (utf8 && isIDFIRST_utf8_safe(c, e)) {
4240 while (c < e && isIDCONT_utf8_safe(
4241 (const U8*) c, (const U8*) e))
4244 else if (isWORDCHAR_A(*c)) {
4245 while (c < e && isWORDCHAR_A(*c))
4254 if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
4255 sv_catpvs(msg, " (you may need to install the ");
4256 for (c = name; c < e; c++) {
4258 sv_catpvs(msg, "::");
4261 sv_catpvn(msg, c, 1);
4264 sv_catpvs(msg, " module)");
4267 else if (memENDs(name, len, ".h")) {
4268 sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4270 else if (memENDs(name, len, ".ph")) {
4271 sv_catpvs(msg, " (did you run h2ph?)");
4274 /* diag_listed_as: Can't locate %s */
4276 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4280 DIE(aTHX_ "Can't locate %s", name);
4283 #ifdef DEFAULT_INC_EXCLUDES_DOT
4287 /* the complication is to match the logic from doopen_pm() so
4288 * we don't treat do "sda1" as a previously successful "do".
4290 bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED)
4291 && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode)
4292 && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL;
4298 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4299 "do \"%s\" failed, '.' is no longer in @INC; "
4300 "did you mean do \"./%s\"?",
4309 SETERRNO(0, SS_NORMAL);
4311 /* Update %INC. Assume success here to prevent recursive requirement. */
4312 /* name is never assigned to again, so len is still strlen(name) */
4313 /* Check whether a hook in @INC has already filled %INC */
4315 (void)hv_store(GvHVn(PL_incgv),
4316 unixname, unixlen, newSVpv(tryname,0),0);
4318 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4320 (void)hv_store(GvHVn(PL_incgv),
4321 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4324 /* Now parse the file */
4326 old_savestack_ix = PL_savestack_ix;
4327 SAVECOPFILE_FREE(&PL_compiling);
4328 CopFILE_set(&PL_compiling, tryname);
4329 lex_start(NULL, tryrsfp, 0);
4331 if (filter_sub || filter_cache) {
4332 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4333 than hanging another SV from it. In turn, filter_add() optionally
4334 takes the SV to use as the filter (or creates a new SV if passed
4335 NULL), so simply pass in whatever value filter_cache has. */
4336 SV * const fc = filter_cache ? newSV(0) : NULL;
4338 if (fc) sv_copypv(fc, filter_cache);
4339 datasv = filter_add(S_run_user_filter, fc);
4340 IoLINES(datasv) = filter_has_file;
4341 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4342 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4345 /* switch to eval mode */
4347 cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4348 cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4350 SAVECOPLINE(&PL_compiling);
4351 CopLINE_set(&PL_compiling, 0);
4355 if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4358 op = PL_op->op_next;
4360 PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4366 /* also used for: pp_dofile() */
4370 RUN_PP_CATCHABLY(Perl_pp_require);
4377 return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4378 ? S_require_version(aTHX_ sv)
4379 : S_require_file(aTHX_ sv);
4384 /* This is a op added to hold the hints hash for
4385 pp_entereval. The hash can be modified by the code
4386 being eval'ed, so we return a copy instead. */
4391 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4403 char tbuf[TYPE_DIGITS(long) + 12];
4411 I32 old_savestack_ix;
4413 RUN_PP_CATCHABLY(Perl_pp_entereval);
4416 was = PL_breakable_sub_gen;
4417 saved_delete = FALSE;
4421 bytes = PL_op->op_private & OPpEVAL_BYTES;
4423 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4424 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4426 else if (PL_hints & HINT_LOCALIZE_HH || (
4427 PL_op->op_private & OPpEVAL_COPHH
4428 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4430 saved_hh = cop_hints_2hv(PL_curcop, 0);
4431 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4435 /* make sure we've got a plain PV (no overload etc) before testing
4436 * for taint. Making a copy here is probably overkill, but better
4437 * safe than sorry */
4439 const char * const p = SvPV_const(sv, len);
4441 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4442 lex_flags |= LEX_START_COPIED;
4444 if (bytes && SvUTF8(sv))
4445 SvPVbyte_force(sv, len);
4447 else if (bytes && SvUTF8(sv)) {
4448 /* Don't modify someone else's scalar */
4451 (void)sv_2mortal(sv);
4452 SvPVbyte_force(sv,len);
4453 lex_flags |= LEX_START_COPIED;
4456 TAINT_IF(SvTAINTED(sv));
4457 TAINT_PROPER("eval");
4459 old_savestack_ix = PL_savestack_ix;
4461 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4462 ? LEX_IGNORE_UTF8_HINTS
4463 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4467 /* switch to eval mode */
4469 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4470 SV * const temp_sv = sv_newmortal();
4471 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]",
4472 (unsigned long)++PL_evalseq,
4473 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4474 tmpbuf = SvPVX(temp_sv);
4475 len = SvCUR(temp_sv);
4478 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4479 SAVECOPFILE_FREE(&PL_compiling);
4480 CopFILE_set(&PL_compiling, tmpbuf+2);
4481 SAVECOPLINE(&PL_compiling);
4482 CopLINE_set(&PL_compiling, 1);
4483 /* special case: an eval '' executed within the DB package gets lexically
4484 * placed in the first non-DB CV rather than the current CV - this
4485 * allows the debugger to execute code, find lexicals etc, in the
4486 * scope of the code being debugged. Passing &seq gets find_runcv
4487 * to do the dirty work for us */
4488 runcv = find_runcv(&seq);
4491 cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
4492 cx_pusheval(cx, PL_op->op_next, NULL);
4494 /* prepare to compile string */
4496 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4497 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4499 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4500 deleting the eval's FILEGV from the stash before gv_check() runs
4501 (i.e. before run-time proper). To work around the coredump that
4502 ensues, we always turn GvMULTI_on for any globals that were
4503 introduced within evals. See force_ident(). GSAR 96-10-12 */
4504 char *const safestr = savepvn(tmpbuf, len);
4505 SAVEDELETE(PL_defstash, safestr, len);
4506 saved_delete = TRUE;
4511 if (doeval_compile(gimme, runcv, seq, saved_hh)) {
4512 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4513 ? PERLDB_LINE_OR_SAVESRC
4514 : PERLDB_SAVESRC_NOSUBS) {
4515 /* Retain the filegv we created. */
4516 } else if (!saved_delete) {
4517 char *const safestr = savepvn(tmpbuf, len);
4518 SAVEDELETE(PL_defstash, safestr, len);
4520 return PL_eval_start;
4522 /* We have already left the scope set up earlier thanks to the LEAVE
4523 in doeval_compile(). */
4524 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4525 ? PERLDB_LINE_OR_SAVESRC
4526 : PERLDB_SAVESRC_INVALID) {
4527 /* Retain the filegv we created. */
4528 } else if (!saved_delete) {
4529 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4531 return PL_op->op_next;
4536 /* also tail-called by pp_return */
4551 assert(CxTYPE(cx) == CXt_EVAL);
4553 oldsp = PL_stack_base + cx->blk_oldsp;
4554 gimme = cx->blk_gimme;
4556 /* did require return a false value? */
4557 failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE
4558 && !(gimme == G_SCALAR
4559 ? SvTRUE_NN(*PL_stack_sp)
4560 : PL_stack_sp > oldsp);
4562 if (gimme == G_VOID) {
4563 PL_stack_sp = oldsp;
4564 /* free now to avoid late-called destructors clobbering $@ */
4568 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4570 /* the cx_popeval does a leavescope, which frees the optree associated
4571 * with eval, which if it frees the nextstate associated with
4572 * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
4573 * regex when running under 'use re Debug' because it needs PL_curcop
4574 * to get the current hints. So restore it early.
4576 PL_curcop = cx->blk_oldcop;
4578 /* grab this value before cx_popeval restores the old PL_in_eval */
4579 keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4580 retop = cx->blk_eval.retop;
4581 evalcv = cx->blk_eval.cv;
4583 assert(CvDEPTH(evalcv) == 1);
4585 CvDEPTH(evalcv) = 0;
4587 /* pop the CXt_EVAL, and if a require failed, croak */
4588 S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
4596 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4597 close to the related Perl_create_eval_scope. */
4599 Perl_delete_eval_scope(pTHX)
4610 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4611 also needed by Perl_fold_constants. */
4613 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
4616 const U8 gimme = GIMME_V;
4618 cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme,
4619 PL_stack_sp, PL_savestack_ix);
4620 cx_pusheval(cx, retop, NULL);
4622 PL_in_eval = EVAL_INEVAL;
4623 if (flags & G_KEEPERR)
4624 PL_in_eval |= EVAL_KEEPERR;
4627 if (flags & G_FAKINGEVAL) {
4628 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4634 RUN_PP_CATCHABLY(Perl_pp_entertry);
4637 create_eval_scope(cLOGOP->op_other->op_next, 0);
4638 return PL_op->op_next;
4642 /* also tail-called by pp_return */
4654 assert(CxTYPE(cx) == CXt_EVAL);
4655 oldsp = PL_stack_base + cx->blk_oldsp;
4656 gimme = cx->blk_gimme;
4658 if (gimme == G_VOID) {
4659 PL_stack_sp = oldsp;
4660 /* free now to avoid late-called destructors clobbering $@ */
4664 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4668 retop = cx->blk_eval.retop;
4679 const U8 gimme = GIMME_V;
4683 assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4684 GvSV(PL_defgv) = SvREFCNT_inc(newsv);
4686 cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
4687 cx_pushgiven(cx, origsv);
4697 PERL_UNUSED_CONTEXT;
4700 assert(CxTYPE(cx) == CXt_GIVEN);
4701 oldsp = PL_stack_base + cx->blk_oldsp;
4702 gimme = cx->blk_gimme;
4704 if (gimme == G_VOID)
4705 PL_stack_sp = oldsp;
4707 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4717 /* Helper routines used by pp_smartmatch */
4719 S_make_matcher(pTHX_ REGEXP *re)
4721 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4723 PERL_ARGS_ASSERT_MAKE_MATCHER;
4725 PM_SETRE(matcher, ReREFCNT_inc(re));
4727 SAVEFREEOP((OP *) matcher);
4728 ENTER_with_name("matcher"); SAVETMPS;
4734 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4739 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4741 PL_op = (OP *) matcher;
4744 (void) Perl_pp_match(aTHX);
4746 result = SvTRUEx(POPs);
4753 S_destroy_matcher(pTHX_ PMOP *matcher)
4755 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4756 PERL_UNUSED_ARG(matcher);
4759 LEAVE_with_name("matcher");
4762 /* Do a smart match */
4765 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4766 return do_smartmatch(NULL, NULL, 0);
4769 /* This version of do_smartmatch() implements the
4770 * table of smart matches that is found in perlsyn.
4773 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4777 bool object_on_left = FALSE;
4778 SV *e = TOPs; /* e is for 'expression' */
4779 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4781 /* Take care only to invoke mg_get() once for each argument.
4782 * Currently we do this by copying the SV if it's magical. */
4784 if (!copied && SvGMAGICAL(d))
4785 d = sv_mortalcopy(d);
4792 e = sv_mortalcopy(e);
4794 /* First of all, handle overload magic of the rightmost argument */
4797 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4798 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4800 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4807 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4810 SP -= 2; /* Pop the values */
4815 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4822 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4823 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4824 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4826 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4827 object_on_left = TRUE;
4830 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4832 if (object_on_left) {
4833 goto sm_any_sub; /* Treat objects like scalars */
4835 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4836 /* Test sub truth for each key */
4838 bool andedresults = TRUE;
4839 HV *hv = (HV*) SvRV(d);
4840 I32 numkeys = hv_iterinit(hv);
4841 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4844 while ( (he = hv_iternext(hv)) ) {
4845 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4846 ENTER_with_name("smartmatch_hash_key_test");
4849 PUSHs(hv_iterkeysv(he));
4851 c = call_sv(e, G_SCALAR);
4854 andedresults = FALSE;
4856 andedresults = SvTRUEx(POPs) && andedresults;
4858 LEAVE_with_name("smartmatch_hash_key_test");
4865 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4866 /* Test sub truth for each element */
4868 bool andedresults = TRUE;
4869 AV *av = (AV*) SvRV(d);
4870 const Size_t len = av_count(av);
4871 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4874 for (i = 0; i < len; ++i) {
4875 SV * const * const svp = av_fetch(av, i, FALSE);
4876 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4877 ENTER_with_name("smartmatch_array_elem_test");
4883 c = call_sv(e, G_SCALAR);
4886 andedresults = FALSE;
4888 andedresults = SvTRUEx(POPs) && andedresults;
4890 LEAVE_with_name("smartmatch_array_elem_test");
4899 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4900 ENTER_with_name("smartmatch_coderef");
4905 c = call_sv(e, G_SCALAR);
4909 else if (SvTEMP(TOPs))
4910 SvREFCNT_inc_void(TOPs);
4912 LEAVE_with_name("smartmatch_coderef");
4917 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4918 if (object_on_left) {
4919 goto sm_any_hash; /* Treat objects like scalars */
4921 else if (!SvOK(d)) {
4922 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4925 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4926 /* Check that the key-sets are identical */
4928 HV *other_hv = MUTABLE_HV(SvRV(d));
4931 U32 this_key_count = 0,
4932 other_key_count = 0;
4933 HV *hv = MUTABLE_HV(SvRV(e));
4935 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4936 /* Tied hashes don't know how many keys they have. */
4937 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4938 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4942 HV * const temp = other_hv;
4948 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4952 /* The hashes have the same number of keys, so it suffices
4953 to check that one is a subset of the other. */
4954 (void) hv_iterinit(hv);
4955 while ( (he = hv_iternext(hv)) ) {
4956 SV *key = hv_iterkeysv(he);
4958 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4961 if(!hv_exists_ent(other_hv, key, 0)) {
4962 (void) hv_iterinit(hv); /* reset iterator */
4968 (void) hv_iterinit(other_hv);
4969 while ( hv_iternext(other_hv) )
4973 other_key_count = HvUSEDKEYS(other_hv);
4975 if (this_key_count != other_key_count)
4980 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4981 AV * const other_av = MUTABLE_AV(SvRV(d));
4982 const Size_t other_len = av_count(other_av);
4984 HV *hv = MUTABLE_HV(SvRV(e));
4986 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4987 for (i = 0; i < other_len; ++i) {
4988 SV ** const svp = av_fetch(other_av, i, FALSE);
4989 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4990 if (svp) { /* ??? When can this not happen? */
4991 if (hv_exists_ent(hv, *svp, 0))
4997 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4998 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
5001 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
5003 HV *hv = MUTABLE_HV(SvRV(e));
5005 (void) hv_iterinit(hv);
5006 while ( (he = hv_iternext(hv)) ) {
5007 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
5009 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
5011 (void) hv_iterinit(hv);
5012 destroy_matcher(matcher);
5017 destroy_matcher(matcher);
5023 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
5024 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
5031 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
5032 if (object_on_left) {
5033 goto sm_any_array; /* Treat objects like scalars */
5035 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5036 AV * const other_av = MUTABLE_AV(SvRV(e));
5037 const Size_t other_len = av_count(other_av);
5040 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
5041 for (i = 0; i < other_len; ++i) {
5042 SV ** const svp = av_fetch(other_av, i, FALSE);
5044 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
5045 if (svp) { /* ??? When can this not happen? */
5046 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
5052 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5053 AV *other_av = MUTABLE_AV(SvRV(d));
5054 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
5055 if (av_count(MUTABLE_AV(SvRV(e))) != av_count(other_av))
5059 const Size_t other_len = av_count(other_av);
5061 if (NULL == seen_this) {
5062 seen_this = newHV();
5063 (void) sv_2mortal(MUTABLE_SV(seen_this));
5065 if (NULL == seen_other) {
5066 seen_other = newHV();
5067 (void) sv_2mortal(MUTABLE_SV(seen_other));
5069 for(i = 0; i < other_len; ++i) {
5070 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5071 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
5073 if (!this_elem || !other_elem) {
5074 if ((this_elem && SvOK(*this_elem))
5075 || (other_elem && SvOK(*other_elem)))
5078 else if (hv_exists_ent(seen_this,
5079 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
5080 hv_exists_ent(seen_other,
5081 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
5083 if (*this_elem != *other_elem)
5087 (void)hv_store_ent(seen_this,
5088 sv_2mortal(newSViv(PTR2IV(*this_elem))),
5090 (void)hv_store_ent(seen_other,
5091 sv_2mortal(newSViv(PTR2IV(*other_elem))),
5097 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
5098 (void) do_smartmatch(seen_this, seen_other, 0);
5100 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
5109 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
5110 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
5113 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
5114 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
5117 for(i = 0; i < this_len; ++i) {
5118 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5119 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
5121 if (svp && matcher_matches_sv(matcher, *svp)) {
5123 destroy_matcher(matcher);
5128 destroy_matcher(matcher);
5132 else if (!SvOK(d)) {
5133 /* undef ~~ array */
5134 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
5137 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
5138 for (i = 0; i < this_len; ++i) {
5139 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5140 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
5141 if (!svp || !SvOK(*svp))
5150 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
5152 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
5153 for (i = 0; i < this_len; ++i) {
5154 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5161 /* infinite recursion isn't supposed to happen here */
5162 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
5163 (void) do_smartmatch(NULL, NULL, 1);
5165 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
5174 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
5175 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5176 SV *t = d; d = e; e = t;
5177 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
5180 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5181 SV *t = d; d = e; e = t;
5182 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
5183 goto sm_regex_array;
5186 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
5189 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
5191 result = matcher_matches_sv(matcher, d);
5193 PUSHs(result ? &PL_sv_yes : &PL_sv_no);
5194 destroy_matcher(matcher);
5199 /* See if there is overload magic on left */
5200 else if (object_on_left && SvAMAGIC(d)) {
5202 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
5203 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
5206 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
5214 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
5217 else if (!SvOK(d)) {
5218 /* undef ~~ scalar ; we already know that the scalar is SvOK */
5219 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
5224 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
5225 DEBUG_M(if (SvNIOK(e))
5226 Perl_deb(aTHX_ " applying rule Any-Num\n");
5228 Perl_deb(aTHX_ " applying rule Num-numish\n");
5230 /* numeric comparison */
5233 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
5234 (void) Perl_pp_i_eq(aTHX);
5236 (void) Perl_pp_eq(aTHX);
5244 /* As a last resort, use string comparison */
5245 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
5248 return Perl_pp_seq(aTHX);
5255 const U8 gimme = GIMME_V;
5257 /* This is essentially an optimization: if the match
5258 fails, we don't want to push a context and then
5259 pop it again right away, so we skip straight
5260 to the op that follows the leavewhen.
5261 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5263 if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) {
5264 if (gimme == G_SCALAR)
5265 PUSHs(&PL_sv_undef);
5266 RETURNOP(cLOGOP->op_other->op_next);
5269 cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
5283 assert(CxTYPE(cx) == CXt_WHEN);
5284 gimme = cx->blk_gimme;
5286 cxix = dopoptogivenfor(cxstack_ix);
5288 /* diag_listed_as: Can't "when" outside a topicalizer */
5289 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5290 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5292 oldsp = PL_stack_base + cx->blk_oldsp;
5293 if (gimme == G_VOID)
5294 PL_stack_sp = oldsp;
5296 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5298 /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
5299 assert(cxix < cxstack_ix);
5302 cx = &cxstack[cxix];
5304 if (CxFOREACH(cx)) {
5305 /* emulate pp_next. Note that any stack(s) cleanup will be
5306 * done by the pp_unstack which op_nextop should point to */
5309 PL_curcop = cx->blk_oldcop;
5310 return cx->blk_loop.my_op->op_nextop;
5314 assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
5315 return cx->blk_givwhen.leave_op;
5325 cxix = dopoptowhen(cxstack_ix);
5327 DIE(aTHX_ "Can't \"continue\" outside a when block");
5329 if (cxix < cxstack_ix)
5333 assert(CxTYPE(cx) == CXt_WHEN);
5334 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5338 nextop = cx->blk_givwhen.leave_op->op_next;
5349 cxix = dopoptogivenfor(cxstack_ix);
5351 DIE(aTHX_ "Can't \"break\" outside a given block");
5353 cx = &cxstack[cxix];
5355 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5357 if (cxix < cxstack_ix)
5360 /* Restore the sp at the time we entered the given block */
5362 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5364 return cx->blk_givwhen.leave_op;
5368 S_doparseform(pTHX_ SV *sv)
5371 char *s = SvPV(sv, len);
5373 char *base = NULL; /* start of current field */
5374 I32 skipspaces = 0; /* number of contiguous spaces seen */
5375 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5376 bool repeat = FALSE; /* ~~ seen on this line */
5377 bool postspace = FALSE; /* a text field may need right padding */
5380 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5382 bool ischop; /* it's a ^ rather than a @ */
5383 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5384 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5388 PERL_ARGS_ASSERT_DOPARSEFORM;
5391 Perl_croak(aTHX_ "Null picture in formline");
5393 if (SvTYPE(sv) >= SVt_PVMG) {
5394 /* This might, of course, still return NULL. */
5395 mg = mg_find(sv, PERL_MAGIC_fm);
5397 sv_upgrade(sv, SVt_PVMG);
5401 /* still the same as previously-compiled string? */
5402 SV *old = mg->mg_obj;
5403 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5404 && len == SvCUR(old)
5405 && strnEQ(SvPVX(old), s, len)
5407 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5411 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5412 Safefree(mg->mg_ptr);
5418 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5419 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5422 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5423 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5427 /* estimate the buffer size needed */
5428 for (base = s; s <= send; s++) {
5429 if (*s == '\n' || *s == '@' || *s == '^')
5435 Newx(fops, maxops, U32);
5440 *fpc++ = FF_LINEMARK;
5441 noblank = repeat = FALSE;
5459 case ' ': case '\t':
5475 *fpc++ = FF_LITERAL;
5483 *fpc++ = (U32)skipspaces;
5487 *fpc++ = FF_NEWLINE;
5491 arg = fpc - linepc + 1;
5498 *fpc++ = FF_LINEMARK;
5499 noblank = repeat = FALSE;
5508 ischop = s[-1] == '^';
5514 arg = (s - base) - 1;
5516 *fpc++ = FF_LITERAL;
5522 if (*s == '*') { /* @* or ^* */
5524 *fpc++ = 2; /* skip the @* or ^* */
5526 *fpc++ = FF_LINESNGL;
5529 *fpc++ = FF_LINEGLOB;
5531 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5532 arg = ischop ? FORM_NUM_BLANK : 0;
5537 const char * const f = ++s;
5540 arg |= FORM_NUM_POINT + (s - f);
5542 *fpc++ = s - base; /* fieldsize for FETCH */
5543 *fpc++ = FF_DECIMAL;
5545 unchopnum |= ! ischop;
5547 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5548 arg = ischop ? FORM_NUM_BLANK : 0;
5550 s++; /* skip the '0' first */
5554 const char * const f = ++s;
5557 arg |= FORM_NUM_POINT + (s - f);
5559 *fpc++ = s - base; /* fieldsize for FETCH */
5560 *fpc++ = FF_0DECIMAL;
5562 unchopnum |= ! ischop;
5564 else { /* text field */
5566 bool ismore = FALSE;
5569 while (*++s == '>') ;
5570 prespace = FF_SPACE;
5572 else if (*s == '|') {
5573 while (*++s == '|') ;
5574 prespace = FF_HALFSPACE;
5579 while (*++s == '<') ;
5582 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5586 *fpc++ = s - base; /* fieldsize for FETCH */
5588 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5591 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5605 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5608 mg->mg_ptr = (char *) fops;
5609 mg->mg_len = arg * sizeof(U32);
5610 mg->mg_obj = sv_copy;
5611 mg->mg_flags |= MGf_REFCOUNTED;
5613 if (unchopnum && repeat)
5614 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5621 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5623 /* Can value be printed in fldsize chars, using %*.*f ? */
5627 int intsize = fldsize - (value < 0 ? 1 : 0);
5629 if (frcsize & FORM_NUM_POINT)
5631 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5634 while (intsize--) pwr *= 10.0;
5635 while (frcsize--) eps /= 10.0;
5638 if (value + eps >= pwr)
5641 if (value - eps <= -pwr)
5648 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5650 SV * const datasv = FILTER_DATA(idx);
5651 const int filter_has_file = IoLINES(datasv);
5652 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5653 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5658 char *prune_from = NULL;
5659 bool read_from_cache = FALSE;
5663 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5665 assert(maxlen >= 0);
5668 /* I was having segfault trouble under Linux 2.2.5 after a
5669 parse error occurred. (Had to hack around it with a test
5670 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5671 not sure where the trouble is yet. XXX */
5674 SV *const cache = datasv;
5677 const char *cache_p = SvPV(cache, cache_len);
5681 /* Running in block mode and we have some cached data already.
5683 if (cache_len >= umaxlen) {
5684 /* In fact, so much data we don't even need to call
5689 const char *const first_nl =
5690 (const char *)memchr(cache_p, '\n', cache_len);
5692 take = first_nl + 1 - cache_p;
5696 sv_catpvn(buf_sv, cache_p, take);
5697 sv_chop(cache, cache_p + take);
5698 /* Definitely not EOF */
5702 sv_catsv(buf_sv, cache);
5704 umaxlen -= cache_len;
5707 read_from_cache = TRUE;
5711 /* Filter API says that the filter appends to the contents of the buffer.
5712 Usually the buffer is "", so the details don't matter. But if it's not,
5713 then clearly what it contains is already filtered by this filter, so we
5714 don't want to pass it in a second time.
5715 I'm going to use a mortal in case the upstream filter croaks. */
5716 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5717 ? sv_newmortal() : buf_sv;
5718 SvUPGRADE(upstream, SVt_PV);
5720 if (filter_has_file) {
5721 status = FILTER_READ(idx+1, upstream, 0);
5724 if (filter_sub && status >= 0) {
5728 ENTER_with_name("call_filter_sub");
5733 DEFSV_set(upstream);
5737 PUSHs(filter_state);
5740 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5750 SV * const errsv = ERRSV;
5751 if (SvTRUE_NN(errsv))
5752 err = newSVsv(errsv);
5758 LEAVE_with_name("call_filter_sub");
5761 if (SvGMAGICAL(upstream)) {
5763 if (upstream == buf_sv) mg_free(buf_sv);
5765 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5766 if(!err && SvOK(upstream)) {
5767 got_p = SvPV_nomg(upstream, got_len);
5769 if (got_len > umaxlen) {
5770 prune_from = got_p + umaxlen;
5773 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5774 if (first_nl && first_nl + 1 < got_p + got_len) {
5775 /* There's a second line here... */
5776 prune_from = first_nl + 1;
5780 if (!err && prune_from) {
5781 /* Oh. Too long. Stuff some in our cache. */
5782 STRLEN cached_len = got_p + got_len - prune_from;
5783 SV *const cache = datasv;
5786 /* Cache should be empty. */
5787 assert(!SvCUR(cache));
5790 sv_setpvn(cache, prune_from, cached_len);
5791 /* If you ask for block mode, you may well split UTF-8 characters.
5792 "If it breaks, you get to keep both parts"
5793 (Your code is broken if you don't put them back together again
5794 before something notices.) */
5795 if (SvUTF8(upstream)) {
5798 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5800 /* Cannot just use sv_setpvn, as that could free the buffer
5801 before we have a chance to assign it. */
5802 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5803 got_len - cached_len);
5805 /* Can't yet be EOF */
5810 /* If they are at EOF but buf_sv has something in it, then they may never
5811 have touched the SV upstream, so it may be undefined. If we naively
5812 concatenate it then we get a warning about use of uninitialised value.
5814 if (!err && upstream != buf_sv &&
5816 sv_catsv_nomg(buf_sv, upstream);
5818 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5821 IoLINES(datasv) = 0;
5823 SvREFCNT_dec(filter_state);
5824 IoTOP_GV(datasv) = NULL;
5827 SvREFCNT_dec(filter_sub);
5828 IoBOTTOM_GV(datasv) = NULL;
5830 filter_del(S_run_user_filter);
5836 if (status == 0 && read_from_cache) {
5837 /* If we read some data from the cache (and by getting here it implies
5838 that we emptied the cache) then we aren't yet at EOF, and mustn't
5839 report that to our caller. */
5846 * ex: set ts=8 sts=4 sw=4 et: