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;
1005 /* pp_grepwhile() lives in pp_hot.c */
1010 const U8 gimme = GIMME_V;
1011 I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
1017 /* first, move source pointer to the next item in the source list */
1018 ++PL_markstack_ptr[-1];
1020 /* if there are new items, push them into the destination list */
1021 if (items && gimme != G_VOID) {
1022 /* might need to make room back there first */
1023 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1024 /* XXX this implementation is very pessimal because the stack
1025 * is repeatedly extended for every set of items. Is possible
1026 * to do this without any stack extension or copying at all
1027 * by maintaining a separate list over which the map iterates
1028 * (like foreach does). --gsar */
1030 /* everything in the stack after the destination list moves
1031 * towards the end the stack by the amount of room needed */
1032 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1034 /* items to shift up (accounting for the moved source pointer) */
1035 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1037 /* This optimization is by Ben Tilly and it does
1038 * things differently from what Sarathy (gsar)
1039 * is describing. The downside of this optimization is
1040 * that leaves "holes" (uninitialized and hopefully unused areas)
1041 * to the Perl stack, but on the other hand this
1042 * shouldn't be a problem. If Sarathy's idea gets
1043 * implemented, this optimization should become
1044 * irrelevant. --jhi */
1046 shift = count; /* Avoid shifting too often --Ben Tilly */
1050 dst = (SP += shift);
1051 PL_markstack_ptr[-1] += shift;
1052 *PL_markstack_ptr += shift;
1056 /* copy the new items down to the destination list */
1057 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1058 if (gimme == G_LIST) {
1059 /* add returned items to the collection (making mortal copies
1060 * if necessary), then clear the current temps stack frame
1061 * *except* for those items. We do this splicing the items
1062 * into the start of the tmps frame (so some items may be on
1063 * the tmps stack twice), then moving PL_tmps_floor above
1064 * them, then freeing the frame. That way, the only tmps that
1065 * accumulate over iterations are the return values for map.
1066 * We have to do to this way so that everything gets correctly
1067 * freed if we die during the map.
1071 /* make space for the slice */
1072 EXTEND_MORTAL(items);
1073 tmpsbase = PL_tmps_floor + 1;
1074 Move(PL_tmps_stack + tmpsbase,
1075 PL_tmps_stack + tmpsbase + items,
1076 PL_tmps_ix - PL_tmps_floor,
1078 PL_tmps_ix += items;
1083 sv = sv_mortalcopy(sv);
1085 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1087 /* clear the stack frame except for the items */
1088 PL_tmps_floor += items;
1090 /* FREETMPS may have cleared the TEMP flag on some of the items */
1093 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1096 /* scalar context: we don't care about which values map returns
1097 * (we use undef here). And so we certainly don't want to do mortal
1098 * copies of meaningless values. */
1099 while (items-- > 0) {
1101 *dst-- = &PL_sv_undef;
1109 LEAVE_with_name("grep_item"); /* exit inner scope */
1112 if (PL_markstack_ptr[-1] > TOPMARK) {
1114 (void)POPMARK; /* pop top */
1115 LEAVE_with_name("grep"); /* exit outer scope */
1116 (void)POPMARK; /* pop src */
1117 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1118 (void)POPMARK; /* pop dst */
1119 SP = PL_stack_base + POPMARK; /* pop original mark */
1120 if (gimme == G_SCALAR) {
1124 else if (gimme == G_LIST)
1131 ENTER_with_name("grep_item"); /* enter inner scope */
1134 /* set $_ to the new source item */
1135 src = PL_stack_base[PL_markstack_ptr[-1]];
1136 if (SvPADTMP(src)) {
1137 src = sv_mortalcopy(src);
1142 RETURNOP(cLOGOP->op_other);
1151 if (GIMME_V == G_LIST)
1154 if (SvTRUE_NN(targ))
1155 return cLOGOP->op_other;
1164 if (GIMME_V == G_LIST) {
1165 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1169 SV * const targ = PAD_SV(PL_op->op_targ);
1172 if (PL_op->op_private & OPpFLIP_LINENUM) {
1173 if (GvIO(PL_last_in_gv)) {
1174 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1177 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1179 flip = SvIV(sv) == SvIV(GvSV(gv));
1182 flip = SvTRUE_NN(sv);
1185 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1186 if (PL_op->op_flags & OPf_SPECIAL) {
1194 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1203 /* This code tries to decide if "$left .. $right" should use the
1204 magical string increment, or if the range is numeric. Initially,
1205 an exception was made for *any* string beginning with "0" (see
1206 [#18165], AMS 20021031), but now that is only applied when the
1207 string's length is also >1 - see the rules now documented in
1210 #define RANGE_IS_NUMERIC(left,right) ( \
1211 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1212 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1213 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1214 looks_like_number(left)) && SvPOKp(left) \
1215 && !(*SvPVX_const(left) == '0' && SvCUR(left)>1 ) )) \
1216 && (!SvOK(right) || looks_like_number(right))))
1222 if (GIMME_V == G_LIST) {
1228 if (RANGE_IS_NUMERIC(left,right)) {
1230 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1231 (SvOK(right) && (SvIOK(right)
1232 ? SvIsUV(right) && SvUV(right) > IV_MAX
1233 : SvNV_nomg(right) > (NV) IV_MAX)))
1234 DIE(aTHX_ "Range iterator outside integer range");
1235 i = SvIV_nomg(left);
1236 j = SvIV_nomg(right);
1238 /* Dance carefully around signed max. */
1239 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1242 /* The wraparound of signed integers is undefined
1243 * behavior, but here we aim for count >=1, and
1244 * negative count is just wrong. */
1246 #if IVSIZE > Size_t_size
1253 Perl_croak(aTHX_ "Out of memory during list extend");
1260 SV * const sv = sv_2mortal(newSViv(i));
1262 if (n) /* avoid incrementing above IV_MAX */
1268 const char * const lpv = SvPV_nomg_const(left, llen);
1269 const char * const tmps = SvPV_nomg_const(right, len);
1271 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1272 if (DO_UTF8(right) && IN_UNI_8_BIT)
1273 len = sv_len_utf8_nomg(right);
1274 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1276 if (strEQ(SvPVX_const(sv),tmps))
1278 sv = sv_2mortal(newSVsv(sv));
1285 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1289 if (PL_op->op_private & OPpFLIP_LINENUM) {
1290 if (GvIO(PL_last_in_gv)) {
1291 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1294 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1295 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1299 flop = SvTRUE_NN(sv);
1303 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1304 sv_catpvs(targ, "E0");
1314 static const char * const context_name[] = {
1316 NULL, /* CXt_WHEN never actually needs "block" */
1317 NULL, /* CXt_BLOCK never actually needs "block" */
1318 NULL, /* CXt_GIVEN never actually needs "block" */
1319 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1320 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1321 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1322 NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1323 NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1332 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1336 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1338 for (i = cxstack_ix; i >= 0; i--) {
1339 const PERL_CONTEXT * const cx = &cxstack[i];
1340 switch (CxTYPE(cx)) {
1349 /* diag_listed_as: Exiting subroutine via %s */
1350 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1351 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1352 if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1355 case CXt_LOOP_PLAIN:
1356 case CXt_LOOP_LAZYIV:
1357 case CXt_LOOP_LAZYSV:
1361 STRLEN cx_label_len = 0;
1362 U32 cx_label_flags = 0;
1363 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1365 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1368 (const U8*)cx_label, cx_label_len,
1369 (const U8*)label, len) == 0)
1371 (const U8*)label, len,
1372 (const U8*)cx_label, cx_label_len) == 0)
1373 : (len == cx_label_len && ((cx_label == label)
1374 || memEQ(cx_label, label, len))) )) {
1375 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1376 (long)i, cx_label));
1379 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1390 Perl_dowantarray(pTHX)
1392 const U8 gimme = block_gimme();
1393 return (gimme == G_VOID) ? G_SCALAR : gimme;
1396 /* note that this function has mostly been superseded by Perl_gimme_V */
1399 Perl_block_gimme(pTHX)
1401 const I32 cxix = dopopto_cursub();
1406 gimme = (cxstack[cxix].blk_gimme & G_WANT);
1408 Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1414 Perl_is_lvalue_sub(pTHX)
1416 const I32 cxix = dopopto_cursub();
1417 assert(cxix >= 0); /* We should only be called from inside subs */
1419 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1420 return CxLVAL(cxstack + cxix);
1425 /* only used by cx_pushsub() */
1427 Perl_was_lvalue_sub(pTHX)
1429 const I32 cxix = dopoptosub(cxstack_ix-1);
1430 assert(cxix >= 0); /* We should only be called from inside subs */
1432 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1433 return CxLVAL(cxstack + cxix);
1439 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1443 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1445 PERL_UNUSED_CONTEXT;
1448 for (i = startingblock; i >= 0; i--) {
1449 const PERL_CONTEXT * const cx = &cxstk[i];
1450 switch (CxTYPE(cx)) {
1454 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1455 * twice; the first for the normal foo() call, and the second
1456 * for a faked up re-entry into the sub to execute the
1457 * code block. Hide this faked entry from the world. */
1458 if (cx->cx_type & CXp_SUB_RE_FAKE)
1460 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1466 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1470 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1478 S_dopoptoeval(pTHX_ I32 startingblock)
1481 for (i = startingblock; i >= 0; i--) {
1482 const PERL_CONTEXT *cx = &cxstack[i];
1483 switch (CxTYPE(cx)) {
1487 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1495 S_dopoptoloop(pTHX_ I32 startingblock)
1498 for (i = startingblock; i >= 0; i--) {
1499 const PERL_CONTEXT * const cx = &cxstack[i];
1500 switch (CxTYPE(cx)) {
1509 /* diag_listed_as: Exiting subroutine via %s */
1510 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1511 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1512 if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1515 case CXt_LOOP_PLAIN:
1516 case CXt_LOOP_LAZYIV:
1517 case CXt_LOOP_LAZYSV:
1520 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1527 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1530 S_dopoptogivenfor(pTHX_ I32 startingblock)
1533 for (i = startingblock; i >= 0; i--) {
1534 const PERL_CONTEXT *cx = &cxstack[i];
1535 switch (CxTYPE(cx)) {
1539 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1541 case CXt_LOOP_PLAIN:
1542 assert(!(cx->cx_type & CXp_FOR_DEF));
1544 case CXt_LOOP_LAZYIV:
1545 case CXt_LOOP_LAZYSV:
1548 if (cx->cx_type & CXp_FOR_DEF) {
1549 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1558 S_dopoptowhen(pTHX_ I32 startingblock)
1561 for (i = startingblock; i >= 0; i--) {
1562 const PERL_CONTEXT *cx = &cxstack[i];
1563 switch (CxTYPE(cx)) {
1567 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1574 /* dounwind(): pop all contexts above (but not including) cxix.
1575 * Note that it clears the savestack frame associated with each popped
1576 * context entry, but doesn't free any temps.
1577 * It does a cx_popblock() of the last frame that it pops, and leaves
1578 * cxstack_ix equal to cxix.
1582 Perl_dounwind(pTHX_ I32 cxix)
1584 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1587 while (cxstack_ix > cxix) {
1588 PERL_CONTEXT *cx = CX_CUR();
1590 CX_DEBUG(cx, "UNWIND");
1591 /* Note: we don't need to restore the base context info till the end. */
1595 switch (CxTYPE(cx)) {
1598 /* CXt_SUBST is not a block context type, so skip the
1599 * cx_popblock(cx) below */
1600 if (cxstack_ix == cxix + 1) {
1611 case CXt_LOOP_PLAIN:
1612 case CXt_LOOP_LAZYIV:
1613 case CXt_LOOP_LAZYSV:
1627 /* these two don't have a POPFOO() */
1633 if (cxstack_ix == cxix + 1) {
1642 Perl_qerror(pTHX_ SV *err)
1644 PERL_ARGS_ASSERT_QERROR;
1647 if (PL_in_eval & EVAL_KEEPERR) {
1648 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1652 sv_catsv(ERRSV, err);
1655 sv_catsv(PL_errors, err);
1657 Perl_warn(aTHX_ "%" SVf, SVfARG(err));
1659 ++PL_parser->error_count;
1664 /* pop a CXt_EVAL context and in addition, if it was a require then
1666 * 0: do nothing extra;
1667 * 1: undef $INC{$name}; croak "$name did not return a true value";
1668 * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1672 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1674 SV *namesv = NULL; /* init to avoid dumb compiler warning */
1678 do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1680 /* keep namesv alive after cx_popeval() */
1681 namesv = cx->blk_eval.old_namesv;
1682 cx->blk_eval.old_namesv = NULL;
1691 HV *inc_hv = GvHVn(PL_incgv);
1694 (void)hv_delete_ent(inc_hv, namesv, G_DISCARD, 0);
1695 fmt = "%" SVf " did not return a true value";
1699 (void)hv_store_ent(inc_hv, namesv, &PL_sv_undef, 0);
1700 fmt = "%" SVf "Compilation failed in require";
1702 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1705 Perl_croak(aTHX_ fmt, SVfARG(errsv));
1710 /* die_unwind(): this is the final destination for the various croak()
1711 * functions. If we're in an eval, unwind the context and other stacks
1712 * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1713 * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1714 * to is a require the exception will be rethrown, as requires don't
1715 * actually trap exceptions.
1719 Perl_die_unwind(pTHX_ SV *msv)
1722 U8 in_eval = PL_in_eval;
1723 PERL_ARGS_ASSERT_DIE_UNWIND;
1728 /* We need to keep this SV alive through all the stack unwinding
1729 * and FREETMPSing below, while ensuing that it doesn't leak
1730 * if we call out to something which then dies (e.g. sub STORE{die}
1731 * when unlocalising a tied var). So we do a dance with
1732 * mortalising and SAVEFREEing.
1734 if (PL_phase == PERL_PHASE_DESTRUCT) {
1735 exceptsv = sv_mortalcopy(exceptsv);
1737 exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1741 * Historically, perl used to set ERRSV ($@) early in the die
1742 * process and rely on it not getting clobbered during unwinding.
1743 * That sucked, because it was liable to get clobbered, so the
1744 * setting of ERRSV used to emit the exception from eval{} has
1745 * been moved to much later, after unwinding (see just before
1746 * JMPENV_JUMP below). However, some modules were relying on the
1747 * early setting, by examining $@ during unwinding to use it as
1748 * a flag indicating whether the current unwinding was caused by
1749 * an exception. It was never a reliable flag for that purpose,
1750 * being totally open to false positives even without actual
1751 * clobberage, but was useful enough for production code to
1752 * semantically rely on it.
1754 * We'd like to have a proper introspective interface that
1755 * explicitly describes the reason for whatever unwinding
1756 * operations are currently in progress, so that those modules
1757 * work reliably and $@ isn't further overloaded. But we don't
1758 * have one yet. In its absence, as a stopgap measure, ERRSV is
1759 * now *additionally* set here, before unwinding, to serve as the
1760 * (unreliable) flag that it used to.
1762 * This behaviour is temporary, and should be removed when a
1763 * proper way to detect exceptional unwinding has been developed.
1764 * As of 2010-12, the authors of modules relying on the hack
1765 * are aware of the issue, because the modules failed on
1766 * perls 5.13.{1..7} which had late setting of $@ without this
1767 * early-setting hack.
1769 if (!(in_eval & EVAL_KEEPERR)) {
1770 /* remove any read-only/magic from the SV, so we don't
1771 get infinite recursion when setting ERRSV */
1773 sv_setsv_flags(ERRSV, exceptsv,
1774 (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
1777 if (in_eval & EVAL_KEEPERR) {
1778 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1782 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1783 && PL_curstackinfo->si_prev)
1793 JMPENV *restartjmpenv;
1796 if (cxix < cxstack_ix)
1800 assert(CxTYPE(cx) == CXt_EVAL);
1802 /* return false to the caller of eval */
1803 oldsp = PL_stack_base + cx->blk_oldsp;
1804 gimme = cx->blk_gimme;
1805 if (gimme == G_SCALAR)
1806 *++oldsp = &PL_sv_undef;
1807 PL_stack_sp = oldsp;
1809 restartjmpenv = cx->blk_eval.cur_top_env;
1810 restartop = cx->blk_eval.retop;
1812 /* We need a FREETMPS here to avoid late-called destructors
1813 * clobbering $@ *after* we set it below, e.g.
1814 * sub DESTROY { eval { die "X" } }
1815 * eval { my $x = bless []; die $x = 0, "Y" };
1817 * Here the clearing of the $x ref mortalises the anon array,
1818 * which needs to be freed *before* $& is set to "Y",
1819 * otherwise it gets overwritten with "X".
1821 * However, the FREETMPS will clobber exceptsv, so preserve it
1822 * on the savestack for now.
1824 SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv));
1826 /* now we're about to pop the savestack, so re-mortalise it */
1827 sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1829 /* Note that unlike pp_entereval, pp_require isn't supposed to
1830 * trap errors. So if we're a require, after we pop the
1831 * CXt_EVAL that pp_require pushed, rethrow the error with
1832 * croak(exceptsv). This is all handled by the call below when
1835 S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
1837 if (!(in_eval & EVAL_KEEPERR)) {
1839 sv_setsv(ERRSV, exceptsv);
1841 PL_restartjmpenv = restartjmpenv;
1842 PL_restartop = restartop;
1844 NOT_REACHED; /* NOTREACHED */
1848 write_to_stderr(exceptsv);
1850 NOT_REACHED; /* NOTREACHED */
1856 if (SvTRUE_NN(left) != SvTRUE_NN(right))
1864 =for apidoc_section $CV
1866 =for apidoc caller_cx
1868 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1869 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1870 information returned to Perl by C<caller>. Note that XSUBs don't get a
1871 stack frame, so C<caller_cx(0, NULL)> will return information for the
1872 immediately-surrounding Perl code.
1874 This function skips over the automatic calls to C<&DB::sub> made on the
1875 behalf of the debugger. If the stack frame requested was a sub called by
1876 C<DB::sub>, the return value will be the frame for the call to
1877 C<DB::sub>, since that has the correct line number/etc. for the call
1878 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1879 frame for the sub call itself.
1884 const PERL_CONTEXT *
1885 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1887 I32 cxix = dopopto_cursub();
1888 const PERL_CONTEXT *cx;
1889 const PERL_CONTEXT *ccstack = cxstack;
1890 const PERL_SI *top_si = PL_curstackinfo;
1893 /* we may be in a higher stacklevel, so dig down deeper */
1894 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1895 top_si = top_si->si_prev;
1896 ccstack = top_si->si_cxstack;
1897 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1901 /* caller() should not report the automatic calls to &DB::sub */
1902 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1903 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1907 cxix = dopoptosub_at(ccstack, cxix - 1);
1910 cx = &ccstack[cxix];
1911 if (dbcxp) *dbcxp = cx;
1913 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1914 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1915 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1916 field below is defined for any cx. */
1917 /* caller() should not report the automatic calls to &DB::sub */
1918 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1919 cx = &ccstack[dbcxix];
1928 const PERL_CONTEXT *cx;
1929 const PERL_CONTEXT *dbcx;
1931 const HEK *stash_hek;
1933 bool has_arg = MAXARG && TOPs;
1942 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1944 if (gimme != G_LIST) {
1951 CX_DEBUG(cx, "CALLER");
1952 assert(CopSTASH(cx->blk_oldcop));
1953 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1954 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1956 if (gimme != G_LIST) {
1959 PUSHs(&PL_sv_undef);
1962 sv_sethek(TARG, stash_hek);
1971 PUSHs(&PL_sv_undef);
1974 sv_sethek(TARG, stash_hek);
1977 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1978 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
1979 cx->blk_sub.retop, TRUE);
1981 lcop = cx->blk_oldcop;
1982 mPUSHu(CopLINE(lcop));
1985 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1986 /* So is ccstack[dbcxix]. */
1987 if (CvHASGV(dbcx->blk_sub.cv)) {
1988 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
1989 PUSHs(boolSV(CxHASARGS(cx)));
1992 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1993 PUSHs(boolSV(CxHASARGS(cx)));
1997 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
2000 gimme = cx->blk_gimme;
2001 if (gimme == G_VOID)
2002 PUSHs(&PL_sv_undef);
2004 PUSHs(boolSV((gimme & G_WANT) == G_LIST));
2005 if (CxTYPE(cx) == CXt_EVAL) {
2007 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
2008 SV *cur_text = cx->blk_eval.cur_text;
2009 if (SvCUR(cur_text) >= 2) {
2010 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
2011 SvUTF8(cur_text)|SVs_TEMP));
2014 /* I think this is will always be "", but be sure */
2015 PUSHs(sv_2mortal(newSVsv(cur_text)));
2021 else if (cx->blk_eval.old_namesv) {
2022 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
2025 /* eval BLOCK (try blocks have old_namesv == 0) */
2027 PUSHs(&PL_sv_undef);
2028 PUSHs(&PL_sv_undef);
2032 PUSHs(&PL_sv_undef);
2033 PUSHs(&PL_sv_undef);
2035 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
2036 && CopSTASH_eq(PL_curcop, PL_debstash))
2038 /* slot 0 of the pad contains the original @_ */
2039 AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
2040 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2041 cx->blk_sub.olddepth+1]))[0]);
2042 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
2044 Perl_init_dbargs(aTHX);
2046 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
2047 av_extend(PL_dbargs, AvFILLp(ary) + off);
2048 if (AvFILLp(ary) + 1 + off)
2049 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
2050 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
2052 mPUSHi(CopHINTS_get(cx->blk_oldcop));
2055 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
2057 if (old_warnings == pWARN_NONE)
2058 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
2059 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
2060 mask = &PL_sv_undef ;
2061 else if (old_warnings == pWARN_ALL ||
2062 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
2063 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
2066 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
2070 PUSHs(cx->blk_oldcop->cop_hints_hash ?
2071 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2081 if (MAXARG < 1 || (!TOPs && !POPs)) {
2083 tmps = NULL, len = 0;
2086 tmps = SvPVx_const(POPs, len);
2087 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
2092 /* like pp_nextstate, but used instead when the debugger is active */
2096 PL_curcop = (COP*)PL_op;
2097 TAINT_NOT; /* Each statement is presumed innocent */
2098 PL_stack_sp = PL_stack_base + CX_CUR()->blk_oldsp;
2103 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2104 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2108 const U8 gimme = G_LIST;
2109 GV * const gv = PL_DBgv;
2112 if (gv && isGV_with_GP(gv))
2115 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2116 DIE(aTHX_ "No DB::DB routine defined");
2118 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2119 /* don't do recursive DB::DB call */
2129 (void)(*CvXSUB(cv))(aTHX_ cv);
2135 cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix);
2136 cx_pushsub(cx, cv, PL_op->op_next, 0);
2137 /* OP_DBSTATE's op_private holds hint bits rather than
2138 * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2139 * any CxLVAL() flags that have now been mis-calculated */
2146 if (CvDEPTH(cv) >= 2)
2147 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2148 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2149 RETURNOP(CvSTART(cv));
2161 (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2173 assert(CxTYPE(cx) == CXt_BLOCK);
2175 if (PL_op->op_flags & OPf_SPECIAL)
2176 /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */
2177 cx->blk_oldpm = PL_curpm;
2179 oldsp = PL_stack_base + cx->blk_oldsp;
2180 gimme = cx->blk_gimme;
2182 if (gimme == G_VOID)
2183 PL_stack_sp = oldsp;
2185 leave_adjust_stacks(oldsp, oldsp, gimme,
2186 PL_op->op_private & OPpLVALUE ? 3 : 1);
2196 S_outside_integer(pTHX_ SV *sv)
2199 const NV nv = SvNV_nomg(sv);
2200 if (Perl_isinfnan(nv))
2202 #ifdef NV_PRESERVES_UV
2203 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2206 if (nv <= (NV)IV_MIN)
2209 ((nv > (NV)UV_MAX ||
2210 SvUV_nomg(sv) > (UV)IV_MAX)))
2221 const U8 gimme = GIMME_V;
2222 void *itervarp; /* GV or pad slot of the iteration variable */
2223 SV *itersave; /* the old var in the iterator var slot */
2226 if (PL_op->op_targ) { /* "my" variable */
2227 itervarp = &PAD_SVl(PL_op->op_targ);
2228 itersave = *(SV**)itervarp;
2230 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2231 /* the SV currently in the pad slot is never live during
2232 * iteration (the slot is always aliased to one of the items)
2233 * so it's always stale */
2234 SvPADSTALE_on(itersave);
2236 SvREFCNT_inc_simple_void_NN(itersave);
2237 cxflags = CXp_FOR_PAD;
2240 SV * const sv = POPs;
2241 itervarp = (void *)sv;
2242 if (LIKELY(isGV(sv))) { /* symbol table variable */
2243 itersave = GvSV(sv);
2244 SvREFCNT_inc_simple_void(itersave);
2245 cxflags = CXp_FOR_GV;
2246 if (PL_op->op_private & OPpITER_DEF)
2247 cxflags |= CXp_FOR_DEF;
2249 else { /* LV ref: for \$foo (...) */
2250 assert(SvTYPE(sv) == SVt_PVMG);
2251 assert(SvMAGIC(sv));
2252 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2254 cxflags = CXp_FOR_LVREF;
2257 /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2258 assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2260 /* Note that this context is initially set as CXt_NULL. Further on
2261 * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2262 * there mustn't be anything in the blk_loop substruct that requires
2263 * freeing or undoing, in case we die in the meantime. And vice-versa.
2265 cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2266 cx_pushloop_for(cx, itervarp, itersave);
2268 if (PL_op->op_flags & OPf_STACKED) {
2269 /* OPf_STACKED implies either a single array: for(@), with a
2270 * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2272 SV *maybe_ary = POPs;
2273 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2276 SV * const right = maybe_ary;
2277 if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2278 DIE(aTHX_ "Assigned value is not a reference");
2281 if (RANGE_IS_NUMERIC(sv,right)) {
2282 cx->cx_type |= CXt_LOOP_LAZYIV;
2283 if (S_outside_integer(aTHX_ sv) ||
2284 S_outside_integer(aTHX_ right))
2285 DIE(aTHX_ "Range iterator outside integer range");
2286 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2287 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2290 cx->cx_type |= CXt_LOOP_LAZYSV;
2291 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2292 cx->blk_loop.state_u.lazysv.end = right;
2293 SvREFCNT_inc_simple_void_NN(right);
2294 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2295 /* This will do the upgrade to SVt_PV, and warn if the value
2296 is uninitialised. */
2297 (void) SvPV_nolen_const(right);
2298 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2299 to replace !SvOK() with a pointer to "". */
2301 SvREFCNT_dec(right);
2302 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2306 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2307 /* for (@array) {} */
2308 cx->cx_type |= CXt_LOOP_ARY;
2309 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2310 SvREFCNT_inc_simple_void_NN(maybe_ary);
2311 cx->blk_loop.state_u.ary.ix =
2312 (PL_op->op_private & OPpITER_REVERSED) ?
2313 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2316 /* EXTEND(SP, 1) not needed in this branch because we just did POPs */
2318 else { /* iterating over items on the stack */
2319 cx->cx_type |= CXt_LOOP_LIST;
2320 cx->blk_oldsp = SP - PL_stack_base;
2321 cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2322 cx->blk_loop.state_u.stack.ix =
2323 (PL_op->op_private & OPpITER_REVERSED)
2325 : cx->blk_loop.state_u.stack.basesp;
2326 /* pre-extend stack so pp_iter doesn't have to check every time
2327 * it pushes yes/no */
2337 const U8 gimme = GIMME_V;
2339 cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2340 cx_pushloop_plain(cx);
2353 assert(CxTYPE_is_LOOP(cx));
2354 oldsp = PL_stack_base + cx->blk_oldsp;
2355 base = CxTYPE(cx) == CXt_LOOP_LIST
2356 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2358 gimme = cx->blk_gimme;
2360 if (gimme == G_VOID)
2363 leave_adjust_stacks(oldsp, base, gimme,
2364 PL_op->op_private & OPpLVALUE ? 3 : 1);
2367 cx_poploop(cx); /* Stack values are safe: release loop vars ... */
2375 /* This duplicates most of pp_leavesub, but with additional code to handle
2376 * return args in lvalue context. It was forked from pp_leavesub to
2377 * avoid slowing down that function any further.
2379 * Any changes made to this function may need to be copied to pp_leavesub
2382 * also tail-called by pp_return
2393 assert(CxTYPE(cx) == CXt_SUB);
2395 if (CxMULTICALL(cx)) {
2396 /* entry zero of a stack is always PL_sv_undef, which
2397 * simplifies converting a '()' return into undef in scalar context */
2398 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2402 gimme = cx->blk_gimme;
2403 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2405 if (gimme == G_VOID)
2406 PL_stack_sp = oldsp;
2408 U8 lval = CxLVAL(cx);
2409 bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2410 const char *what = NULL;
2412 if (gimme == G_SCALAR) {
2414 /* check for bad return arg */
2415 if (oldsp < PL_stack_sp) {
2416 SV *sv = *PL_stack_sp;
2417 if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2419 SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2420 : "a readonly value" : "a temporary";
2425 /* sub:lvalue{} will take us here. */
2430 "Can't return %s from lvalue subroutine", what);
2434 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2436 if (lval & OPpDEREF) {
2437 /* lval_sub()->{...} and similar */
2441 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2447 assert(gimme == G_LIST);
2448 assert (!(lval & OPpDEREF));
2451 /* scan for bad return args */
2453 for (p = PL_stack_sp; p > oldsp; p--) {
2455 /* the PL_sv_undef exception is to allow things like
2456 * this to work, where PL_sv_undef acts as 'skip'
2457 * placeholder on the LHS of list assigns:
2458 * sub foo :lvalue { undef }
2459 * ($a, undef, foo(), $b) = 1..4;
2461 if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2463 /* Might be flattened array after $#array = */
2464 what = SvREADONLY(sv)
2465 ? "a readonly value" : "a temporary";
2471 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2476 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
2478 retop = cx->blk_sub.retop;
2489 I32 cxix = dopopto_cursub();
2491 assert(cxstack_ix >= 0);
2492 if (cxix < cxstack_ix) {
2494 /* Check for defer { return; } */
2495 for(i = cxstack_ix; i > cxix; i--) {
2496 if(CxTYPE(&cxstack[i]) == CXt_DEFER)
2497 Perl_croak(aTHX_ "Can't \"%s\" out of a \"defer\" block", "return");
2500 if (!( PL_curstackinfo->si_type == PERLSI_SORT
2501 || ( PL_curstackinfo->si_type == PERLSI_MULTICALL
2502 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2505 DIE(aTHX_ "Can't return outside a subroutine");
2507 * a sort block, which is a CXt_NULL not a CXt_SUB;
2508 * or a /(?{...})/ block.
2509 * Handle specially. */
2510 assert(CxTYPE(&cxstack[0]) == CXt_NULL
2511 || ( CxTYPE(&cxstack[0]) == CXt_SUB
2512 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2513 if (cxstack_ix > 0) {
2514 /* See comment below about context popping. Since we know
2515 * we're scalar and not lvalue, we can preserve the return
2516 * value in a simpler fashion than there. */
2518 assert(cxstack[0].blk_gimme == G_SCALAR);
2519 if ( (sp != PL_stack_base)
2520 && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2522 *SP = sv_mortalcopy(sv);
2525 /* caller responsible for popping cxstack[0] */
2529 /* There are contexts that need popping. Doing this may free the
2530 * return value(s), so preserve them first: e.g. popping the plain
2531 * loop here would free $x:
2532 * sub f { { my $x = 1; return $x } }
2533 * We may also need to shift the args down; for example,
2534 * for (1,2) { return 3,4 }
2535 * leaves 1,2,3,4 on the stack. Both these actions will be done by
2536 * leave_adjust_stacks(), along with freeing any temps. Note that
2537 * whoever we tail-call (e.g. pp_leaveeval) will also call
2538 * leave_adjust_stacks(); however, the second call is likely to
2539 * just see a bunch of SvTEMPs with a ref count of 1, and so just
2540 * pass them through, rather than copying them again. So this
2541 * isn't as inefficient as it sounds.
2543 cx = &cxstack[cxix];
2545 if (cx->blk_gimme != G_VOID)
2546 leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2548 CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2552 cx = &cxstack[cxix]; /* CX stack may have been realloced */
2555 /* Like in the branch above, we need to handle any extra junk on
2556 * the stack. But because we're not also popping extra contexts, we
2557 * don't have to worry about prematurely freeing args. So we just
2558 * need to do the bare minimum to handle junk, and leave the main
2559 * arg processing in the function we tail call, e.g. pp_leavesub.
2560 * In list context we have to splice out the junk; in scalar
2561 * context we can leave as-is (pp_leavesub will later return the
2562 * top stack element). But for an empty arg list, e.g.
2563 * for (1,2) { return }
2564 * we need to set sp = oldsp so that pp_leavesub knows to push
2565 * &PL_sv_undef onto the stack.
2568 cx = &cxstack[cxix];
2569 oldsp = PL_stack_base + cx->blk_oldsp;
2570 if (oldsp != MARK) {
2571 SSize_t nargs = SP - MARK;
2573 if (cx->blk_gimme == G_LIST) {
2574 /* shift return args to base of call stack frame */
2575 Move(MARK + 1, oldsp + 1, nargs, SV*);
2576 PL_stack_sp = oldsp + nargs;
2580 PL_stack_sp = oldsp;
2584 /* fall through to a normal exit */
2585 switch (CxTYPE(cx)) {
2587 return CxEVALBLOCK(cx)
2588 ? Perl_pp_leavetry(aTHX)
2589 : Perl_pp_leaveeval(aTHX);
2591 return CvLVALUE(cx->blk_sub.cv)
2592 ? Perl_pp_leavesublv(aTHX)
2593 : Perl_pp_leavesub(aTHX);
2595 return Perl_pp_leavewrite(aTHX);
2597 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2601 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2603 static PERL_CONTEXT *
2607 if (PL_op->op_flags & OPf_SPECIAL) {
2608 cxix = dopoptoloop(cxstack_ix);
2610 /* diag_listed_as: Can't "last" outside a loop block */
2611 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2617 const char * const label =
2618 PL_op->op_flags & OPf_STACKED
2619 ? SvPV(TOPs,label_len)
2620 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2621 const U32 label_flags =
2622 PL_op->op_flags & OPf_STACKED
2624 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2626 cxix = dopoptolabel(label, label_len, label_flags);
2628 /* diag_listed_as: Label not found for "last %s" */
2629 Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"",
2631 SVfARG(PL_op->op_flags & OPf_STACKED
2632 && !SvGMAGICAL(TOPp1s)
2634 : newSVpvn_flags(label,
2636 label_flags | SVs_TEMP)));
2638 if (cxix < cxstack_ix) {
2640 /* Check for defer { last ... } etc */
2641 for(i = cxstack_ix; i > cxix; i--) {
2642 if(CxTYPE(&cxstack[i]) == CXt_DEFER)
2643 Perl_croak(aTHX_ "Can't \"%s\" out of a \"defer\" block", OP_NAME(PL_op));
2647 return &cxstack[cxix];
2656 cx = S_unwind_loop(aTHX);
2658 assert(CxTYPE_is_LOOP(cx));
2659 PL_stack_sp = PL_stack_base
2660 + (CxTYPE(cx) == CXt_LOOP_LIST
2661 ? cx->blk_loop.state_u.stack.basesp
2667 /* Stack values are safe: */
2669 cx_poploop(cx); /* release loop vars ... */
2671 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2681 /* if not a bare 'next' in the main scope, search for it */
2683 if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
2684 cx = S_unwind_loop(aTHX);
2687 PL_curcop = cx->blk_oldcop;
2689 return (cx)->blk_loop.my_op->op_nextop;
2694 PERL_CONTEXT *cx = S_unwind_loop(aTHX);
2695 OP* redo_op = cx->blk_loop.my_op->op_redoop;
2697 if (redo_op->op_type == OP_ENTER) {
2698 /* pop one less context to avoid $x being freed in while (my $x..) */
2701 assert(CxTYPE(cx) == CXt_BLOCK);
2702 redo_op = redo_op->op_next;
2708 PL_curcop = cx->blk_oldcop;
2713 #define UNENTERABLE (OP *)1
2714 #define GOTO_DEPTH 64
2717 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2720 static const char* const too_deep = "Target of goto is too deeply nested";
2722 PERL_ARGS_ASSERT_DOFINDLABEL;
2725 Perl_croak(aTHX_ "%s", too_deep);
2726 if (o->op_type == OP_LEAVE ||
2727 o->op_type == OP_SCOPE ||
2728 o->op_type == OP_LEAVELOOP ||
2729 o->op_type == OP_LEAVESUB ||
2730 o->op_type == OP_LEAVETRY ||
2731 o->op_type == OP_LEAVEGIVEN)
2733 *ops++ = cUNOPo->op_first;
2735 else if (oplimit - opstack < GOTO_DEPTH) {
2736 if (o->op_flags & OPf_KIDS
2737 && cUNOPo->op_first->op_type == OP_PUSHMARK) {
2738 *ops++ = UNENTERABLE;
2740 else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type]
2741 && OP_CLASS(o) != OA_LOGOP
2742 && o->op_type != OP_LINESEQ
2743 && o->op_type != OP_SREFGEN
2744 && o->op_type != OP_ENTEREVAL
2745 && o->op_type != OP_GLOB
2746 && o->op_type != OP_RV2CV) {
2747 OP * const kid = cUNOPo->op_first;
2748 if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid))
2749 *ops++ = UNENTERABLE;
2753 Perl_croak(aTHX_ "%s", too_deep);
2755 if (o->op_flags & OPf_KIDS) {
2757 OP * const kid1 = cUNOPo->op_first;
2758 /* First try all the kids at this level, since that's likeliest. */
2759 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2760 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2761 STRLEN kid_label_len;
2762 U32 kid_label_flags;
2763 const char *kid_label = CopLABEL_len_flags(kCOP,
2764 &kid_label_len, &kid_label_flags);
2766 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2769 (const U8*)kid_label, kid_label_len,
2770 (const U8*)label, len) == 0)
2772 (const U8*)label, len,
2773 (const U8*)kid_label, kid_label_len) == 0)
2774 : ( len == kid_label_len && ((kid_label == label)
2775 || memEQ(kid_label, label, len)))))
2779 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2780 bool first_kid_of_binary = FALSE;
2781 if (kid == PL_lastgotoprobe)
2783 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2786 else if (ops[-1] != UNENTERABLE
2787 && (ops[-1]->op_type == OP_NEXTSTATE ||
2788 ops[-1]->op_type == OP_DBSTATE))
2793 if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) {
2794 first_kid_of_binary = TRUE;
2797 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit))) {
2798 if (kid->op_type == OP_PUSHDEFER)
2799 Perl_croak(aTHX_ "Can't \"goto\" into a \"defer\" block");
2802 if (first_kid_of_binary)
2803 *ops++ = UNENTERABLE;
2812 S_check_op_type(pTHX_ OP * const o)
2814 /* Eventually we may want to stack the needed arguments
2815 * for each op. For now, we punt on the hard ones. */
2816 /* XXX This comment seems to me like wishful thinking. --sprout */
2817 if (o == UNENTERABLE)
2819 "Can't \"goto\" into a binary or list expression");
2820 if (o->op_type == OP_ENTERITER)
2822 "Can't \"goto\" into the middle of a foreach loop");
2823 if (o->op_type == OP_ENTERGIVEN)
2825 "Can't \"goto\" into a \"given\" block");
2828 /* also used for: pp_dump() */
2836 OP *enterops[GOTO_DEPTH];
2837 const char *label = NULL;
2838 STRLEN label_len = 0;
2839 U32 label_flags = 0;
2840 const bool do_dump = (PL_op->op_type == OP_DUMP);
2841 static const char* const must_have_label = "goto must have label";
2843 if (PL_op->op_flags & OPf_STACKED) {
2844 /* goto EXPR or goto &foo */
2846 SV * const sv = POPs;
2849 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2850 /* This egregious kludge implements goto &subroutine */
2853 CV *cv = MUTABLE_CV(SvRV(sv));
2854 AV *arg = GvAV(PL_defgv);
2856 while (!CvROOT(cv) && !CvXSUB(cv)) {
2857 const GV * const gv = CvGV(cv);
2861 /* autoloaded stub? */
2862 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2864 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2866 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2867 if (autogv && (cv = GvCV(autogv)))
2869 tmpstr = sv_newmortal();
2870 gv_efullname3(tmpstr, gv, NULL);
2871 DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
2873 DIE(aTHX_ "Goto undefined subroutine");
2876 cxix = dopopto_cursub();
2878 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2880 cx = &cxstack[cxix];
2881 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2882 if (CxTYPE(cx) == CXt_EVAL) {
2884 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2885 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2887 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2888 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2890 else if (CxMULTICALL(cx))
2891 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2893 /* Check for defer { goto &...; } */
2894 for(ix = cxstack_ix; ix > cxix; ix--) {
2895 if(CxTYPE(&cxstack[ix]) == CXt_DEFER)
2896 Perl_croak(aTHX_ "Can't \"%s\" out of a \"defer\" block", "goto");
2899 /* First do some returnish stuff. */
2901 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2903 if (cxix < cxstack_ix) {
2910 /* protect @_ during save stack unwind. */
2912 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
2914 assert(PL_scopestack_ix == cx->blk_oldscopesp);
2917 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2918 /* this is part of cx_popsub_args() */
2919 AV* av = MUTABLE_AV(PAD_SVl(0));
2920 assert(AvARRAY(MUTABLE_AV(
2921 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2922 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2924 /* we are going to donate the current @_ from the old sub
2925 * to the new sub. This first part of the donation puts a
2926 * new empty AV in the pad[0] slot of the old sub,
2927 * unless pad[0] and @_ differ (e.g. if the old sub did
2928 * local *_ = []); in which case clear the old pad[0]
2929 * array in the usual way */
2930 if (av == arg || AvREAL(av))
2931 clear_defarray(av, av == arg);
2932 else CLEAR_ARGARRAY(av);
2935 /* don't restore PL_comppad here. It won't be needed if the
2936 * sub we're going to is non-XS, but restoring it early then
2937 * croaking (e.g. the "Goto undefined subroutine" below)
2938 * means the CX block gets processed again in dounwind,
2939 * but this time with the wrong PL_comppad */
2941 /* A destructor called during LEAVE_SCOPE could have undefined
2942 * our precious cv. See bug #99850. */
2943 if (!CvROOT(cv) && !CvXSUB(cv)) {
2944 const GV * const gv = CvGV(cv);
2946 SV * const tmpstr = sv_newmortal();
2947 gv_efullname3(tmpstr, gv, NULL);
2948 DIE(aTHX_ "Goto undefined subroutine &%" SVf,
2951 DIE(aTHX_ "Goto undefined subroutine");
2954 if (CxTYPE(cx) == CXt_SUB) {
2955 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
2956 SvREFCNT_dec_NN(cx->blk_sub.cv);
2959 /* Now do some callish stuff. */
2961 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
2962 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
2967 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2969 /* put GvAV(defgv) back onto stack */
2971 EXTEND(SP, items+1); /* @_ could have been extended. */
2976 bool r = cBOOL(AvREAL(arg));
2977 for (index=0; index<items; index++)
2981 SV ** const svp = av_fetch(arg, index, 0);
2982 sv = svp ? *svp : NULL;
2984 else sv = AvARRAY(arg)[index];
2986 ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv
2987 : sv_2mortal(newSVavdefelem(arg, index, 1));
2991 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2992 /* Restore old @_ */
2993 CX_POP_SAVEARRAY(cx);
2996 retop = cx->blk_sub.retop;
2997 PL_comppad = cx->blk_sub.prevcomppad;
2998 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
3000 /* XS subs don't have a CXt_SUB, so pop it;
3001 * this is a cx_popblock(), less all the stuff we already did
3002 * for cx_topblock() earlier */
3003 PL_curcop = cx->blk_oldcop;
3004 /* this is cx_popsub, less all the stuff we already did */
3005 PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
3009 /* Push a mark for the start of arglist */
3012 (void)(*CvXSUB(cv))(aTHX_ cv);
3017 PADLIST * const padlist = CvPADLIST(cv);
3019 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
3021 /* partial unrolled cx_pushsub(): */
3023 cx->blk_sub.cv = cv;
3024 cx->blk_sub.olddepth = CvDEPTH(cv);
3027 SvREFCNT_inc_simple_void_NN(cv);
3028 if (CvDEPTH(cv) > 1) {
3029 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
3030 sub_crush_depth(cv);
3031 pad_push(padlist, CvDEPTH(cv));
3033 PL_curcop = cx->blk_oldcop;
3034 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
3037 /* second half of donating @_ from the old sub to the
3038 * new sub: abandon the original pad[0] AV in the
3039 * new sub, and replace it with the donated @_.
3040 * pad[0] takes ownership of the extra refcount
3041 * we gave arg earlier */
3043 SvREFCNT_dec(PAD_SVl(0));
3044 PAD_SVl(0) = (SV *)arg;
3045 SvREFCNT_inc_simple_void_NN(arg);
3048 /* GvAV(PL_defgv) might have been modified on scope
3049 exit, so point it at arg again. */
3050 if (arg != GvAV(PL_defgv)) {
3051 AV * const av = GvAV(PL_defgv);
3052 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
3057 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
3058 Perl_get_db_sub(aTHX_ NULL, cv);
3060 CV * const gotocv = get_cvs("DB::goto", 0);
3062 PUSHMARK( PL_stack_sp );
3063 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
3068 retop = CvSTART(cv);
3069 goto putback_return;
3074 label = SvPV_nomg_const(sv, label_len);
3075 label_flags = SvUTF8(sv);
3078 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
3079 /* goto LABEL or dump LABEL */
3080 label = cPVOP->op_pv;
3081 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
3082 label_len = strlen(label);
3084 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
3089 OP *gotoprobe = NULL;
3090 bool leaving_eval = FALSE;
3091 bool in_block = FALSE;
3092 bool pseudo_block = FALSE;
3093 PERL_CONTEXT *last_eval_cx = NULL;
3097 PL_lastgotoprobe = NULL;
3099 for (ix = cxstack_ix; ix >= 0; ix--) {
3101 switch (CxTYPE(cx)) {
3103 leaving_eval = TRUE;
3104 if (!CxEVALBLOCK(cx)) {
3105 gotoprobe = (last_eval_cx ?
3106 last_eval_cx->blk_eval.old_eval_root :
3111 /* else fall through */
3112 case CXt_LOOP_PLAIN:
3113 case CXt_LOOP_LAZYIV:
3114 case CXt_LOOP_LAZYSV:
3119 gotoprobe = OpSIBLING(cx->blk_oldcop);
3125 gotoprobe = OpSIBLING(cx->blk_oldcop);
3128 gotoprobe = PL_main_root;
3131 gotoprobe = CvROOT(cx->blk_sub.cv);
3132 pseudo_block = cBOOL(CxMULTICALL(cx));
3136 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3138 DIE(aTHX_ "Can't \"%s\" out of a \"defer\" block", "goto");
3141 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3142 CxTYPE(cx), (long) ix);
3143 gotoprobe = PL_main_root;
3149 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3150 enterops, enterops + GOTO_DEPTH);
3153 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3154 sibl1->op_type == OP_UNSTACK &&
3155 (sibl2 = OpSIBLING(sibl1)))
3157 retop = dofindlabel(sibl2,
3158 label, label_len, label_flags, enterops,
3159 enterops + GOTO_DEPTH);
3165 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3166 PL_lastgotoprobe = gotoprobe;
3169 DIE(aTHX_ "Can't find label %" UTF8f,
3170 UTF8fARG(label_flags, label_len, label));
3172 /* if we're leaving an eval, check before we pop any frames
3173 that we're not going to punt, otherwise the error
3176 if (leaving_eval && *enterops && enterops[1]) {
3178 for (i = 1; enterops[i]; i++)
3179 S_check_op_type(aTHX_ enterops[i]);
3182 if (*enterops && enterops[1]) {
3183 I32 i = enterops[1] != UNENTERABLE
3184 && enterops[1]->op_type == OP_ENTER && in_block
3188 deprecate("\"goto\" to jump into a construct");
3191 /* pop unwanted frames */
3193 if (ix < cxstack_ix) {
3195 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3201 /* push wanted frames */
3203 if (*enterops && enterops[1]) {
3204 OP * const oldop = PL_op;
3205 ix = enterops[1] != UNENTERABLE
3206 && enterops[1]->op_type == OP_ENTER && in_block
3209 for (; enterops[ix]; ix++) {
3210 PL_op = enterops[ix];
3211 S_check_op_type(aTHX_ PL_op);
3212 DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n",
3214 PL_op->op_ppaddr(aTHX);
3222 if (!retop) retop = PL_main_start;
3224 PL_restartop = retop;
3225 PL_do_undump = TRUE;
3229 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3230 PL_do_undump = FALSE;
3248 anum = 0; (void)POPs;
3254 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3257 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3260 PL_exit_flags |= PERL_EXIT_EXPECTED;
3262 PUSHs(&PL_sv_undef);
3269 S_save_lines(pTHX_ AV *array, SV *sv)
3271 const char *s = SvPVX_const(sv);
3272 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3275 PERL_ARGS_ASSERT_SAVE_LINES;
3277 while (s && s < send) {
3279 SV * const tmpstr = newSV_type(SVt_PVMG);
3281 t = (const char *)memchr(s, '\n', send - s);
3287 sv_setpvn(tmpstr, s, t - s);
3288 av_store(array, line++, tmpstr);
3296 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3298 0 is used as continue inside eval,
3300 3 is used for a die caught by an inner eval - continue inner loop
3302 See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3303 establish a local jmpenv to handle exception traps.
3308 S_docatch(pTHX_ Perl_ppaddr_t firstpp)
3311 OP * const oldop = PL_op;
3314 assert(CATCH_GET == TRUE);
3319 PL_op = firstpp(aTHX);
3324 /* die caught by an inner eval - continue inner loop */
3325 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3326 PL_restartjmpenv = NULL;
3327 PL_op = PL_restartop;
3336 NOT_REACHED; /* NOTREACHED */
3345 =for apidoc find_runcv
3347 Locate the CV corresponding to the currently executing sub or eval.
3348 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3349 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3350 entered. (This allows debuggers to eval in the scope of the breakpoint
3351 rather than in the scope of the debugger itself.)
3357 Perl_find_runcv(pTHX_ U32 *db_seqp)
3359 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3362 /* If this becomes part of the API, it might need a better name. */
3364 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3371 PL_curcop == &PL_compiling
3373 : PL_curcop->cop_seq;
3375 for (si = PL_curstackinfo; si; si = si->si_prev) {
3377 for (ix = si->si_cxix; ix >= 0; ix--) {
3378 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3380 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3381 cv = cx->blk_sub.cv;
3382 /* skip DB:: code */
3383 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3384 *db_seqp = cx->blk_oldcop->cop_seq;
3387 if (cx->cx_type & CXp_SUB_RE)
3390 else if (CxTYPE(cx) == CXt_EVAL && !CxEVALBLOCK(cx))
3391 cv = cx->blk_eval.cv;
3394 case FIND_RUNCV_padid_eq:
3396 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3399 case FIND_RUNCV_level_eq:
3400 if (level++ != arg) continue;
3408 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3412 /* Run yyparse() in a setjmp wrapper. Returns:
3413 * 0: yyparse() successful
3414 * 1: yyparse() failed
3418 S_try_yyparse(pTHX_ int gramtype)
3423 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3427 ret = yyparse(gramtype) ? 1 : 0;
3434 NOT_REACHED; /* NOTREACHED */
3441 /* Compile a require/do or an eval ''.
3443 * outside is the lexically enclosing CV (if any) that invoked us.
3444 * seq is the current COP scope value.
3445 * hh is the saved hints hash, if any.
3447 * Returns a bool indicating whether the compile was successful; if so,
3448 * PL_eval_start contains the first op of the compiled code; otherwise,
3451 * This function is called from two places: pp_require and pp_entereval.
3452 * These can be distinguished by whether PL_op is entereval.
3456 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3459 OP * const saveop = PL_op;
3460 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3461 COP * const oldcurcop = PL_curcop;
3462 bool in_require = (saveop->op_type == OP_REQUIRE);
3466 PL_in_eval = (in_require
3467 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3469 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3470 ? EVAL_RE_REPARSING : 0)));
3474 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3476 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3477 CX_CUR()->blk_eval.cv = evalcv;
3478 CX_CUR()->blk_gimme = gimme;
3480 CvOUTSIDE_SEQ(evalcv) = seq;
3481 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3483 /* set up a scratch pad */
3485 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3486 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3489 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3491 /* make sure we compile in the right package */
3493 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3494 SAVEGENERICSV(PL_curstash);
3495 PL_curstash = (HV *)CopSTASH(PL_curcop);
3496 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3498 SvREFCNT_inc_simple_void(PL_curstash);
3499 save_item(PL_curstname);
3500 sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash));
3503 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3504 SAVESPTR(PL_beginav);
3505 PL_beginav = newAV();
3506 SAVEFREESV(PL_beginav);
3507 SAVESPTR(PL_unitcheckav);
3508 PL_unitcheckav = newAV();
3509 SAVEFREESV(PL_unitcheckav);
3512 ENTER_with_name("evalcomp");
3513 SAVESPTR(PL_compcv);
3516 /* try to compile it */
3518 PL_eval_root = NULL;
3519 PL_curcop = &PL_compiling;
3520 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3521 PL_in_eval |= EVAL_KEEPERR;
3527 PL_hints = HINTS_DEFAULT;
3528 hv_clear(GvHV(PL_hintgv));
3532 PL_hints = saveop->op_private & OPpEVAL_COPHH
3533 ? oldcurcop->cop_hints : (U32)saveop->op_targ;
3535 /* making 'use re eval' not be in scope when compiling the
3536 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3537 * infinite recursion when S_has_runtime_code() gives a false
3538 * positive: the second time round, HINT_RE_EVAL isn't set so we
3539 * don't bother calling S_has_runtime_code() */
3540 if (PL_in_eval & EVAL_RE_REPARSING)
3541 PL_hints &= ~HINT_RE_EVAL;
3544 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3545 SvREFCNT_dec(GvHV(PL_hintgv));
3546 GvHV(PL_hintgv) = hh;
3547 FETCHFEATUREBITSHH(hh);
3550 SAVECOMPILEWARNINGS();
3552 if (PL_dowarn & G_WARN_ALL_ON)
3553 PL_compiling.cop_warnings = pWARN_ALL ;
3554 else if (PL_dowarn & G_WARN_ALL_OFF)
3555 PL_compiling.cop_warnings = pWARN_NONE ;
3557 PL_compiling.cop_warnings = pWARN_STD ;
3560 PL_compiling.cop_warnings =
3561 DUP_WARNINGS(oldcurcop->cop_warnings);
3562 cophh_free(CopHINTHASH_get(&PL_compiling));
3563 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3564 /* The label, if present, is the first entry on the chain. So rather
3565 than writing a blank label in front of it (which involves an
3566 allocation), just use the next entry in the chain. */
3567 PL_compiling.cop_hints_hash
3568 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3569 /* Check the assumption that this removed the label. */
3570 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3573 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3576 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3578 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3579 * so honour CATCH_GET and trap it here if necessary */
3582 /* compile the code */
3583 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3585 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3590 /* note that if yystatus == 3, then the require/eval died during
3591 * compilation, so the EVAL CX block has already been popped, and
3592 * various vars restored */
3593 if (yystatus != 3) {
3595 op_free(PL_eval_root);
3596 PL_eval_root = NULL;
3598 SP = PL_stack_base + POPMARK; /* pop original mark */
3600 assert(CxTYPE(cx) == CXt_EVAL);
3601 /* pop the CXt_EVAL, and if was a require, croak */
3602 S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
3605 /* die_unwind() re-croaks when in require, having popped the
3606 * require EVAL context. So we should never catch a require
3608 assert(!in_require);
3611 if (!*(SvPV_nolen_const(errsv)))
3612 sv_setpvs(errsv, "Compilation error");
3614 if (gimme != G_LIST) PUSHs(&PL_sv_undef);
3619 /* Compilation successful. Now clean up */
3621 LEAVE_with_name("evalcomp");
3623 CopLINE_set(&PL_compiling, 0);
3624 SAVEFREEOP(PL_eval_root);
3625 cv_forget_slab(evalcv);
3627 DEBUG_x(dump_eval());
3629 /* Register with debugger: */
3630 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3631 CV * const cv = get_cvs("DB::postponed", 0);
3635 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3637 call_sv(MUTABLE_SV(cv), G_DISCARD);
3641 if (PL_unitcheckav) {
3642 OP *es = PL_eval_start;
3643 call_list(PL_scopestack_ix, PL_unitcheckav);
3647 CvDEPTH(evalcv) = 1;
3648 SP = PL_stack_base + POPMARK; /* pop original mark */
3649 PL_op = saveop; /* The caller may need it. */
3650 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3656 /* Return NULL if the file doesn't exist or isn't a file;
3657 * else return PerlIO_openn().
3661 S_check_type_and_open(pTHX_ SV *name)
3666 const char *p = SvPV_const(name, len);
3669 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3671 /* checking here captures a reasonable error message when
3672 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3673 * user gets a confusing message about looking for the .pmc file
3674 * rather than for the .pm file so do the check in S_doopen_pm when
3675 * PMC is on instead of here. S_doopen_pm calls this func.
3676 * This check prevents a \0 in @INC causing problems.
3678 #ifdef PERL_DISABLE_PMC
3679 if (!IS_SAFE_PATHNAME(p, len, "require"))
3683 /* on Win32 stat is expensive (it does an open() and close() twice and
3684 a couple other IO calls), the open will fail with a dir on its own with
3685 errno EACCES, so only do a stat to separate a dir from a real EACCES
3686 caused by user perms */
3688 st_rc = PerlLIO_stat(p, &st);
3694 if(S_ISBLK(st.st_mode)) {
3698 else if(S_ISDIR(st.st_mode)) {
3707 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3709 /* EACCES stops the INC search early in pp_require to implement
3710 feature RT #113422 */
3711 if(!retio && errno == EACCES) { /* exists but probably a directory */
3713 st_rc = PerlLIO_stat(p, &st);
3715 if(S_ISDIR(st.st_mode))
3717 else if(S_ISBLK(st.st_mode))
3728 /* doopen_pm(): return the equivalent of PerlIO_openn() on the given name,
3729 * but first check for bad names (\0) and non-files.
3730 * Also if the filename ends in .pm and unless PERL_DISABLE_PMC,
3731 * try loading Foo.pmc first.
3733 #ifndef PERL_DISABLE_PMC
3735 S_doopen_pm(pTHX_ SV *name)
3738 const char *p = SvPV_const(name, namelen);
3740 PERL_ARGS_ASSERT_DOOPEN_PM;
3742 /* check the name before trying for the .pmc name to avoid the
3743 * warning referring to the .pmc which the user probably doesn't
3744 * know or care about
3746 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3749 if (memENDPs(p, namelen, ".pm")) {
3750 SV *const pmcsv = sv_newmortal();
3753 SvSetSV_nosteal(pmcsv,name);
3754 sv_catpvs(pmcsv, "c");
3756 pmcio = check_type_and_open(pmcsv);
3760 return check_type_and_open(name);
3763 # define doopen_pm(name) check_type_and_open(name)
3764 #endif /* !PERL_DISABLE_PMC */
3766 /* require doesn't search in @INC for absolute names, or when the name is
3767 explicitly relative the current directory: i.e. ./, ../ */
3768 PERL_STATIC_INLINE bool
3769 S_path_is_searchable(const char *name)
3771 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3773 if (PERL_FILE_IS_ABSOLUTE(name)
3775 || (*name == '.' && ((name[1] == '/' ||
3776 (name[1] == '.' && name[2] == '/'))
3777 || (name[1] == '\\' ||
3778 ( name[1] == '.' && name[2] == '\\')))
3781 || (*name == '.' && (name[1] == '/' ||
3782 (name[1] == '.' && name[2] == '/')))
3793 /* implement 'require 5.010001' */
3796 S_require_version(pTHX_ SV *sv)
3800 sv = sv_2mortal(new_version(sv));
3801 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3802 upg_version(PL_patchlevel, TRUE);
3803 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3804 if ( vcmp(sv,PL_patchlevel) <= 0 )
3805 DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
3806 SVfARG(sv_2mortal(vnormal(sv))),
3807 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3811 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3814 SV * const req = SvRV(sv);
3815 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3817 /* get the left hand term */
3818 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3820 first = SvIV(*av_fetch(lav,0,0));
3821 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3822 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3823 || av_count(lav) > 2 /* FP with > 3 digits */
3824 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3826 DIE(aTHX_ "Perl %" SVf " required--this is only "
3827 "%" SVf ", stopped",
3828 SVfARG(sv_2mortal(vnormal(req))),
3829 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3832 else { /* probably 'use 5.10' or 'use 5.8' */
3836 if (av_count(lav) > 1)
3837 second = SvIV(*av_fetch(lav,1,0));
3839 second /= second >= 600 ? 100 : 10;
3840 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3841 (int)first, (int)second);
3842 upg_version(hintsv, TRUE);
3844 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)"
3845 "--this is only %" SVf ", stopped",
3846 SVfARG(sv_2mortal(vnormal(req))),
3847 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3848 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3857 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
3858 * The first form will have already been converted at compile time to
3859 * the second form */
3862 S_require_file(pTHX_ SV *sv)
3872 int vms_unixname = 0;
3875 /* tryname is the actual pathname (with @INC prefix) which was loaded.
3876 * It's stored as a value in %INC, and used for error messages */
3877 const char *tryname = NULL;
3878 SV *namesv = NULL; /* SV equivalent of tryname */
3879 const U8 gimme = GIMME_V;
3880 int filter_has_file = 0;
3881 PerlIO *tryrsfp = NULL;
3882 SV *filter_cache = NULL;
3883 SV *filter_state = NULL;
3884 SV *filter_sub = NULL;
3888 bool path_searchable;
3889 I32 old_savestack_ix;
3890 const bool op_is_require = PL_op->op_type == OP_REQUIRE;
3891 const char *const op_name = op_is_require ? "require" : "do";
3892 SV ** svp_cached = NULL;
3894 assert(op_is_require || PL_op->op_type == OP_DOFILE);
3897 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3898 name = SvPV_nomg_const(sv, len);
3899 if (!(name && len > 0 && *name))
3900 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
3903 /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */
3904 if (op_is_require) {
3905 /* can optimize to only perform one single lookup */
3906 svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0);
3907 if ( svp_cached && (SvGETMAGIC(*svp_cached), SvOK(*svp_cached)) ) RETPUSHYES;
3911 if (!IS_SAFE_PATHNAME(name, len, op_name)) {
3912 if (!op_is_require) {
3916 DIE(aTHX_ "Can't locate %s: %s",
3917 pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
3918 NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3921 TAINT_PROPER(op_name);
3923 path_searchable = path_is_searchable(name);
3926 /* The key in the %ENV hash is in the syntax of file passed as the argument
3927 * usually this is in UNIX format, but sometimes in VMS format, which
3928 * can result in a module being pulled in more than once.
3929 * To prevent this, the key must be stored in UNIX format if the VMS
3930 * name can be translated to UNIX.
3934 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3936 unixlen = strlen(unixname);
3942 /* if not VMS or VMS name can not be translated to UNIX, pass it
3945 unixname = (char *) name;
3948 if (op_is_require) {
3949 /* reuse the previous hv_fetch result if possible */
3950 SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3952 /* we already did a get magic if this was cached */
3958 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3959 "Compilation failed in require", unixname);
3962 /*XXX OPf_KIDS should always be true? -dapm 4/2017 */
3963 if (PL_op->op_flags & OPf_KIDS) {
3964 SVOP * const kid = (SVOP*)cUNOP->op_first;
3966 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
3967 /* Make sure that a bareword module name (e.g. ::Foo::Bar)
3968 * doesn't map to a naughty pathname like /Foo/Bar.pm.
3969 * Note that the parser will normally detect such errors
3970 * at compile time before we reach here, but
3971 * Perl_load_module() can fake up an identical optree
3972 * without going near the parser, and being able to put
3973 * anything as the bareword. So we include a duplicate set
3974 * of checks here at runtime.
3976 const STRLEN package_len = len - 3;
3977 const char slashdot[2] = {'/', '.'};
3979 const char backslashdot[2] = {'\\', '.'};
3982 /* Disallow *purported* barewords that map to absolute
3983 filenames, filenames relative to the current or parent
3984 directory, or (*nix) hidden filenames. Also sanity check
3985 that the generated filename ends .pm */
3986 if (!path_searchable || len < 3 || name[0] == '.'
3987 || !memEQs(name + package_len, len - package_len, ".pm"))
3988 DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv);
3989 if (memchr(name, 0, package_len)) {
3990 /* diag_listed_as: Bareword in require contains "%s" */
3991 DIE(aTHX_ "Bareword in require contains \"\\0\"");
3993 if (ninstr(name, name + package_len, slashdot,
3994 slashdot + sizeof(slashdot))) {
3995 /* diag_listed_as: Bareword in require contains "%s" */
3996 DIE(aTHX_ "Bareword in require contains \"/.\"");
3999 if (ninstr(name, name + package_len, backslashdot,
4000 backslashdot + sizeof(backslashdot))) {
4001 /* diag_listed_as: Bareword in require contains "%s" */
4002 DIE(aTHX_ "Bareword in require contains \"\\.\"");
4009 PERL_DTRACE_PROBE_FILE_LOADING(unixname);
4011 /* Try to locate and open a file, possibly using @INC */
4013 /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load
4014 * the file directly rather than via @INC ... */
4015 if (!path_searchable) {
4016 /* At this point, name is SvPVX(sv) */
4018 tryrsfp = doopen_pm(sv);
4021 /* ... but if we fail, still search @INC for code references;
4022 * these are applied even on non-searchable paths (except
4023 * if we got EACESS).
4025 * For searchable paths, just search @INC normally
4027 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
4028 AV * const ar = GvAVn(PL_incgv);
4035 namesv = newSV_type(SVt_PV);
4036 for (i = 0; i <= AvFILL(ar); i++) {
4037 SV * const dirsv = *av_fetch(ar, i, TRUE);
4045 if (SvTYPE(SvRV(loader)) == SVt_PVAV
4046 && !SvOBJECT(SvRV(loader)))
4048 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
4052 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
4053 PTR2UV(SvRV(dirsv)), name);
4054 tryname = SvPVX_const(namesv);
4057 if (SvPADTMP(nsv)) {
4058 nsv = sv_newmortal();
4059 SvSetSV_nosteal(nsv,sv);
4062 ENTER_with_name("call_INC");
4070 if (SvGMAGICAL(loader)) {
4071 SV *l = sv_newmortal();
4072 sv_setsv_nomg(l, loader);
4075 if (sv_isobject(loader))
4076 count = call_method("INC", G_LIST);
4078 count = call_sv(loader, G_LIST);
4088 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
4089 && !isGV_with_GP(SvRV(arg))) {
4090 filter_cache = SvRV(arg);
4097 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
4101 if (isGV_with_GP(arg)) {
4102 IO * const io = GvIO((const GV *)arg);
4107 tryrsfp = IoIFP(io);
4108 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
4109 PerlIO_close(IoOFP(io));
4120 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
4122 SvREFCNT_inc_simple_void_NN(filter_sub);
4125 filter_state = SP[i];
4126 SvREFCNT_inc_simple_void(filter_state);
4130 if (!tryrsfp && (filter_cache || filter_sub)) {
4131 tryrsfp = PerlIO_open(BIT_BUCKET,
4137 /* FREETMPS may free our filter_cache */
4138 SvREFCNT_inc_simple_void(filter_cache);
4142 LEAVE_with_name("call_INC");
4144 /* Now re-mortalize it. */
4145 sv_2mortal(filter_cache);
4147 /* Adjust file name if the hook has set an %INC entry.
4148 This needs to happen after the FREETMPS above. */
4149 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
4151 tryname = SvPV_nolen_const(*svp);
4158 filter_has_file = 0;
4159 filter_cache = NULL;
4161 SvREFCNT_dec_NN(filter_state);
4162 filter_state = NULL;
4165 SvREFCNT_dec_NN(filter_sub);
4169 else if (path_searchable) {
4170 /* match against a plain @INC element (non-searchable
4171 * paths are only matched against refs in @INC) */
4176 dir = SvPV_nomg_const(dirsv, dirlen);
4182 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
4186 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4189 sv_setpv(namesv, unixdir);
4190 sv_catpv(namesv, unixname);
4192 /* The equivalent of
4193 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4194 but without the need to parse the format string, or
4195 call strlen on either pointer, and with the correct
4196 allocation up front. */
4198 char *tmp = SvGROW(namesv, dirlen + len + 2);
4200 memcpy(tmp, dir, dirlen);
4203 /* Avoid '<dir>//<file>' */
4204 if (!dirlen || *(tmp-1) != '/') {
4207 /* So SvCUR_set reports the correct length below */
4211 /* name came from an SV, so it will have a '\0' at the
4212 end that we can copy as part of this memcpy(). */
4213 memcpy(tmp, name, len + 1);
4215 SvCUR_set(namesv, dirlen + len + 1);
4219 TAINT_PROPER(op_name);
4220 tryname = SvPVX_const(namesv);
4221 tryrsfp = doopen_pm(namesv);
4223 if (tryname[0] == '.' && tryname[1] == '/') {
4225 while (*++tryname == '/') {}
4229 else if (errno == EMFILE || errno == EACCES) {
4230 /* no point in trying other paths if out of handles;
4231 * on the other hand, if we couldn't open one of the
4232 * files, then going on with the search could lead to
4233 * unexpected results; see perl #113422
4242 /* at this point we've ether opened a file (tryrsfp) or set errno */
4244 saved_errno = errno; /* sv_2mortal can realloc things */
4247 /* we failed; croak if require() or return undef if do() */
4248 if (op_is_require) {
4249 if(saved_errno == EMFILE || saved_errno == EACCES) {
4250 /* diag_listed_as: Can't locate %s */
4251 DIE(aTHX_ "Can't locate %s: %s: %s",
4252 name, tryname, Strerror(saved_errno));
4254 if (path_searchable) { /* did we lookup @INC? */
4255 AV * const ar = GvAVn(PL_incgv);
4257 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4258 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4259 for (i = 0; i <= AvFILL(ar); i++) {
4260 sv_catpvs(inc, " ");
4261 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4263 if (memENDPs(name, len, ".pm")) {
4264 const char *e = name + len - (sizeof(".pm") - 1);
4266 bool utf8 = cBOOL(SvUTF8(sv));
4268 /* if the filename, when converted from "Foo/Bar.pm"
4269 * form back to Foo::Bar form, makes a valid
4270 * package name (i.e. parseable by C<require
4271 * Foo::Bar>), then emit a hint.
4273 * this loop is modelled after the one in
4277 if (utf8 && isIDFIRST_utf8_safe(c, e)) {
4279 while (c < e && isIDCONT_utf8_safe(
4280 (const U8*) c, (const U8*) e))
4283 else if (isWORDCHAR_A(*c)) {
4284 while (c < e && isWORDCHAR_A(*c))
4293 if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
4294 sv_catpvs(msg, " (you may need to install the ");
4295 for (c = name; c < e; c++) {
4297 sv_catpvs(msg, "::");
4300 sv_catpvn(msg, c, 1);
4303 sv_catpvs(msg, " module)");
4306 else if (memENDs(name, len, ".h")) {
4307 sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4309 else if (memENDs(name, len, ".ph")) {
4310 sv_catpvs(msg, " (did you run h2ph?)");
4313 /* diag_listed_as: Can't locate %s */
4315 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4319 DIE(aTHX_ "Can't locate %s", name);
4322 #ifdef DEFAULT_INC_EXCLUDES_DOT
4326 /* the complication is to match the logic from doopen_pm() so
4327 * we don't treat do "sda1" as a previously successful "do".
4329 bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED)
4330 && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode)
4331 && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL;
4337 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4338 "do \"%s\" failed, '.' is no longer in @INC; "
4339 "did you mean do \"./%s\"?",
4348 SETERRNO(0, SS_NORMAL);
4350 /* Update %INC. Assume success here to prevent recursive requirement. */
4351 /* name is never assigned to again, so len is still strlen(name) */
4352 /* Check whether a hook in @INC has already filled %INC */
4354 (void)hv_store(GvHVn(PL_incgv),
4355 unixname, unixlen, newSVpv(tryname,0),0);
4357 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4359 (void)hv_store(GvHVn(PL_incgv),
4360 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4363 /* Now parse the file */
4365 old_savestack_ix = PL_savestack_ix;
4366 SAVECOPFILE_FREE(&PL_compiling);
4367 CopFILE_set(&PL_compiling, tryname);
4368 lex_start(NULL, tryrsfp, 0);
4370 if (filter_sub || filter_cache) {
4371 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4372 than hanging another SV from it. In turn, filter_add() optionally
4373 takes the SV to use as the filter (or creates a new SV if passed
4374 NULL), so simply pass in whatever value filter_cache has. */
4375 SV * const fc = filter_cache ? newSV(0) : NULL;
4377 if (fc) sv_copypv(fc, filter_cache);
4378 datasv = filter_add(S_run_user_filter, fc);
4379 IoLINES(datasv) = filter_has_file;
4380 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4381 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4384 /* switch to eval mode */
4386 cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
4387 cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
4389 SAVECOPLINE(&PL_compiling);
4390 CopLINE_set(&PL_compiling, 0);
4394 if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
4397 op = PL_op->op_next;
4399 PERL_DTRACE_PROBE_FILE_LOADED(unixname);
4405 /* also used for: pp_dofile() */
4409 RUN_PP_CATCHABLY(Perl_pp_require);
4416 return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
4417 ? S_require_version(aTHX_ sv)
4418 : S_require_file(aTHX_ sv);
4423 /* This is a op added to hold the hints hash for
4424 pp_entereval. The hash can be modified by the code
4425 being eval'ed, so we return a copy instead. */
4430 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4442 char tbuf[TYPE_DIGITS(long) + 12];
4450 I32 old_savestack_ix;
4452 RUN_PP_CATCHABLY(Perl_pp_entereval);
4455 was = PL_breakable_sub_gen;
4456 saved_delete = FALSE;
4460 bytes = PL_op->op_private & OPpEVAL_BYTES;
4462 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4463 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4465 else if (PL_hints & HINT_LOCALIZE_HH || (
4466 PL_op->op_private & OPpEVAL_COPHH
4467 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4469 saved_hh = cop_hints_2hv(PL_curcop, 0);
4470 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4474 /* make sure we've got a plain PV (no overload etc) before testing
4475 * for taint. Making a copy here is probably overkill, but better
4476 * safe than sorry */
4478 const char * const p = SvPV_const(sv, len);
4480 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4481 lex_flags |= LEX_START_COPIED;
4483 if (bytes && SvUTF8(sv))
4484 SvPVbyte_force(sv, len);
4486 else if (bytes && SvUTF8(sv)) {
4487 /* Don't modify someone else's scalar */
4490 (void)sv_2mortal(sv);
4491 SvPVbyte_force(sv,len);
4492 lex_flags |= LEX_START_COPIED;
4495 TAINT_IF(SvTAINTED(sv));
4496 TAINT_PROPER("eval");
4498 old_savestack_ix = PL_savestack_ix;
4500 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4501 ? LEX_IGNORE_UTF8_HINTS
4502 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4506 /* switch to eval mode */
4508 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4509 SV * const temp_sv = sv_newmortal();
4510 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]",
4511 (unsigned long)++PL_evalseq,
4512 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4513 tmpbuf = SvPVX(temp_sv);
4514 len = SvCUR(temp_sv);
4517 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4518 SAVECOPFILE_FREE(&PL_compiling);
4519 CopFILE_set(&PL_compiling, tmpbuf+2);
4520 SAVECOPLINE(&PL_compiling);
4521 CopLINE_set(&PL_compiling, 1);
4522 /* special case: an eval '' executed within the DB package gets lexically
4523 * placed in the first non-DB CV rather than the current CV - this
4524 * allows the debugger to execute code, find lexicals etc, in the
4525 * scope of the code being debugged. Passing &seq gets find_runcv
4526 * to do the dirty work for us */
4527 runcv = find_runcv(&seq);
4530 cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
4531 cx_pusheval(cx, PL_op->op_next, NULL);
4533 /* prepare to compile string */
4535 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
4536 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4538 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4539 deleting the eval's FILEGV from the stash before gv_check() runs
4540 (i.e. before run-time proper). To work around the coredump that
4541 ensues, we always turn GvMULTI_on for any globals that were
4542 introduced within evals. See force_ident(). GSAR 96-10-12 */
4543 char *const safestr = savepvn(tmpbuf, len);
4544 SAVEDELETE(PL_defstash, safestr, len);
4545 saved_delete = TRUE;
4550 if (doeval_compile(gimme, runcv, seq, saved_hh)) {
4551 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4552 ? PERLDB_LINE_OR_SAVESRC
4553 : PERLDB_SAVESRC_NOSUBS) {
4554 /* Retain the filegv we created. */
4555 } else if (!saved_delete) {
4556 char *const safestr = savepvn(tmpbuf, len);
4557 SAVEDELETE(PL_defstash, safestr, len);
4559 return PL_eval_start;
4561 /* We have already left the scope set up earlier thanks to the LEAVE
4562 in doeval_compile(). */
4563 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4564 ? PERLDB_LINE_OR_SAVESRC
4565 : PERLDB_SAVESRC_INVALID) {
4566 /* Retain the filegv we created. */
4567 } else if (!saved_delete) {
4568 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4570 return PL_op->op_next;
4575 /* also tail-called by pp_return */
4590 assert(CxTYPE(cx) == CXt_EVAL);
4592 oldsp = PL_stack_base + cx->blk_oldsp;
4593 gimme = cx->blk_gimme;
4595 /* did require return a false value? */
4596 failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE
4597 && !(gimme == G_SCALAR
4598 ? SvTRUE_NN(*PL_stack_sp)
4599 : PL_stack_sp > oldsp);
4601 if (gimme == G_VOID) {
4602 PL_stack_sp = oldsp;
4603 /* free now to avoid late-called destructors clobbering $@ */
4607 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
4609 /* the cx_popeval does a leavescope, which frees the optree associated
4610 * with eval, which if it frees the nextstate associated with
4611 * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
4612 * regex when running under 'use re Debug' because it needs PL_curcop
4613 * to get the current hints. So restore it early.
4615 PL_curcop = cx->blk_oldcop;
4617 /* grab this value before cx_popeval restores the old PL_in_eval */
4618 keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
4619 retop = cx->blk_eval.retop;
4620 evalcv = cx->blk_eval.cv;
4622 assert(CvDEPTH(evalcv) == 1);
4624 CvDEPTH(evalcv) = 0;
4626 /* pop the CXt_EVAL, and if a require failed, croak */
4627 S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
4635 /* Ops that implement try/catch syntax
4636 * Note the asymmetry here:
4637 * pp_entertrycatch does two pushblocks
4638 * pp_leavetrycatch pops only the outer one; the inner one is popped by
4639 * pp_poptry or by stack-unwind of die within the try block
4642 PP(pp_entertrycatch)
4645 const U8 gimme = GIMME_V;
4647 RUN_PP_CATCHABLY(Perl_pp_entertrycatch);
4651 Perl_pp_enter(aTHX); /* performs cx_pushblock(CXt_BLOCK, ...) */
4653 save_scalar(PL_errgv);
4656 cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK|CXp_TRY), gimme,
4657 PL_stack_sp, PL_savestack_ix);
4658 cx_pushtry(cx, cLOGOP->op_other);
4660 PL_in_eval = EVAL_INEVAL;
4665 PP(pp_leavetrycatch)
4667 /* leavetrycatch is leave */
4668 return Perl_pp_leave(aTHX);
4673 /* poptry is leavetry */
4674 return Perl_pp_leavetry(aTHX);
4681 save_clearsv(&(PAD_SVl(PL_op->op_targ)));
4682 sv_setsv(TARG, ERRSV);
4685 return cLOGOP->op_other;
4688 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4689 close to the related Perl_create_eval_scope. */
4691 Perl_delete_eval_scope(pTHX)
4702 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4703 also needed by Perl_fold_constants. */
4705 Perl_create_eval_scope(pTHX_ OP *retop, U32 flags)
4708 const U8 gimme = GIMME_V;
4710 cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK), gimme,
4711 PL_stack_sp, PL_savestack_ix);
4712 cx_pusheval(cx, retop, NULL);
4714 PL_in_eval = EVAL_INEVAL;
4715 if (flags & G_KEEPERR)
4716 PL_in_eval |= EVAL_KEEPERR;
4719 if (flags & G_FAKINGEVAL) {
4720 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4726 OP *retop = cLOGOP->op_other->op_next;
4728 RUN_PP_CATCHABLY(Perl_pp_entertry);
4732 create_eval_scope(retop, 0);
4734 return PL_op->op_next;
4738 /* also tail-called by pp_return */
4750 assert(CxTYPE(cx) == CXt_EVAL);
4751 oldsp = PL_stack_base + cx->blk_oldsp;
4752 gimme = cx->blk_gimme;
4754 if (gimme == G_VOID) {
4755 PL_stack_sp = oldsp;
4756 /* free now to avoid late-called destructors clobbering $@ */
4760 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4764 retop = CxTRY(cx) ? PL_op->op_next : cx->blk_eval.retop;
4775 const U8 gimme = GIMME_V;
4779 assert(!PL_op->op_targ); /* used to be set for lexical $_ */
4780 GvSV(PL_defgv) = SvREFCNT_inc(newsv);
4782 cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix);
4783 cx_pushgiven(cx, origsv);
4793 PERL_UNUSED_CONTEXT;
4796 assert(CxTYPE(cx) == CXt_GIVEN);
4797 oldsp = PL_stack_base + cx->blk_oldsp;
4798 gimme = cx->blk_gimme;
4800 if (gimme == G_VOID)
4801 PL_stack_sp = oldsp;
4803 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
4813 /* Helper routines used by pp_smartmatch */
4815 S_make_matcher(pTHX_ REGEXP *re)
4817 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4819 PERL_ARGS_ASSERT_MAKE_MATCHER;
4821 PM_SETRE(matcher, ReREFCNT_inc(re));
4823 SAVEFREEOP((OP *) matcher);
4824 ENTER_with_name("matcher"); SAVETMPS;
4830 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4835 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4837 PL_op = (OP *) matcher;
4840 (void) Perl_pp_match(aTHX);
4842 result = SvTRUEx(POPs);
4849 S_destroy_matcher(pTHX_ PMOP *matcher)
4851 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4852 PERL_UNUSED_ARG(matcher);
4855 LEAVE_with_name("matcher");
4858 /* Do a smart match */
4861 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4862 return do_smartmatch(NULL, NULL, 0);
4865 /* This version of do_smartmatch() implements the
4866 * table of smart matches that is found in perlsyn.
4869 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4873 bool object_on_left = FALSE;
4874 SV *e = TOPs; /* e is for 'expression' */
4875 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4877 /* Take care only to invoke mg_get() once for each argument.
4878 * Currently we do this by copying the SV if it's magical. */
4880 if (!copied && SvGMAGICAL(d))
4881 d = sv_mortalcopy(d);
4888 e = sv_mortalcopy(e);
4890 /* First of all, handle overload magic of the rightmost argument */
4893 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4894 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4896 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4903 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4906 SP -= 2; /* Pop the values */
4911 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4918 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4919 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4920 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4922 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4923 object_on_left = TRUE;
4926 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4928 if (object_on_left) {
4929 goto sm_any_sub; /* Treat objects like scalars */
4931 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4932 /* Test sub truth for each key */
4934 bool andedresults = TRUE;
4935 HV *hv = (HV*) SvRV(d);
4936 I32 numkeys = hv_iterinit(hv);
4937 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4940 while ( (he = hv_iternext(hv)) ) {
4941 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4942 ENTER_with_name("smartmatch_hash_key_test");
4945 PUSHs(hv_iterkeysv(he));
4947 c = call_sv(e, G_SCALAR);
4950 andedresults = FALSE;
4952 andedresults = SvTRUEx(POPs) && andedresults;
4954 LEAVE_with_name("smartmatch_hash_key_test");
4961 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4962 /* Test sub truth for each element */
4964 bool andedresults = TRUE;
4965 AV *av = (AV*) SvRV(d);
4966 const Size_t len = av_count(av);
4967 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4970 for (i = 0; i < len; ++i) {
4971 SV * const * const svp = av_fetch(av, i, FALSE);
4972 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4973 ENTER_with_name("smartmatch_array_elem_test");
4979 c = call_sv(e, G_SCALAR);
4982 andedresults = FALSE;
4984 andedresults = SvTRUEx(POPs) && andedresults;
4986 LEAVE_with_name("smartmatch_array_elem_test");
4995 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4996 ENTER_with_name("smartmatch_coderef");
5001 c = call_sv(e, G_SCALAR);
5005 else if (SvTEMP(TOPs))
5006 SvREFCNT_inc_void(TOPs);
5008 LEAVE_with_name("smartmatch_coderef");
5013 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
5014 if (object_on_left) {
5015 goto sm_any_hash; /* Treat objects like scalars */
5017 else if (!SvOK(d)) {
5018 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
5021 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5022 /* Check that the key-sets are identical */
5024 HV *other_hv = MUTABLE_HV(SvRV(d));
5027 U32 this_key_count = 0,
5028 other_key_count = 0;
5029 HV *hv = MUTABLE_HV(SvRV(e));
5031 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
5032 /* Tied hashes don't know how many keys they have. */
5033 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
5034 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
5038 HV * const temp = other_hv;
5044 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
5048 /* The hashes have the same number of keys, so it suffices
5049 to check that one is a subset of the other. */
5050 (void) hv_iterinit(hv);
5051 while ( (he = hv_iternext(hv)) ) {
5052 SV *key = hv_iterkeysv(he);
5054 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
5057 if(!hv_exists_ent(other_hv, key, 0)) {
5058 (void) hv_iterinit(hv); /* reset iterator */
5064 (void) hv_iterinit(other_hv);
5065 while ( hv_iternext(other_hv) )
5069 other_key_count = HvUSEDKEYS(other_hv);
5071 if (this_key_count != other_key_count)
5076 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5077 AV * const other_av = MUTABLE_AV(SvRV(d));
5078 const Size_t other_len = av_count(other_av);
5080 HV *hv = MUTABLE_HV(SvRV(e));
5082 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
5083 for (i = 0; i < other_len; ++i) {
5084 SV ** const svp = av_fetch(other_av, i, FALSE);
5085 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
5086 if (svp) { /* ??? When can this not happen? */
5087 if (hv_exists_ent(hv, *svp, 0))
5093 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
5094 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
5097 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
5099 HV *hv = MUTABLE_HV(SvRV(e));
5101 (void) hv_iterinit(hv);
5102 while ( (he = hv_iternext(hv)) ) {
5103 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
5105 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
5107 (void) hv_iterinit(hv);
5108 destroy_matcher(matcher);
5113 destroy_matcher(matcher);
5119 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
5120 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
5127 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
5128 if (object_on_left) {
5129 goto sm_any_array; /* Treat objects like scalars */
5131 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5132 AV * const other_av = MUTABLE_AV(SvRV(e));
5133 const Size_t other_len = av_count(other_av);
5136 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
5137 for (i = 0; i < other_len; ++i) {
5138 SV ** const svp = av_fetch(other_av, i, FALSE);
5140 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
5141 if (svp) { /* ??? When can this not happen? */
5142 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
5148 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5149 AV *other_av = MUTABLE_AV(SvRV(d));
5150 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
5151 if (av_count(MUTABLE_AV(SvRV(e))) != av_count(other_av))
5155 const Size_t other_len = av_count(other_av);
5157 if (NULL == seen_this) {
5158 seen_this = newHV();
5159 (void) sv_2mortal(MUTABLE_SV(seen_this));
5161 if (NULL == seen_other) {
5162 seen_other = newHV();
5163 (void) sv_2mortal(MUTABLE_SV(seen_other));
5165 for(i = 0; i < other_len; ++i) {
5166 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5167 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
5169 if (!this_elem || !other_elem) {
5170 if ((this_elem && SvOK(*this_elem))
5171 || (other_elem && SvOK(*other_elem)))
5174 else if (hv_exists_ent(seen_this,
5175 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
5176 hv_exists_ent(seen_other,
5177 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
5179 if (*this_elem != *other_elem)
5183 (void)hv_store_ent(seen_this,
5184 sv_2mortal(newSViv(PTR2IV(*this_elem))),
5186 (void)hv_store_ent(seen_other,
5187 sv_2mortal(newSViv(PTR2IV(*other_elem))),
5193 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
5194 (void) do_smartmatch(seen_this, seen_other, 0);
5196 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
5205 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
5206 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
5209 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
5210 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
5213 for(i = 0; i < this_len; ++i) {
5214 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5215 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
5217 if (svp && matcher_matches_sv(matcher, *svp)) {
5219 destroy_matcher(matcher);
5224 destroy_matcher(matcher);
5228 else if (!SvOK(d)) {
5229 /* undef ~~ array */
5230 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
5233 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
5234 for (i = 0; i < this_len; ++i) {
5235 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5236 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
5237 if (!svp || !SvOK(*svp))
5246 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
5248 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
5249 for (i = 0; i < this_len; ++i) {
5250 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
5257 /* infinite recursion isn't supposed to happen here */
5258 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
5259 (void) do_smartmatch(NULL, NULL, 1);
5261 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
5270 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
5271 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5272 SV *t = d; d = e; e = t;
5273 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
5276 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5277 SV *t = d; d = e; e = t;
5278 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
5279 goto sm_regex_array;
5282 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
5285 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
5287 result = matcher_matches_sv(matcher, d);
5289 PUSHs(result ? &PL_sv_yes : &PL_sv_no);
5290 destroy_matcher(matcher);
5295 /* See if there is overload magic on left */
5296 else if (object_on_left && SvAMAGIC(d)) {
5298 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
5299 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
5302 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
5310 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
5313 else if (!SvOK(d)) {
5314 /* undef ~~ scalar ; we already know that the scalar is SvOK */
5315 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
5320 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
5321 DEBUG_M(if (SvNIOK(e))
5322 Perl_deb(aTHX_ " applying rule Any-Num\n");
5324 Perl_deb(aTHX_ " applying rule Num-numish\n");
5326 /* numeric comparison */
5329 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
5330 (void) Perl_pp_i_eq(aTHX);
5332 (void) Perl_pp_eq(aTHX);
5340 /* As a last resort, use string comparison */
5341 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
5344 return Perl_pp_seq(aTHX);
5351 const U8 gimme = GIMME_V;
5353 /* This is essentially an optimization: if the match
5354 fails, we don't want to push a context and then
5355 pop it again right away, so we skip straight
5356 to the op that follows the leavewhen.
5357 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5359 if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) {
5360 if (gimme == G_SCALAR)
5361 PUSHs(&PL_sv_undef);
5362 RETURNOP(cLOGOP->op_other->op_next);
5365 cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
5379 assert(CxTYPE(cx) == CXt_WHEN);
5380 gimme = cx->blk_gimme;
5382 cxix = dopoptogivenfor(cxstack_ix);
5384 /* diag_listed_as: Can't "when" outside a topicalizer */
5385 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5386 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5388 oldsp = PL_stack_base + cx->blk_oldsp;
5389 if (gimme == G_VOID)
5390 PL_stack_sp = oldsp;
5392 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5394 /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
5395 assert(cxix < cxstack_ix);
5398 cx = &cxstack[cxix];
5400 if (CxFOREACH(cx)) {
5401 /* emulate pp_next. Note that any stack(s) cleanup will be
5402 * done by the pp_unstack which op_nextop should point to */
5405 PL_curcop = cx->blk_oldcop;
5406 return cx->blk_loop.my_op->op_nextop;
5410 assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
5411 return cx->blk_givwhen.leave_op;
5421 cxix = dopoptowhen(cxstack_ix);
5423 DIE(aTHX_ "Can't \"continue\" outside a when block");
5425 if (cxix < cxstack_ix)
5429 assert(CxTYPE(cx) == CXt_WHEN);
5430 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5434 nextop = cx->blk_givwhen.leave_op->op_next;
5445 cxix = dopoptogivenfor(cxstack_ix);
5447 DIE(aTHX_ "Can't \"break\" outside a given block");
5449 cx = &cxstack[cxix];
5451 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5453 if (cxix < cxstack_ix)
5456 /* Restore the sp at the time we entered the given block */
5458 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5460 return cx->blk_givwhen.leave_op;
5464 invoke_defer_block(pTHX_ void *_arg)
5466 OP *start = (OP *)_arg;
5468 I32 was_cxstack_ix = cxstack_ix;
5471 cx_pushblock(CXt_DEFER, G_VOID, PL_stack_sp, PL_savestack_ix);
5487 assert(CxTYPE(cx) == CXt_DEFER);
5489 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
5496 assert(cxstack_ix == was_cxstack_ix);
5501 SAVEDESTRUCTOR_X(invoke_defer_block, cLOGOP->op_other);
5507 S_doparseform(pTHX_ SV *sv)
5510 char *s = SvPV(sv, len);
5512 char *base = NULL; /* start of current field */
5513 I32 skipspaces = 0; /* number of contiguous spaces seen */
5514 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5515 bool repeat = FALSE; /* ~~ seen on this line */
5516 bool postspace = FALSE; /* a text field may need right padding */
5519 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5521 bool ischop; /* it's a ^ rather than a @ */
5522 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5523 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5527 PERL_ARGS_ASSERT_DOPARSEFORM;
5530 Perl_croak(aTHX_ "Null picture in formline");
5532 if (SvTYPE(sv) >= SVt_PVMG) {
5533 /* This might, of course, still return NULL. */
5534 mg = mg_find(sv, PERL_MAGIC_fm);
5536 sv_upgrade(sv, SVt_PVMG);
5540 /* still the same as previously-compiled string? */
5541 SV *old = mg->mg_obj;
5542 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5543 && len == SvCUR(old)
5544 && strnEQ(SvPVX(old), s, len)
5546 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5550 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5551 Safefree(mg->mg_ptr);
5557 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5558 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5561 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5562 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5566 /* estimate the buffer size needed */
5567 for (base = s; s <= send; s++) {
5568 if (*s == '\n' || *s == '@' || *s == '^')
5574 Newx(fops, maxops, U32);
5579 *fpc++ = FF_LINEMARK;
5580 noblank = repeat = FALSE;
5598 case ' ': case '\t':
5614 *fpc++ = FF_LITERAL;
5622 *fpc++ = (U32)skipspaces;
5626 *fpc++ = FF_NEWLINE;
5630 arg = fpc - linepc + 1;
5637 *fpc++ = FF_LINEMARK;
5638 noblank = repeat = FALSE;
5647 ischop = s[-1] == '^';
5653 arg = (s - base) - 1;
5655 *fpc++ = FF_LITERAL;
5661 if (*s == '*') { /* @* or ^* */
5663 *fpc++ = 2; /* skip the @* or ^* */
5665 *fpc++ = FF_LINESNGL;
5668 *fpc++ = FF_LINEGLOB;
5670 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5671 arg = ischop ? FORM_NUM_BLANK : 0;
5676 const char * const f = ++s;
5679 arg |= FORM_NUM_POINT + (s - f);
5681 *fpc++ = s - base; /* fieldsize for FETCH */
5682 *fpc++ = FF_DECIMAL;
5684 unchopnum |= ! ischop;
5686 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5687 arg = ischop ? FORM_NUM_BLANK : 0;
5689 s++; /* skip the '0' first */
5693 const char * const f = ++s;
5696 arg |= FORM_NUM_POINT + (s - f);
5698 *fpc++ = s - base; /* fieldsize for FETCH */
5699 *fpc++ = FF_0DECIMAL;
5701 unchopnum |= ! ischop;
5703 else { /* text field */
5705 bool ismore = FALSE;
5708 while (*++s == '>') ;
5709 prespace = FF_SPACE;
5711 else if (*s == '|') {
5712 while (*++s == '|') ;
5713 prespace = FF_HALFSPACE;
5718 while (*++s == '<') ;
5721 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5725 *fpc++ = s - base; /* fieldsize for FETCH */
5727 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5730 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5744 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5747 mg->mg_ptr = (char *) fops;
5748 mg->mg_len = arg * sizeof(U32);
5749 mg->mg_obj = sv_copy;
5750 mg->mg_flags |= MGf_REFCOUNTED;
5752 if (unchopnum && repeat)
5753 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5760 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5762 /* Can value be printed in fldsize chars, using %*.*f ? */
5766 int intsize = fldsize - (value < 0 ? 1 : 0);
5768 if (frcsize & FORM_NUM_POINT)
5770 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5773 while (intsize--) pwr *= 10.0;
5774 while (frcsize--) eps /= 10.0;
5777 if (value + eps >= pwr)
5780 if (value - eps <= -pwr)
5787 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5789 SV * const datasv = FILTER_DATA(idx);
5790 const int filter_has_file = IoLINES(datasv);
5791 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5792 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5797 char *prune_from = NULL;
5798 bool read_from_cache = FALSE;
5802 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5804 assert(maxlen >= 0);
5807 /* I was having segfault trouble under Linux 2.2.5 after a
5808 parse error occurred. (Had to hack around it with a test
5809 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5810 not sure where the trouble is yet. XXX */
5813 SV *const cache = datasv;
5816 const char *cache_p = SvPV(cache, cache_len);
5820 /* Running in block mode and we have some cached data already.
5822 if (cache_len >= umaxlen) {
5823 /* In fact, so much data we don't even need to call
5828 const char *const first_nl =
5829 (const char *)memchr(cache_p, '\n', cache_len);
5831 take = first_nl + 1 - cache_p;
5835 sv_catpvn(buf_sv, cache_p, take);
5836 sv_chop(cache, cache_p + take);
5837 /* Definitely not EOF */
5841 sv_catsv(buf_sv, cache);
5843 umaxlen -= cache_len;
5846 read_from_cache = TRUE;
5850 /* Filter API says that the filter appends to the contents of the buffer.
5851 Usually the buffer is "", so the details don't matter. But if it's not,
5852 then clearly what it contains is already filtered by this filter, so we
5853 don't want to pass it in a second time.
5854 I'm going to use a mortal in case the upstream filter croaks. */
5855 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5856 ? sv_newmortal() : buf_sv;
5857 SvUPGRADE(upstream, SVt_PV);
5859 if (filter_has_file) {
5860 status = FILTER_READ(idx+1, upstream, 0);
5863 if (filter_sub && status >= 0) {
5867 ENTER_with_name("call_filter_sub");
5872 DEFSV_set(upstream);
5876 PUSHs(filter_state);
5879 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5889 SV * const errsv = ERRSV;
5890 if (SvTRUE_NN(errsv))
5891 err = newSVsv(errsv);
5897 LEAVE_with_name("call_filter_sub");
5900 if (SvGMAGICAL(upstream)) {
5902 if (upstream == buf_sv) mg_free(buf_sv);
5904 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5905 if(!err && SvOK(upstream)) {
5906 got_p = SvPV_nomg(upstream, got_len);
5908 if (got_len > umaxlen) {
5909 prune_from = got_p + umaxlen;
5912 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5913 if (first_nl && first_nl + 1 < got_p + got_len) {
5914 /* There's a second line here... */
5915 prune_from = first_nl + 1;
5919 if (!err && prune_from) {
5920 /* Oh. Too long. Stuff some in our cache. */
5921 STRLEN cached_len = got_p + got_len - prune_from;
5922 SV *const cache = datasv;
5925 /* Cache should be empty. */
5926 assert(!SvCUR(cache));
5929 sv_setpvn(cache, prune_from, cached_len);
5930 /* If you ask for block mode, you may well split UTF-8 characters.
5931 "If it breaks, you get to keep both parts"
5932 (Your code is broken if you don't put them back together again
5933 before something notices.) */
5934 if (SvUTF8(upstream)) {
5937 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5939 /* Cannot just use sv_setpvn, as that could free the buffer
5940 before we have a chance to assign it. */
5941 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5942 got_len - cached_len);
5944 /* Can't yet be EOF */
5949 /* If they are at EOF but buf_sv has something in it, then they may never
5950 have touched the SV upstream, so it may be undefined. If we naively
5951 concatenate it then we get a warning about use of uninitialised value.
5953 if (!err && upstream != buf_sv &&
5955 sv_catsv_nomg(buf_sv, upstream);
5957 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5960 IoLINES(datasv) = 0;
5962 SvREFCNT_dec(filter_state);
5963 IoTOP_GV(datasv) = NULL;
5966 SvREFCNT_dec(filter_sub);
5967 IoBOTTOM_GV(datasv) = NULL;
5969 filter_del(S_run_user_filter);
5975 if (status == 0 && read_from_cache) {
5976 /* If we read some data from the cache (and by getting here it implies
5977 that we emptied the cache) then we aren't yet at EOF, and mustn't
5978 report that to our caller. */
5985 * ex: set ts=8 sts=4 sw=4 et: