3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
37 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
39 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
46 const PERL_CONTEXT *cx;
49 if (PL_op->op_private & OPpOFFBYONE) {
50 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
53 cxix = dopoptosub(cxstack_ix);
59 switch (cx->blk_gimme) {
80 PMOP *pm = (PMOP*)cLOGOP->op_other;
85 const regexp_engine *eng;
86 bool is_bare_re= FALSE;
88 if (PL_op->op_flags & OPf_STACKED) {
98 /* prevent recompiling under /o and ithreads. */
99 #if defined(USE_ITHREADS)
100 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
107 assert (re != (REGEXP*) &PL_sv_undef);
108 eng = re ? RX_ENGINE(re) : current_re_engine();
111 In the below logic: these are basically the same - check if this regcomp is part of a split.
113 (PL_op->op_pmflags & PMf_split )
114 (PL_op->op_next->op_type == OP_PUSHRE)
116 We could add a new mask for this and copy the PMf_split, if we did
117 some bit definition fiddling first.
119 For now we leave this
122 new_re = (eng->op_comp
124 : &Perl_re_op_compile
125 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
127 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
129 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
131 if (pm->op_pmflags & PMf_HAS_CV)
132 ReANY(new_re)->qr_anoncv
133 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
137 /* The match's LHS's get-magic might need to access this op's regexp
138 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
139 get-magic now before we replace the regexp. Hopefully this hack can
140 be replaced with the approach described at
141 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
143 if (pm->op_type == OP_MATCH) {
145 const bool was_tainted = TAINT_get;
146 if (pm->op_flags & OPf_STACKED)
148 else if (pm->op_private & OPpTARGET_MY)
149 lhs = PAD_SV(pm->op_targ);
152 /* Restore the previous value of PL_tainted (which may have been
153 modified by get-magic), to avoid incorrectly setting the
154 RXf_TAINTED flag with RX_TAINT_on further down. */
155 TAINT_set(was_tainted);
157 PERL_UNUSED_VAR(was_tainted);
160 tmp = reg_temp_copy(NULL, new_re);
161 ReREFCNT_dec(new_re);
167 PM_SETRE(pm, new_re);
171 #ifndef INCOMPLETE_TAINTS
172 if (TAINTING_get && TAINT_get) {
173 SvTAINTED_on((SV*)new_re);
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 (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
183 if (pm->op_pmflags & PMf_KEEP) {
184 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
185 cLOGOP->op_first->op_next = PL_op->op_next;
198 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
199 PMOP * const pm = (PMOP*) cLOGOP->op_other;
200 SV * const dstr = cx->sb_dstr;
203 char *orig = cx->sb_orig;
204 REGEXP * const rx = cx->sb_rx;
206 REGEXP *old = PM_GETRE(pm);
213 PM_SETRE(pm,ReREFCNT_inc(rx));
216 rxres_restore(&cx->sb_rxres, rx);
218 if (cx->sb_iters++) {
219 const I32 saviters = cx->sb_iters;
220 if (cx->sb_iters > cx->sb_maxiters)
221 DIE(aTHX_ "Substitution loop");
223 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
225 /* See "how taint works" above pp_subst() */
227 cx->sb_rxtainted |= SUBST_TAINT_REPL;
228 sv_catsv_nomg(dstr, POPs);
229 if (CxONCE(cx) || s < orig ||
230 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
231 (s == m), cx->sb_targ, NULL,
232 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
234 SV *targ = cx->sb_targ;
236 assert(cx->sb_strend >= s);
237 if(cx->sb_strend > s) {
238 if (DO_UTF8(dstr) && !SvUTF8(targ))
239 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
241 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
243 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
244 cx->sb_rxtainted |= SUBST_TAINT_PAT;
246 if (pm->op_pmflags & PMf_NONDESTRUCT) {
248 /* From here on down we're using the copy, and leaving the
249 original untouched. */
253 SV_CHECK_THINKFIRST_COW_DROP(targ);
254 if (isGV(targ)) Perl_croak_no_modify();
256 SvPV_set(targ, SvPVX(dstr));
257 SvCUR_set(targ, SvCUR(dstr));
258 SvLEN_set(targ, SvLEN(dstr));
261 SvPV_set(dstr, NULL);
264 mPUSHi(saviters - 1);
266 (void)SvPOK_only_UTF8(targ);
269 /* update the taint state of various various variables in
270 * preparation for final exit.
271 * See "how taint works" above pp_subst() */
273 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
274 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
275 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
277 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
279 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
280 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
282 SvTAINTED_on(TOPs); /* taint return value */
283 /* needed for mg_set below */
285 cBOOL(cx->sb_rxtainted &
286 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
290 /* PL_tainted must be correctly set for this mg_set */
293 LEAVE_SCOPE(cx->sb_oldsave);
296 RETURNOP(pm->op_next);
297 assert(0); /* NOTREACHED */
299 cx->sb_iters = saviters;
301 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
304 assert(!RX_SUBOFFSET(rx));
305 cx->sb_orig = orig = RX_SUBBEG(rx);
307 cx->sb_strend = s + (cx->sb_strend - m);
309 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
311 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
312 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
314 sv_catpvn_nomg(dstr, s, m-s);
316 cx->sb_s = RX_OFFS(rx)[0].end + orig;
317 { /* Update the pos() information. */
319 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
321 if (!(mg = mg_find_mglob(sv))) {
322 mg = sv_magicext_mglob(sv);
325 MgBYTEPOS_set(mg, sv, SvPVX(dstr), m - orig);
328 (void)ReREFCNT_inc(rx);
329 /* update the taint state of various various variables in preparation
330 * for calling the code block.
331 * See "how taint works" above pp_subst() */
333 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
334 cx->sb_rxtainted |= SUBST_TAINT_PAT;
336 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
337 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
338 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
340 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
342 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
343 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
344 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
345 ? cx->sb_dstr : cx->sb_targ);
348 rxres_save(&cx->sb_rxres, rx);
350 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
354 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
359 PERL_ARGS_ASSERT_RXRES_SAVE;
362 if (!p || p[1] < RX_NPARENS(rx)) {
364 i = 7 + (RX_NPARENS(rx)+1) * 2;
366 i = 6 + (RX_NPARENS(rx)+1) * 2;
375 /* what (if anything) to free on croak */
376 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
377 RX_MATCH_COPIED_off(rx);
378 *p++ = RX_NPARENS(rx);
381 *p++ = PTR2UV(RX_SAVED_COPY(rx));
382 RX_SAVED_COPY(rx) = NULL;
385 *p++ = PTR2UV(RX_SUBBEG(rx));
386 *p++ = (UV)RX_SUBLEN(rx);
387 *p++ = (UV)RX_SUBOFFSET(rx);
388 *p++ = (UV)RX_SUBCOFFSET(rx);
389 for (i = 0; i <= RX_NPARENS(rx); ++i) {
390 *p++ = (UV)RX_OFFS(rx)[i].start;
391 *p++ = (UV)RX_OFFS(rx)[i].end;
396 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
401 PERL_ARGS_ASSERT_RXRES_RESTORE;
404 RX_MATCH_COPY_FREE(rx);
405 RX_MATCH_COPIED_set(rx, *p);
407 RX_NPARENS(rx) = *p++;
410 if (RX_SAVED_COPY(rx))
411 SvREFCNT_dec (RX_SAVED_COPY(rx));
412 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
416 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
417 RX_SUBLEN(rx) = (I32)(*p++);
418 RX_SUBOFFSET(rx) = (I32)*p++;
419 RX_SUBCOFFSET(rx) = (I32)*p++;
420 for (i = 0; i <= RX_NPARENS(rx); ++i) {
421 RX_OFFS(rx)[i].start = (I32)(*p++);
422 RX_OFFS(rx)[i].end = (I32)(*p++);
427 S_rxres_free(pTHX_ void **rsp)
429 UV * const p = (UV*)*rsp;
431 PERL_ARGS_ASSERT_RXRES_FREE;
435 void *tmp = INT2PTR(char*,*p);
438 U32 i = 9 + p[1] * 2;
440 U32 i = 8 + p[1] * 2;
445 SvREFCNT_dec (INT2PTR(SV*,p[2]));
448 PoisonFree(p, i, sizeof(UV));
457 #define FORM_NUM_BLANK (1<<30)
458 #define FORM_NUM_POINT (1<<29)
462 dVAR; dSP; dMARK; dORIGMARK;
463 SV * const tmpForm = *++MARK;
464 SV *formsv; /* contains text of original format */
465 U32 *fpc; /* format ops program counter */
466 char *t; /* current append position in target string */
467 const char *f; /* current position in format string */
469 SV *sv = NULL; /* current item */
470 const char *item = NULL;/* string value of current item */
471 I32 itemsize = 0; /* length of current item, possibly truncated */
472 I32 fieldsize = 0; /* width of current field */
473 I32 lines = 0; /* number of lines that have been output */
474 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
475 const char *chophere = NULL; /* where to chop current item */
476 STRLEN linemark = 0; /* pos of start of line in output */
478 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
480 STRLEN linemax; /* estimate of output size in bytes */
481 bool item_is_utf8 = FALSE;
482 bool targ_is_utf8 = FALSE;
485 U8 *source; /* source of bytes to append */
486 STRLEN to_copy; /* how may bytes to append */
487 char trans; /* what chars to translate */
489 mg = doparseform(tmpForm);
491 fpc = (U32*)mg->mg_ptr;
492 /* the actual string the format was compiled from.
493 * with overload etc, this may not match tmpForm */
497 SvPV_force(PL_formtarget, len);
498 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
499 SvTAINTED_on(PL_formtarget);
500 if (DO_UTF8(PL_formtarget))
502 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
503 t = SvGROW(PL_formtarget, len + linemax + 1);
504 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
506 f = SvPV_const(formsv, len);
510 const char *name = "???";
513 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
514 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
515 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
516 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
517 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
519 case FF_CHECKNL: name = "CHECKNL"; break;
520 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
521 case FF_SPACE: name = "SPACE"; break;
522 case FF_HALFSPACE: name = "HALFSPACE"; break;
523 case FF_ITEM: name = "ITEM"; break;
524 case FF_CHOP: name = "CHOP"; break;
525 case FF_LINEGLOB: name = "LINEGLOB"; break;
526 case FF_NEWLINE: name = "NEWLINE"; break;
527 case FF_MORE: name = "MORE"; break;
528 case FF_LINEMARK: name = "LINEMARK"; break;
529 case FF_END: name = "END"; break;
530 case FF_0DECIMAL: name = "0DECIMAL"; break;
531 case FF_LINESNGL: name = "LINESNGL"; break;
534 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
536 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
540 linemark = t - SvPVX(PL_formtarget);
550 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
566 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
569 SvTAINTED_on(PL_formtarget);
575 const char *s = item = SvPV_const(sv, len);
578 itemsize = sv_len_utf8(sv);
579 if (itemsize != (I32)len) {
581 if (itemsize > fieldsize) {
582 itemsize = fieldsize;
583 itembytes = itemsize;
584 sv_pos_u2b(sv, &itembytes, 0);
588 send = chophere = s + itembytes;
598 sv_pos_b2u(sv, &itemsize);
602 item_is_utf8 = FALSE;
603 if (itemsize > fieldsize)
604 itemsize = fieldsize;
605 send = chophere = s + itemsize;
619 const char *s = item = SvPV_const(sv, len);
622 itemsize = sv_len_utf8(sv);
623 if (itemsize != (I32)len) {
625 if (itemsize <= fieldsize) {
626 const char *send = chophere = s + itemsize;
639 itemsize = fieldsize;
640 itembytes = itemsize;
641 sv_pos_u2b(sv, &itembytes, 0);
642 send = chophere = s + itembytes;
643 while (s < send || (s == send && isSPACE(*s))) {
653 if (strchr(PL_chopset, *s))
658 itemsize = chophere - item;
659 sv_pos_b2u(sv, &itemsize);
665 item_is_utf8 = FALSE;
666 if (itemsize <= fieldsize) {
667 const char *const send = chophere = s + itemsize;
680 itemsize = fieldsize;
681 send = chophere = s + itemsize;
682 while (s < send || (s == send && isSPACE(*s))) {
692 if (strchr(PL_chopset, *s))
697 itemsize = chophere - item;
703 arg = fieldsize - itemsize;
712 arg = fieldsize - itemsize;
726 /* convert to_copy from chars to bytes */
730 to_copy = s - source;
736 const char *s = chophere;
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 - SvPVX_const(sv) - 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);
792 if (item_is_utf8 && !targ_is_utf8) {
794 /* Upgrade targ to UTF8, and then we reduce it to
795 a problem we have a simple solution for.
796 Don't need get magic. */
797 sv_utf8_upgrade_nomg(PL_formtarget);
799 /* re-calculate linemark */
800 s = (U8*)SvPVX(PL_formtarget);
801 /* the bytes we initially allocated to append the
802 * whole line may have been gobbled up during the
803 * upgrade, so allocate a whole new line's worth
808 linemark = s - (U8*)SvPVX(PL_formtarget);
810 /* Easy. They agree. */
811 assert (item_is_utf8 == targ_is_utf8);
814 /* @* and ^* are the only things that can exceed
815 * the linemax, so grow by the output size, plus
816 * a whole new form's worth in case of any further
818 grow = linemax + to_copy;
820 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
821 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
823 Copy(source, t, to_copy, char);
825 /* blank out ~ or control chars, depending on trans.
826 * works on bytes not chars, so relies on not
827 * matching utf8 continuation bytes */
829 U8 *send = s + to_copy;
832 if (trans == '~' ? (ch == '~') :
845 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
853 #if defined(USE_LONG_DOUBLE)
855 ((arg & FORM_NUM_POINT) ?
856 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
859 ((arg & FORM_NUM_POINT) ?
860 "%#0*.*f" : "%0*.*f");
865 #if defined(USE_LONG_DOUBLE)
867 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
870 ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
873 /* If the field is marked with ^ and the value is undefined,
875 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
883 /* overflow evidence */
884 if (num_overflow(value, fieldsize, arg)) {
890 /* Formats aren't yet marked for locales, so assume "yes". */
892 STORE_NUMERIC_STANDARD_SET_LOCAL();
893 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
894 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
895 RESTORE_NUMERIC_STANDARD();
902 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
910 if (arg) { /* repeat until fields exhausted? */
916 t = SvPVX(PL_formtarget) + linemark;
923 const char *s = chophere;
924 const char *send = item + len;
926 while (isSPACE(*s) && (s < send))
931 arg = fieldsize - itemsize;
938 if (strnEQ(s1," ",3)) {
939 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
950 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
952 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
954 SvUTF8_on(PL_formtarget);
955 FmLINES(PL_formtarget) += lines;
957 if (fpc[-1] == FF_BLANK)
958 RETURNOP(cLISTOP->op_first);
970 if (PL_stack_base + *PL_markstack_ptr == SP) {
972 if (GIMME_V == G_SCALAR)
974 RETURNOP(PL_op->op_next->op_next);
976 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
977 Perl_pp_pushmark(aTHX); /* push dst */
978 Perl_pp_pushmark(aTHX); /* push src */
979 ENTER_with_name("grep"); /* enter outer scope */
982 if (PL_op->op_private & OPpGREP_LEX)
983 SAVESPTR(PAD_SVl(PL_op->op_targ));
986 ENTER_with_name("grep_item"); /* enter inner scope */
989 src = PL_stack_base[*PL_markstack_ptr];
990 if (SvPADTMP(src) && !IS_PADGV(src)) {
991 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
995 if (PL_op->op_private & OPpGREP_LEX)
996 PAD_SVl(PL_op->op_targ) = src;
1001 if (PL_op->op_type == OP_MAPSTART)
1002 Perl_pp_pushmark(aTHX); /* push top */
1003 return ((LOGOP*)PL_op->op_next)->op_other;
1009 const I32 gimme = GIMME_V;
1010 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1016 /* first, move source pointer to the next item in the source list */
1017 ++PL_markstack_ptr[-1];
1019 /* if there are new items, push them into the destination list */
1020 if (items && gimme != G_VOID) {
1021 /* might need to make room back there first */
1022 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1023 /* XXX this implementation is very pessimal because the stack
1024 * is repeatedly extended for every set of items. Is possible
1025 * to do this without any stack extension or copying at all
1026 * by maintaining a separate list over which the map iterates
1027 * (like foreach does). --gsar */
1029 /* everything in the stack after the destination list moves
1030 * towards the end the stack by the amount of room needed */
1031 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1033 /* items to shift up (accounting for the moved source pointer) */
1034 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1036 /* This optimization is by Ben Tilly and it does
1037 * things differently from what Sarathy (gsar)
1038 * is describing. The downside of this optimization is
1039 * that leaves "holes" (uninitialized and hopefully unused areas)
1040 * to the Perl stack, but on the other hand this
1041 * shouldn't be a problem. If Sarathy's idea gets
1042 * implemented, this optimization should become
1043 * irrelevant. --jhi */
1045 shift = count; /* Avoid shifting too often --Ben Tilly */
1049 dst = (SP += shift);
1050 PL_markstack_ptr[-1] += shift;
1051 *PL_markstack_ptr += shift;
1055 /* copy the new items down to the destination list */
1056 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1057 if (gimme == G_ARRAY) {
1058 /* add returned items to the collection (making mortal copies
1059 * if necessary), then clear the current temps stack frame
1060 * *except* for those items. We do this splicing the items
1061 * into the start of the tmps frame (so some items may be on
1062 * the tmps stack twice), then moving PL_tmps_floor above
1063 * them, then freeing the frame. That way, the only tmps that
1064 * accumulate over iterations are the return values for map.
1065 * We have to do to this way so that everything gets correctly
1066 * freed if we die during the map.
1070 /* make space for the slice */
1071 EXTEND_MORTAL(items);
1072 tmpsbase = PL_tmps_floor + 1;
1073 Move(PL_tmps_stack + tmpsbase,
1074 PL_tmps_stack + tmpsbase + items,
1075 PL_tmps_ix - PL_tmps_floor,
1077 PL_tmps_ix += items;
1082 sv = sv_mortalcopy(sv);
1084 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1086 /* clear the stack frame except for the items */
1087 PL_tmps_floor += items;
1089 /* FREETMPS may have cleared the TEMP flag on some of the items */
1092 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1095 /* scalar context: we don't care about which values map returns
1096 * (we use undef here). And so we certainly don't want to do mortal
1097 * copies of meaningless values. */
1098 while (items-- > 0) {
1100 *dst-- = &PL_sv_undef;
1108 LEAVE_with_name("grep_item"); /* exit inner scope */
1111 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1113 (void)POPMARK; /* pop top */
1114 LEAVE_with_name("grep"); /* exit outer scope */
1115 (void)POPMARK; /* pop src */
1116 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1117 (void)POPMARK; /* pop dst */
1118 SP = PL_stack_base + POPMARK; /* pop original mark */
1119 if (gimme == G_SCALAR) {
1120 if (PL_op->op_private & OPpGREP_LEX) {
1121 SV* sv = sv_newmortal();
1122 sv_setiv(sv, items);
1130 else if (gimme == G_ARRAY)
1137 ENTER_with_name("grep_item"); /* enter inner scope */
1140 /* set $_ to the new source item */
1141 src = PL_stack_base[PL_markstack_ptr[-1]];
1142 if (SvPADTMP(src) && !IS_PADGV(src)) src = sv_mortalcopy(src);
1144 if (PL_op->op_private & OPpGREP_LEX)
1145 PAD_SVl(PL_op->op_targ) = src;
1149 RETURNOP(cLOGOP->op_other);
1158 if (GIMME == G_ARRAY)
1160 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1161 return cLOGOP->op_other;
1171 if (GIMME == G_ARRAY) {
1172 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1176 SV * const targ = PAD_SV(PL_op->op_targ);
1179 if (PL_op->op_private & OPpFLIP_LINENUM) {
1180 if (GvIO(PL_last_in_gv)) {
1181 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1184 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1186 flip = SvIV(sv) == SvIV(GvSV(gv));
1192 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1193 if (PL_op->op_flags & OPf_SPECIAL) {
1201 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1204 sv_setpvs(TARG, "");
1210 /* This code tries to decide if "$left .. $right" should use the
1211 magical string increment, or if the range is numeric (we make
1212 an exception for .."0" [#18165]). AMS 20021031. */
1214 #define RANGE_IS_NUMERIC(left,right) ( \
1215 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1216 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1217 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1218 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1219 && (!SvOK(right) || looks_like_number(right))))
1225 if (GIMME == G_ARRAY) {
1231 if (RANGE_IS_NUMERIC(left,right)) {
1234 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1235 (SvOK(right) && (SvIOK(right)
1236 ? SvIsUV(right) && SvUV(right) > IV_MAX
1237 : SvNV_nomg(right) > IV_MAX)))
1238 DIE(aTHX_ "Range iterator outside integer range");
1239 i = SvIV_nomg(left);
1240 max = SvIV_nomg(right);
1243 if (j > SSize_t_MAX)
1244 Perl_croak(aTHX_ "Out of memory during list extend");
1251 SV * const sv = sv_2mortal(newSViv(i++));
1257 const char * const lpv = SvPV_nomg_const(left, llen);
1258 const char * const tmps = SvPV_nomg_const(right, len);
1260 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1261 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1263 if (strEQ(SvPVX_const(sv),tmps))
1265 sv = sv_2mortal(newSVsv(sv));
1272 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1276 if (PL_op->op_private & OPpFLIP_LINENUM) {
1277 if (GvIO(PL_last_in_gv)) {
1278 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1281 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1282 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1290 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1291 sv_catpvs(targ, "E0");
1301 static const char * const context_name[] = {
1303 NULL, /* CXt_WHEN never actually needs "block" */
1304 NULL, /* CXt_BLOCK never actually needs "block" */
1305 NULL, /* CXt_GIVEN never actually needs "block" */
1306 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1307 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1308 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1309 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1317 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1322 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1324 for (i = cxstack_ix; i >= 0; i--) {
1325 const PERL_CONTEXT * const cx = &cxstack[i];
1326 switch (CxTYPE(cx)) {
1332 /* diag_listed_as: Exiting subroutine via %s */
1333 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1334 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1335 if (CxTYPE(cx) == CXt_NULL)
1338 case CXt_LOOP_LAZYIV:
1339 case CXt_LOOP_LAZYSV:
1341 case CXt_LOOP_PLAIN:
1343 STRLEN cx_label_len = 0;
1344 U32 cx_label_flags = 0;
1345 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1347 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1350 (const U8*)cx_label, cx_label_len,
1351 (const U8*)label, len) == 0)
1353 (const U8*)label, len,
1354 (const U8*)cx_label, cx_label_len) == 0)
1355 : (len == cx_label_len && ((cx_label == label)
1356 || memEQ(cx_label, label, len))) )) {
1357 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1358 (long)i, cx_label));
1361 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1372 Perl_dowantarray(pTHX)
1375 const I32 gimme = block_gimme();
1376 return (gimme == G_VOID) ? G_SCALAR : gimme;
1380 Perl_block_gimme(pTHX)
1383 const I32 cxix = dopoptosub(cxstack_ix);
1387 switch (cxstack[cxix].blk_gimme) {
1395 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1396 assert(0); /* NOTREACHED */
1402 Perl_is_lvalue_sub(pTHX)
1405 const I32 cxix = dopoptosub(cxstack_ix);
1406 assert(cxix >= 0); /* We should only be called from inside subs */
1408 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1409 return CxLVAL(cxstack + cxix);
1414 /* only used by PUSHSUB */
1416 Perl_was_lvalue_sub(pTHX)
1419 const I32 cxix = dopoptosub(cxstack_ix-1);
1420 assert(cxix >= 0); /* We should only be called from inside subs */
1422 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1423 return CxLVAL(cxstack + cxix);
1429 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1434 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1436 for (i = startingblock; i >= 0; i--) {
1437 const PERL_CONTEXT * const cx = &cxstk[i];
1438 switch (CxTYPE(cx)) {
1442 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1443 * twice; the first for the normal foo() call, and the second
1444 * for a faked up re-entry into the sub to execute the
1445 * code block. Hide this faked entry from the world. */
1446 if (cx->cx_type & CXp_SUB_RE_FAKE)
1450 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1458 S_dopoptoeval(pTHX_ I32 startingblock)
1462 for (i = startingblock; i >= 0; i--) {
1463 const PERL_CONTEXT *cx = &cxstack[i];
1464 switch (CxTYPE(cx)) {
1468 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1476 S_dopoptoloop(pTHX_ I32 startingblock)
1480 for (i = startingblock; i >= 0; i--) {
1481 const PERL_CONTEXT * const cx = &cxstack[i];
1482 switch (CxTYPE(cx)) {
1488 /* diag_listed_as: Exiting subroutine via %s */
1489 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1490 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1491 if ((CxTYPE(cx)) == CXt_NULL)
1494 case CXt_LOOP_LAZYIV:
1495 case CXt_LOOP_LAZYSV:
1497 case CXt_LOOP_PLAIN:
1498 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1506 S_dopoptogiven(pTHX_ I32 startingblock)
1510 for (i = startingblock; i >= 0; i--) {
1511 const PERL_CONTEXT *cx = &cxstack[i];
1512 switch (CxTYPE(cx)) {
1516 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1518 case CXt_LOOP_PLAIN:
1519 assert(!CxFOREACHDEF(cx));
1521 case CXt_LOOP_LAZYIV:
1522 case CXt_LOOP_LAZYSV:
1524 if (CxFOREACHDEF(cx)) {
1525 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1534 S_dopoptowhen(pTHX_ I32 startingblock)
1538 for (i = startingblock; i >= 0; i--) {
1539 const PERL_CONTEXT *cx = &cxstack[i];
1540 switch (CxTYPE(cx)) {
1544 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1552 Perl_dounwind(pTHX_ I32 cxix)
1557 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1560 while (cxstack_ix > cxix) {
1562 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1563 DEBUG_CX("UNWIND"); \
1564 /* Note: we don't need to restore the base context info till the end. */
1565 switch (CxTYPE(cx)) {
1568 continue; /* not break */
1576 case CXt_LOOP_LAZYIV:
1577 case CXt_LOOP_LAZYSV:
1579 case CXt_LOOP_PLAIN:
1590 PERL_UNUSED_VAR(optype);
1594 Perl_qerror(pTHX_ SV *err)
1598 PERL_ARGS_ASSERT_QERROR;
1601 if (PL_in_eval & EVAL_KEEPERR) {
1602 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1606 sv_catsv(ERRSV, err);
1609 sv_catsv(PL_errors, err);
1611 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1613 ++PL_parser->error_count;
1617 Perl_die_unwind(pTHX_ SV *msv)
1620 SV *exceptsv = sv_mortalcopy(msv);
1621 U8 in_eval = PL_in_eval;
1622 PERL_ARGS_ASSERT_DIE_UNWIND;
1629 * Historically, perl used to set ERRSV ($@) early in the die
1630 * process and rely on it not getting clobbered during unwinding.
1631 * That sucked, because it was liable to get clobbered, so the
1632 * setting of ERRSV used to emit the exception from eval{} has
1633 * been moved to much later, after unwinding (see just before
1634 * JMPENV_JUMP below). However, some modules were relying on the
1635 * early setting, by examining $@ during unwinding to use it as
1636 * a flag indicating whether the current unwinding was caused by
1637 * an exception. It was never a reliable flag for that purpose,
1638 * being totally open to false positives even without actual
1639 * clobberage, but was useful enough for production code to
1640 * semantically rely on it.
1642 * We'd like to have a proper introspective interface that
1643 * explicitly describes the reason for whatever unwinding
1644 * operations are currently in progress, so that those modules
1645 * work reliably and $@ isn't further overloaded. But we don't
1646 * have one yet. In its absence, as a stopgap measure, ERRSV is
1647 * now *additionally* set here, before unwinding, to serve as the
1648 * (unreliable) flag that it used to.
1650 * This behaviour is temporary, and should be removed when a
1651 * proper way to detect exceptional unwinding has been developed.
1652 * As of 2010-12, the authors of modules relying on the hack
1653 * are aware of the issue, because the modules failed on
1654 * perls 5.13.{1..7} which had late setting of $@ without this
1655 * early-setting hack.
1657 if (!(in_eval & EVAL_KEEPERR)) {
1658 SvTEMP_off(exceptsv);
1659 sv_setsv(ERRSV, exceptsv);
1662 if (in_eval & EVAL_KEEPERR) {
1663 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1667 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1668 && PL_curstackinfo->si_prev)
1680 JMPENV *restartjmpenv;
1683 if (cxix < cxstack_ix)
1686 POPBLOCK(cx,PL_curpm);
1687 if (CxTYPE(cx) != CXt_EVAL) {
1689 const char* message = SvPVx_const(exceptsv, msglen);
1690 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1691 PerlIO_write(Perl_error_log, message, msglen);
1695 namesv = cx->blk_eval.old_namesv;
1696 oldcop = cx->blk_oldcop;
1697 restartjmpenv = cx->blk_eval.cur_top_env;
1698 restartop = cx->blk_eval.retop;
1700 if (gimme == G_SCALAR)
1701 *++newsp = &PL_sv_undef;
1702 PL_stack_sp = newsp;
1706 /* LEAVE could clobber PL_curcop (see save_re_context())
1707 * XXX it might be better to find a way to avoid messing with
1708 * PL_curcop in save_re_context() instead, but this is a more
1709 * minimal fix --GSAR */
1712 if (optype == OP_REQUIRE) {
1713 (void)hv_store(GvHVn(PL_incgv),
1714 SvPVX_const(namesv),
1715 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1717 /* note that unlike pp_entereval, pp_require isn't
1718 * supposed to trap errors. So now that we've popped the
1719 * EVAL that pp_require pushed, and processed the error
1720 * message, rethrow the error */
1721 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1722 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1725 if (!(in_eval & EVAL_KEEPERR))
1726 sv_setsv(ERRSV, exceptsv);
1727 PL_restartjmpenv = restartjmpenv;
1728 PL_restartop = restartop;
1730 assert(0); /* NOTREACHED */
1734 write_to_stderr(exceptsv);
1736 assert(0); /* NOTREACHED */
1741 dVAR; dSP; dPOPTOPssrl;
1742 if (SvTRUE(left) != SvTRUE(right))
1749 =for apidoc caller_cx
1751 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1752 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1753 information returned to Perl by C<caller>. Note that XSUBs don't get a
1754 stack frame, so C<caller_cx(0, NULL)> will return information for the
1755 immediately-surrounding Perl code.
1757 This function skips over the automatic calls to C<&DB::sub> made on the
1758 behalf of the debugger. If the stack frame requested was a sub called by
1759 C<DB::sub>, the return value will be the frame for the call to
1760 C<DB::sub>, since that has the correct line number/etc. for the call
1761 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1762 frame for the sub call itself.
1767 const PERL_CONTEXT *
1768 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1770 I32 cxix = dopoptosub(cxstack_ix);
1771 const PERL_CONTEXT *cx;
1772 const PERL_CONTEXT *ccstack = cxstack;
1773 const PERL_SI *top_si = PL_curstackinfo;
1776 /* we may be in a higher stacklevel, so dig down deeper */
1777 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1778 top_si = top_si->si_prev;
1779 ccstack = top_si->si_cxstack;
1780 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1784 /* caller() should not report the automatic calls to &DB::sub */
1785 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1786 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1790 cxix = dopoptosub_at(ccstack, cxix - 1);
1793 cx = &ccstack[cxix];
1794 if (dbcxp) *dbcxp = cx;
1796 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1797 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1798 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1799 field below is defined for any cx. */
1800 /* caller() should not report the automatic calls to &DB::sub */
1801 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1802 cx = &ccstack[dbcxix];
1812 const PERL_CONTEXT *cx;
1813 const PERL_CONTEXT *dbcx;
1815 const HEK *stash_hek;
1817 bool has_arg = MAXARG && TOPs;
1825 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1827 if (GIMME != G_ARRAY) {
1835 assert(CopSTASH(cx->blk_oldcop));
1836 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1837 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1839 if (GIMME != G_ARRAY) {
1842 PUSHs(&PL_sv_undef);
1845 sv_sethek(TARG, stash_hek);
1854 PUSHs(&PL_sv_undef);
1857 sv_sethek(TARG, stash_hek);
1860 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1861 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1864 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1865 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1866 /* So is ccstack[dbcxix]. */
1867 if (cvgv && isGV(cvgv)) {
1868 SV * const sv = newSV(0);
1869 gv_efullname3(sv, cvgv, NULL);
1871 PUSHs(boolSV(CxHASARGS(cx)));
1874 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1875 PUSHs(boolSV(CxHASARGS(cx)));
1879 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1882 gimme = (I32)cx->blk_gimme;
1883 if (gimme == G_VOID)
1884 PUSHs(&PL_sv_undef);
1886 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1887 if (CxTYPE(cx) == CXt_EVAL) {
1889 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1890 PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
1891 SvCUR(cx->blk_eval.cur_text)-2,
1892 SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
1896 else if (cx->blk_eval.old_namesv) {
1897 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1900 /* eval BLOCK (try blocks have old_namesv == 0) */
1902 PUSHs(&PL_sv_undef);
1903 PUSHs(&PL_sv_undef);
1907 PUSHs(&PL_sv_undef);
1908 PUSHs(&PL_sv_undef);
1910 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1911 && CopSTASH_eq(PL_curcop, PL_debstash))
1913 AV * const ary = cx->blk_sub.argarray;
1914 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1916 Perl_init_dbargs(aTHX);
1918 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1919 av_extend(PL_dbargs, AvFILLp(ary) + off);
1920 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1921 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1923 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1926 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1928 if (old_warnings == pWARN_NONE)
1929 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1930 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1931 mask = &PL_sv_undef ;
1932 else if (old_warnings == pWARN_ALL ||
1933 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1934 /* Get the bit mask for $warnings::Bits{all}, because
1935 * it could have been extended by warnings::register */
1937 HV * const bits = get_hv("warnings::Bits", 0);
1938 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1939 mask = newSVsv(*bits_all);
1942 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1946 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1950 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1951 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1962 if (MAXARG < 1 || (!TOPs && !POPs))
1963 tmps = NULL, len = 0;
1965 tmps = SvPVx_const(POPs, len);
1966 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1971 /* like pp_nextstate, but used instead when the debugger is active */
1976 PL_curcop = (COP*)PL_op;
1977 TAINT_NOT; /* Each statement is presumed innocent */
1978 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1983 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1984 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1988 const I32 gimme = G_ARRAY;
1990 GV * const gv = PL_DBgv;
1993 if (gv && isGV_with_GP(gv))
1996 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1997 DIE(aTHX_ "No DB::DB routine defined");
1999 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2000 /* don't do recursive DB::DB call */
2014 (void)(*CvXSUB(cv))(aTHX_ cv);
2020 PUSHBLOCK(cx, CXt_SUB, SP);
2022 cx->blk_sub.retop = PL_op->op_next;
2024 if (CvDEPTH(cv) >= 2) {
2025 PERL_STACK_OVERFLOW_CHECK();
2026 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2029 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2030 RETURNOP(CvSTART(cv));
2038 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
2041 PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2043 if (flags & SVs_PADTMP) {
2044 flags &= ~SVs_PADTMP;
2047 if (gimme == G_SCALAR) {
2049 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2050 ? *SP : sv_mortalcopy(*SP);
2052 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2055 *++MARK = &PL_sv_undef;
2059 else if (gimme == G_ARRAY) {
2060 /* in case LEAVE wipes old return values */
2061 while (++MARK <= SP) {
2062 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2065 *++newsp = sv_mortalcopy(*MARK);
2066 TAINT_NOT; /* Each item is independent */
2069 /* When this function was called with MARK == newsp, we reach this
2070 * point with SP == newsp. */
2080 I32 gimme = GIMME_V;
2082 ENTER_with_name("block");
2085 PUSHBLOCK(cx, CXt_BLOCK, SP);
2098 if (PL_op->op_flags & OPf_SPECIAL) {
2099 cx = &cxstack[cxstack_ix];
2100 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2105 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2108 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
2109 PL_curpm = newpm; /* Don't pop $1 et al till now */
2111 LEAVE_with_name("block");
2120 const I32 gimme = GIMME_V;
2121 void *itervar; /* location of the iteration variable */
2122 U8 cxtype = CXt_LOOP_FOR;
2124 ENTER_with_name("loop1");
2127 if (PL_op->op_targ) { /* "my" variable */
2128 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2129 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2130 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2131 SVs_PADSTALE, SVs_PADSTALE);
2133 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2135 itervar = PL_comppad;
2137 itervar = &PAD_SVl(PL_op->op_targ);
2140 else { /* symbol table variable */
2141 GV * const gv = MUTABLE_GV(POPs);
2142 SV** svp = &GvSV(gv);
2143 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2145 itervar = (void *)gv;
2148 if (PL_op->op_private & OPpITER_DEF)
2149 cxtype |= CXp_FOR_DEF;
2151 ENTER_with_name("loop2");
2153 PUSHBLOCK(cx, cxtype, SP);
2154 PUSHLOOP_FOR(cx, itervar, MARK);
2155 if (PL_op->op_flags & OPf_STACKED) {
2156 SV *maybe_ary = POPs;
2157 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2159 SV * const right = maybe_ary;
2162 if (RANGE_IS_NUMERIC(sv,right)) {
2163 cx->cx_type &= ~CXTYPEMASK;
2164 cx->cx_type |= CXt_LOOP_LAZYIV;
2165 /* Make sure that no-one re-orders cop.h and breaks our
2167 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2168 #ifdef NV_PRESERVES_UV
2169 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2170 (SvNV_nomg(sv) > (NV)IV_MAX)))
2172 (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2173 (SvNV_nomg(right) < (NV)IV_MIN))))
2175 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
2177 ((SvNV_nomg(sv) > 0) &&
2178 ((SvUV_nomg(sv) > (UV)IV_MAX) ||
2179 (SvNV_nomg(sv) > (NV)UV_MAX)))))
2181 (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
2183 ((SvNV_nomg(right) > 0) &&
2184 ((SvUV_nomg(right) > (UV)IV_MAX) ||
2185 (SvNV_nomg(right) > (NV)UV_MAX))
2188 DIE(aTHX_ "Range iterator outside integer range");
2189 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2190 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2192 /* for correct -Dstv display */
2193 cx->blk_oldsp = sp - PL_stack_base;
2197 cx->cx_type &= ~CXTYPEMASK;
2198 cx->cx_type |= CXt_LOOP_LAZYSV;
2199 /* Make sure that no-one re-orders cop.h and breaks our
2201 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2202 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2203 cx->blk_loop.state_u.lazysv.end = right;
2204 SvREFCNT_inc(right);
2205 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2206 /* This will do the upgrade to SVt_PV, and warn if the value
2207 is uninitialised. */
2208 (void) SvPV_nolen_const(right);
2209 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2210 to replace !SvOK() with a pointer to "". */
2212 SvREFCNT_dec(right);
2213 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2217 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2218 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2219 SvREFCNT_inc(maybe_ary);
2220 cx->blk_loop.state_u.ary.ix =
2221 (PL_op->op_private & OPpITER_REVERSED) ?
2222 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2226 else { /* iterating over items on the stack */
2227 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2228 if (PL_op->op_private & OPpITER_REVERSED) {
2229 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2232 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2243 const I32 gimme = GIMME_V;
2245 ENTER_with_name("loop1");
2247 ENTER_with_name("loop2");
2249 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2250 PUSHLOOP_PLAIN(cx, SP);
2265 assert(CxTYPE_is_LOOP(cx));
2267 newsp = PL_stack_base + cx->blk_loop.resetsp;
2270 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
2273 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2274 PL_curpm = newpm; /* ... and pop $1 et al */
2276 LEAVE_with_name("loop2");
2277 LEAVE_with_name("loop1");
2283 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2284 PERL_CONTEXT *cx, PMOP *newpm)
2286 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2287 if (gimme == G_SCALAR) {
2288 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2290 const char *what = NULL;
2292 assert(MARK+1 == SP);
2293 if ((SvPADTMP(TOPs) ||
2294 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2297 !SvSMAGICAL(TOPs)) {
2299 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2300 : "a readonly value" : "a temporary";
2305 /* sub:lvalue{} will take us here. */
2314 "Can't return %s from lvalue subroutine", what
2319 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2320 if (!SvPADTMP(*SP)) {
2321 *++newsp = SvREFCNT_inc(*SP);
2326 /* FREETMPS could clobber it */
2327 SV *sv = SvREFCNT_inc(*SP);
2329 *++newsp = sv_mortalcopy(sv);
2336 ? sv_mortalcopy(*SP)
2338 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2343 *++newsp = &PL_sv_undef;
2345 if (CxLVAL(cx) & OPpDEREF) {
2348 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2352 else if (gimme == G_ARRAY) {
2353 assert (!(CxLVAL(cx) & OPpDEREF));
2354 if (ref || !CxLVAL(cx))
2355 while (++MARK <= SP)
2357 SvFLAGS(*MARK) & SVs_PADTMP
2358 ? sv_mortalcopy(*MARK)
2361 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2362 else while (++MARK <= SP) {
2363 if (*MARK != &PL_sv_undef
2365 || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2370 /* Might be flattened array after $#array = */
2377 /* diag_listed_as: Can't return %s from lvalue subroutine */
2379 "Can't return a %s from lvalue subroutine",
2380 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2386 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2389 PL_stack_sp = newsp;
2396 bool popsub2 = FALSE;
2397 bool clear_errsv = FALSE;
2407 const I32 cxix = dopoptosub(cxstack_ix);
2410 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2411 * sort block, which is a CXt_NULL
2414 PL_stack_base[1] = *PL_stack_sp;
2415 PL_stack_sp = PL_stack_base + 1;
2419 DIE(aTHX_ "Can't return outside a subroutine");
2421 if (cxix < cxstack_ix)
2424 if (CxMULTICALL(&cxstack[cxix])) {
2425 gimme = cxstack[cxix].blk_gimme;
2426 if (gimme == G_VOID)
2427 PL_stack_sp = PL_stack_base;
2428 else if (gimme == G_SCALAR) {
2429 PL_stack_base[1] = *PL_stack_sp;
2430 PL_stack_sp = PL_stack_base + 1;
2436 switch (CxTYPE(cx)) {
2439 lval = !!CvLVALUE(cx->blk_sub.cv);
2440 retop = cx->blk_sub.retop;
2441 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2444 if (!(PL_in_eval & EVAL_KEEPERR))
2447 namesv = cx->blk_eval.old_namesv;
2448 retop = cx->blk_eval.retop;
2451 if (optype == OP_REQUIRE &&
2452 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2454 /* Unassume the success we assumed earlier. */
2455 (void)hv_delete(GvHVn(PL_incgv),
2456 SvPVX_const(namesv),
2457 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2459 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2464 retop = cx->blk_sub.retop;
2467 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2471 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2473 if (gimme == G_SCALAR) {
2476 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2477 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2478 && !SvMAGICAL(TOPs)) {
2479 *++newsp = SvREFCNT_inc(*SP);
2484 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2486 *++newsp = sv_mortalcopy(sv);
2490 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2491 && !SvMAGICAL(*SP)) {
2495 *++newsp = sv_mortalcopy(*SP);
2498 *++newsp = sv_mortalcopy(*SP);
2501 *++newsp = &PL_sv_undef;
2503 else if (gimme == G_ARRAY) {
2504 while (++MARK <= SP) {
2505 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2506 && !SvGMAGICAL(*MARK)
2507 ? *MARK : sv_mortalcopy(*MARK);
2508 TAINT_NOT; /* Each item is independent */
2511 PL_stack_sp = newsp;
2515 /* Stack values are safe: */
2518 POPSUB(cx,sv); /* release CV and @_ ... */
2522 PL_curpm = newpm; /* ... and pop $1 et al */
2531 /* This duplicates parts of pp_leavesub, so that it can share code with
2542 if (CxMULTICALL(&cxstack[cxstack_ix]))
2546 cxstack_ix++; /* temporarily protect top context */
2550 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2554 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2555 PL_curpm = newpm; /* ... and pop $1 et al */
2558 return cx->blk_sub.retop;
2562 S_unwind_loop(pTHX_ const char * const opname)
2566 if (PL_op->op_flags & OPf_SPECIAL) {
2567 cxix = dopoptoloop(cxstack_ix);
2569 /* diag_listed_as: Can't "last" outside a loop block */
2570 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2575 const char * const label =
2576 PL_op->op_flags & OPf_STACKED
2577 ? SvPV(TOPs,label_len)
2578 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2579 const U32 label_flags =
2580 PL_op->op_flags & OPf_STACKED
2582 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2584 cxix = dopoptolabel(label, label_len, label_flags);
2586 /* diag_listed_as: Label not found for "last %s" */
2587 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2589 SVfARG(PL_op->op_flags & OPf_STACKED
2590 && !SvGMAGICAL(TOPp1s)
2592 : newSVpvn_flags(label,
2594 label_flags | SVs_TEMP)));
2596 if (cxix < cxstack_ix)
2614 S_unwind_loop(aTHX_ "last");
2617 cxstack_ix++; /* temporarily protect top context */
2619 switch (CxTYPE(cx)) {
2620 case CXt_LOOP_LAZYIV:
2621 case CXt_LOOP_LAZYSV:
2623 case CXt_LOOP_PLAIN:
2625 newsp = PL_stack_base + cx->blk_loop.resetsp;
2626 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2630 nextop = cx->blk_sub.retop;
2634 nextop = cx->blk_eval.retop;
2638 nextop = cx->blk_sub.retop;
2641 DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2645 PL_stack_sp = adjust_stack_on_leave(newsp, PL_stack_sp, MARK, gimme,
2646 pop2 == CXt_SUB ? SVs_TEMP : 0);
2650 /* Stack values are safe: */
2652 case CXt_LOOP_LAZYIV:
2653 case CXt_LOOP_PLAIN:
2654 case CXt_LOOP_LAZYSV:
2656 POPLOOP(cx); /* release loop vars ... */
2660 POPSUB(cx,sv); /* release CV and @_ ... */
2663 PL_curpm = newpm; /* ... and pop $1 et al */
2666 PERL_UNUSED_VAR(optype);
2667 PERL_UNUSED_VAR(gimme);
2675 const I32 inner = PL_scopestack_ix;
2677 S_unwind_loop(aTHX_ "next");
2679 /* clear off anything above the scope we're re-entering, but
2680 * save the rest until after a possible continue block */
2682 if (PL_scopestack_ix < inner)
2683 leave_scope(PL_scopestack[PL_scopestack_ix]);
2684 PL_curcop = cx->blk_oldcop;
2686 return (cx)->blk_loop.my_op->op_nextop;
2692 const I32 cxix = S_unwind_loop(aTHX_ "redo");
2695 OP* redo_op = cxstack[cxix].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..) */
2700 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2701 redo_op = redo_op->op_next;
2705 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2706 LEAVE_SCOPE(oldsave);
2708 PL_curcop = cx->blk_oldcop;
2714 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2718 static const char* const too_deep = "Target of goto is too deeply nested";
2720 PERL_ARGS_ASSERT_DOFINDLABEL;
2723 Perl_croak(aTHX_ "%s", too_deep);
2724 if (o->op_type == OP_LEAVE ||
2725 o->op_type == OP_SCOPE ||
2726 o->op_type == OP_LEAVELOOP ||
2727 o->op_type == OP_LEAVESUB ||
2728 o->op_type == OP_LEAVETRY)
2730 *ops++ = cUNOPo->op_first;
2732 Perl_croak(aTHX_ "%s", too_deep);
2735 if (o->op_flags & OPf_KIDS) {
2737 /* First try all the kids at this level, since that's likeliest. */
2738 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2739 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2740 STRLEN kid_label_len;
2741 U32 kid_label_flags;
2742 const char *kid_label = CopLABEL_len_flags(kCOP,
2743 &kid_label_len, &kid_label_flags);
2745 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2748 (const U8*)kid_label, kid_label_len,
2749 (const U8*)label, len) == 0)
2751 (const U8*)label, len,
2752 (const U8*)kid_label, kid_label_len) == 0)
2753 : ( len == kid_label_len && ((kid_label == label)
2754 || memEQ(kid_label, label, len)))))
2758 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2759 if (kid == PL_lastgotoprobe)
2761 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2764 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2765 ops[-1]->op_type == OP_DBSTATE)
2770 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2784 #define GOTO_DEPTH 64
2785 OP *enterops[GOTO_DEPTH];
2786 const char *label = NULL;
2787 STRLEN label_len = 0;
2788 U32 label_flags = 0;
2789 const bool do_dump = (PL_op->op_type == OP_DUMP);
2790 static const char* const must_have_label = "goto must have label";
2792 if (PL_op->op_flags & OPf_STACKED) {
2793 SV * const sv = POPs;
2796 /* This egregious kludge implements goto &subroutine */
2797 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2800 CV *cv = MUTABLE_CV(SvRV(sv));
2801 AV *arg = GvAV(PL_defgv);
2805 if (!CvROOT(cv) && !CvXSUB(cv)) {
2806 const GV * const gv = CvGV(cv);
2810 /* autoloaded stub? */
2811 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2813 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2815 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2816 if (autogv && (cv = GvCV(autogv)))
2818 tmpstr = sv_newmortal();
2819 gv_efullname3(tmpstr, gv, NULL);
2820 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2822 DIE(aTHX_ "Goto undefined subroutine");
2825 /* First do some returnish stuff. */
2826 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2828 cxix = dopoptosub(cxstack_ix);
2829 if (cxix < cxstack_ix) {
2832 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2838 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2839 if (CxTYPE(cx) == CXt_EVAL) {
2842 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2843 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2845 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2846 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2848 else if (CxMULTICALL(cx))
2851 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2853 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2854 AV* av = cx->blk_sub.argarray;
2856 /* abandon the original @_ if it got reified or if it is
2857 the same as the current @_ */
2858 if (AvREAL(av) || av == arg) {
2862 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2864 else CLEAR_ARGARRAY(av);
2866 /* We donate this refcount later to the callee’s pad. */
2867 SvREFCNT_inc_simple_void(arg);
2868 if (CxTYPE(cx) == CXt_SUB &&
2869 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2870 SvREFCNT_dec(cx->blk_sub.cv);
2871 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2872 LEAVE_SCOPE(oldsave);
2874 /* A destructor called during LEAVE_SCOPE could have undefined
2875 * our precious cv. See bug #99850. */
2876 if (!CvROOT(cv) && !CvXSUB(cv)) {
2877 const GV * const gv = CvGV(cv);
2880 SV * const tmpstr = sv_newmortal();
2881 gv_efullname3(tmpstr, gv, NULL);
2882 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2885 DIE(aTHX_ "Goto undefined subroutine");
2888 /* Now do some callish stuff. */
2890 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2892 OP* const retop = cx->blk_sub.retop;
2895 const SSize_t items = AvFILLp(arg) + 1;
2898 PERL_UNUSED_VAR(newsp);
2899 PERL_UNUSED_VAR(gimme);
2901 /* put GvAV(defgv) back onto stack */
2902 EXTEND(SP, items+1); /* @_ could have been extended. */
2903 Copy(AvARRAY(arg), SP + 1, items, SV*);
2908 for (index=0; index<items; index++)
2909 SvREFCNT_inc_void(sv_2mortal(SP[-index]));
2912 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2913 /* Restore old @_ */
2914 arg = GvAV(PL_defgv);
2915 GvAV(PL_defgv) = cx->blk_sub.savearray;
2919 /* XS subs don't have a CxSUB, so pop it */
2920 POPBLOCK(cx, PL_curpm);
2921 /* Push a mark for the start of arglist */
2924 (void)(*CvXSUB(cv))(aTHX_ cv);
2930 PADLIST * const padlist = CvPADLIST(cv);
2931 cx->blk_sub.cv = cv;
2932 cx->blk_sub.olddepth = CvDEPTH(cv);
2935 if (CvDEPTH(cv) < 2)
2936 SvREFCNT_inc_simple_void_NN(cv);
2938 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2939 sub_crush_depth(cv);
2940 pad_push(padlist, CvDEPTH(cv));
2942 PL_curcop = cx->blk_oldcop;
2944 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2947 CX_CURPAD_SAVE(cx->blk_sub);
2949 /* cx->blk_sub.argarray has no reference count, so we
2950 need something to hang on to our argument array so
2951 that cx->blk_sub.argarray does not end up pointing
2952 to freed memory as the result of undef *_. So put
2953 it in the callee’s pad, donating our refer-
2955 SvREFCNT_dec(PAD_SVl(0));
2956 PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2958 /* GvAV(PL_defgv) might have been modified on scope
2959 exit, so restore it. */
2960 if (arg != GvAV(PL_defgv)) {
2961 AV * const av = GvAV(PL_defgv);
2962 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2966 else SvREFCNT_dec(arg);
2967 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2968 Perl_get_db_sub(aTHX_ NULL, cv);
2970 CV * const gotocv = get_cvs("DB::goto", 0);
2972 PUSHMARK( PL_stack_sp );
2973 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2979 RETURNOP(CvSTART(cv));
2983 label = SvPV_nomg_const(sv, label_len);
2984 label_flags = SvUTF8(sv);
2987 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2988 label = cPVOP->op_pv;
2989 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2990 label_len = strlen(label);
2992 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
2997 OP *gotoprobe = NULL;
2998 bool leaving_eval = FALSE;
2999 bool in_block = FALSE;
3000 PERL_CONTEXT *last_eval_cx = NULL;
3004 PL_lastgotoprobe = NULL;
3006 for (ix = cxstack_ix; ix >= 0; ix--) {
3008 switch (CxTYPE(cx)) {
3010 leaving_eval = TRUE;
3011 if (!CxTRYBLOCK(cx)) {
3012 gotoprobe = (last_eval_cx ?
3013 last_eval_cx->blk_eval.old_eval_root :
3018 /* else fall through */
3019 case CXt_LOOP_LAZYIV:
3020 case CXt_LOOP_LAZYSV:
3022 case CXt_LOOP_PLAIN:
3025 gotoprobe = cx->blk_oldcop->op_sibling;
3031 gotoprobe = cx->blk_oldcop->op_sibling;
3034 gotoprobe = PL_main_root;
3037 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3038 gotoprobe = CvROOT(cx->blk_sub.cv);
3044 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3047 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3048 CxTYPE(cx), (long) ix);
3049 gotoprobe = PL_main_root;
3053 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3054 enterops, enterops + GOTO_DEPTH);
3057 if (gotoprobe->op_sibling &&
3058 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3059 gotoprobe->op_sibling->op_sibling) {
3060 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3061 label, label_len, label_flags, enterops,
3062 enterops + GOTO_DEPTH);
3067 PL_lastgotoprobe = gotoprobe;
3070 DIE(aTHX_ "Can't find label %"UTF8f,
3071 UTF8fARG(label_flags, label_len, label));
3073 /* if we're leaving an eval, check before we pop any frames
3074 that we're not going to punt, otherwise the error
3077 if (leaving_eval && *enterops && enterops[1]) {
3079 for (i = 1; enterops[i]; i++)
3080 if (enterops[i]->op_type == OP_ENTERITER)
3081 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3084 if (*enterops && enterops[1]) {
3085 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3087 deprecate("\"goto\" to jump into a construct");
3090 /* pop unwanted frames */
3092 if (ix < cxstack_ix) {
3099 oldsave = PL_scopestack[PL_scopestack_ix];
3100 LEAVE_SCOPE(oldsave);
3103 /* push wanted frames */
3105 if (*enterops && enterops[1]) {
3106 OP * const oldop = PL_op;
3107 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3108 for (; enterops[ix]; ix++) {
3109 PL_op = enterops[ix];
3110 /* Eventually we may want to stack the needed arguments
3111 * for each op. For now, we punt on the hard ones. */
3112 if (PL_op->op_type == OP_ENTERITER)
3113 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3114 PL_op->op_ppaddr(aTHX);
3122 if (!retop) retop = PL_main_start;
3124 PL_restartop = retop;
3125 PL_do_undump = TRUE;
3129 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3130 PL_do_undump = FALSE;
3146 anum = 0; (void)POPs;
3151 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3153 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3156 PL_exit_flags |= PERL_EXIT_EXPECTED;
3158 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3159 if (anum || !(PL_minus_c && PL_madskills))
3164 PUSHs(&PL_sv_undef);
3171 S_save_lines(pTHX_ AV *array, SV *sv)
3173 const char *s = SvPVX_const(sv);
3174 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3177 PERL_ARGS_ASSERT_SAVE_LINES;
3179 while (s && s < send) {
3181 SV * const tmpstr = newSV_type(SVt_PVMG);
3183 t = (const char *)memchr(s, '\n', send - s);
3189 sv_setpvn(tmpstr, s, t - s);
3190 av_store(array, line++, tmpstr);
3198 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3200 0 is used as continue inside eval,
3202 3 is used for a die caught by an inner eval - continue inner loop
3204 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3205 establish a local jmpenv to handle exception traps.
3210 S_docatch(pTHX_ OP *o)
3214 OP * const oldop = PL_op;
3218 assert(CATCH_GET == TRUE);
3225 assert(cxstack_ix >= 0);
3226 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3227 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3232 /* die caught by an inner eval - continue inner loop */
3233 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3234 PL_restartjmpenv = NULL;
3235 PL_op = PL_restartop;
3244 assert(0); /* NOTREACHED */
3253 =for apidoc find_runcv
3255 Locate the CV corresponding to the currently executing sub or eval.
3256 If db_seqp is non_null, skip CVs that are in the DB package and populate
3257 *db_seqp with the cop sequence number at the point that the DB:: code was
3258 entered. (allows debuggers to eval in the scope of the breakpoint rather
3259 than in the scope of the debugger itself).
3265 Perl_find_runcv(pTHX_ U32 *db_seqp)
3267 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3270 /* If this becomes part of the API, it might need a better name. */
3272 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3280 PL_curcop == &PL_compiling
3282 : PL_curcop->cop_seq;
3284 for (si = PL_curstackinfo; si; si = si->si_prev) {
3286 for (ix = si->si_cxix; ix >= 0; ix--) {
3287 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3289 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3290 cv = cx->blk_sub.cv;
3291 /* skip DB:: code */
3292 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3293 *db_seqp = cx->blk_oldcop->cop_seq;
3296 if (cx->cx_type & CXp_SUB_RE)
3299 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3300 cv = cx->blk_eval.cv;
3303 case FIND_RUNCV_padid_eq:
3305 || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
3308 case FIND_RUNCV_level_eq:
3309 if (level++ != arg) continue;
3317 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3321 /* Run yyparse() in a setjmp wrapper. Returns:
3322 * 0: yyparse() successful
3323 * 1: yyparse() failed
3327 S_try_yyparse(pTHX_ int gramtype)
3332 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3336 ret = yyparse(gramtype) ? 1 : 0;
3343 assert(0); /* NOTREACHED */
3350 /* Compile a require/do or an eval ''.
3352 * outside is the lexically enclosing CV (if any) that invoked us.
3353 * seq is the current COP scope value.
3354 * hh is the saved hints hash, if any.
3356 * Returns a bool indicating whether the compile was successful; if so,
3357 * PL_eval_start contains the first op of the compiled code; otherwise,
3360 * This function is called from two places: pp_require and pp_entereval.
3361 * These can be distinguished by whether PL_op is entereval.
3365 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3368 OP * const saveop = PL_op;
3369 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3370 COP * const oldcurcop = PL_curcop;
3371 bool in_require = (saveop->op_type == OP_REQUIRE);
3375 PL_in_eval = (in_require
3376 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3378 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3379 ? EVAL_RE_REPARSING : 0)));
3383 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3385 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3386 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3387 cxstack[cxstack_ix].blk_gimme = gimme;
3389 CvOUTSIDE_SEQ(evalcv) = seq;
3390 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3392 /* set up a scratch pad */
3394 CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3395 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3399 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3401 /* make sure we compile in the right package */
3403 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3404 SAVEGENERICSV(PL_curstash);
3405 PL_curstash = (HV *)CopSTASH(PL_curcop);
3406 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3407 else SvREFCNT_inc_simple_void(PL_curstash);
3409 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3410 SAVESPTR(PL_beginav);
3411 PL_beginav = newAV();
3412 SAVEFREESV(PL_beginav);
3413 SAVESPTR(PL_unitcheckav);
3414 PL_unitcheckav = newAV();
3415 SAVEFREESV(PL_unitcheckav);
3418 SAVEBOOL(PL_madskills);
3422 ENTER_with_name("evalcomp");
3423 SAVESPTR(PL_compcv);
3426 /* try to compile it */
3428 PL_eval_root = NULL;
3429 PL_curcop = &PL_compiling;
3430 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3431 PL_in_eval |= EVAL_KEEPERR;
3438 hv_clear(GvHV(PL_hintgv));
3441 PL_hints = saveop->op_private & OPpEVAL_COPHH
3442 ? oldcurcop->cop_hints : saveop->op_targ;
3444 /* making 'use re eval' not be in scope when compiling the
3445 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3446 * infinite recursion when S_has_runtime_code() gives a false
3447 * positive: the second time round, HINT_RE_EVAL isn't set so we
3448 * don't bother calling S_has_runtime_code() */
3449 if (PL_in_eval & EVAL_RE_REPARSING)
3450 PL_hints &= ~HINT_RE_EVAL;
3453 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3454 SvREFCNT_dec(GvHV(PL_hintgv));
3455 GvHV(PL_hintgv) = hh;
3458 SAVECOMPILEWARNINGS();
3460 if (PL_dowarn & G_WARN_ALL_ON)
3461 PL_compiling.cop_warnings = pWARN_ALL ;
3462 else if (PL_dowarn & G_WARN_ALL_OFF)
3463 PL_compiling.cop_warnings = pWARN_NONE ;
3465 PL_compiling.cop_warnings = pWARN_STD ;
3468 PL_compiling.cop_warnings =
3469 DUP_WARNINGS(oldcurcop->cop_warnings);
3470 cophh_free(CopHINTHASH_get(&PL_compiling));
3471 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3472 /* The label, if present, is the first entry on the chain. So rather
3473 than writing a blank label in front of it (which involves an
3474 allocation), just use the next entry in the chain. */
3475 PL_compiling.cop_hints_hash
3476 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3477 /* Check the assumption that this removed the label. */
3478 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3481 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3484 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3486 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3487 * so honour CATCH_GET and trap it here if necessary */
3489 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3491 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3492 SV **newsp; /* Used by POPBLOCK. */
3494 I32 optype; /* Used by POPEVAL. */
3500 PERL_UNUSED_VAR(newsp);
3501 PERL_UNUSED_VAR(optype);
3503 /* note that if yystatus == 3, then the EVAL CX block has already
3504 * been popped, and various vars restored */
3506 if (yystatus != 3) {
3508 op_free(PL_eval_root);
3509 PL_eval_root = NULL;
3511 SP = PL_stack_base + POPMARK; /* pop original mark */
3512 POPBLOCK(cx,PL_curpm);
3514 namesv = cx->blk_eval.old_namesv;
3515 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3516 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3522 /* If cx is still NULL, it means that we didn't go in the
3523 * POPEVAL branch. */
3524 cx = &cxstack[cxstack_ix];
3525 assert(CxTYPE(cx) == CXt_EVAL);
3526 namesv = cx->blk_eval.old_namesv;
3528 (void)hv_store(GvHVn(PL_incgv),
3529 SvPVX_const(namesv),
3530 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3532 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3535 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3538 if (!*(SvPV_nolen_const(errsv))) {
3539 sv_setpvs(errsv, "Compilation error");
3542 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3547 LEAVE_with_name("evalcomp");
3549 CopLINE_set(&PL_compiling, 0);
3550 SAVEFREEOP(PL_eval_root);
3551 cv_forget_slab(evalcv);
3553 DEBUG_x(dump_eval());
3555 /* Register with debugger: */
3556 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3557 CV * const cv = get_cvs("DB::postponed", 0);
3561 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3563 call_sv(MUTABLE_SV(cv), G_DISCARD);
3567 if (PL_unitcheckav) {
3568 OP *es = PL_eval_start;
3569 call_list(PL_scopestack_ix, PL_unitcheckav);
3573 /* compiled okay, so do it */
3575 CvDEPTH(evalcv) = 1;
3576 SP = PL_stack_base + POPMARK; /* pop original mark */
3577 PL_op = saveop; /* The caller may need it. */
3578 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3585 S_check_type_and_open(pTHX_ SV *name)
3588 const char *p = SvPV_nolen_const(name);
3589 const int st_rc = PerlLIO_stat(p, &st);
3591 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3593 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3597 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3598 return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3600 return PerlIO_open(p, PERL_SCRIPT_MODE);
3604 #ifndef PERL_DISABLE_PMC
3606 S_doopen_pm(pTHX_ SV *name)
3609 const char *p = SvPV_const(name, namelen);
3611 PERL_ARGS_ASSERT_DOOPEN_PM;
3613 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3614 SV *const pmcsv = sv_newmortal();
3617 SvSetSV_nosteal(pmcsv,name);
3618 sv_catpvn(pmcsv, "c", 1);
3620 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3621 return check_type_and_open(pmcsv);
3623 return check_type_and_open(name);
3626 # define doopen_pm(name) check_type_and_open(name)
3627 #endif /* !PERL_DISABLE_PMC */
3629 /* require doesn't search for absolute names, or when the name is
3630 explicity relative the current directory */
3631 PERL_STATIC_INLINE bool
3632 S_path_is_searchable(const char *name)
3634 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3636 if (PERL_FILE_IS_ABSOLUTE(name)
3638 || (*name == '.' && ((name[1] == '/' ||
3639 (name[1] == '.' && name[2] == '/'))
3640 || (name[1] == '\\' ||
3641 ( name[1] == '.' && name[2] == '\\')))
3644 || (*name == '.' && (name[1] == '/' ||
3645 (name[1] == '.' && name[2] == '/')))
3665 int vms_unixname = 0;
3670 const char *tryname = NULL;
3672 const I32 gimme = GIMME_V;
3673 int filter_has_file = 0;
3674 PerlIO *tryrsfp = NULL;
3675 SV *filter_cache = NULL;
3676 SV *filter_state = NULL;
3677 SV *filter_sub = NULL;
3682 bool path_searchable;
3685 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3686 sv = sv_2mortal(new_version(sv));
3687 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3688 upg_version(PL_patchlevel, TRUE);
3689 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3690 if ( vcmp(sv,PL_patchlevel) <= 0 )
3691 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3692 SVfARG(sv_2mortal(vnormal(sv))),
3693 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3697 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3700 SV * const req = SvRV(sv);
3701 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3703 /* get the left hand term */
3704 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3706 first = SvIV(*av_fetch(lav,0,0));
3707 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3708 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3709 || av_len(lav) > 1 /* FP with > 3 digits */
3710 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3712 DIE(aTHX_ "Perl %"SVf" required--this is only "
3714 SVfARG(sv_2mortal(vnormal(req))),
3715 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3718 else { /* probably 'use 5.10' or 'use 5.8' */
3723 second = SvIV(*av_fetch(lav,1,0));
3725 second /= second >= 600 ? 100 : 10;
3726 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3727 (int)first, (int)second);
3728 upg_version(hintsv, TRUE);
3730 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3731 "--this is only %"SVf", stopped",
3732 SVfARG(sv_2mortal(vnormal(req))),
3733 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3734 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3742 name = SvPV_const(sv, len);
3743 if (!(name && len > 0 && *name))
3744 DIE(aTHX_ "Null filename used");
3745 TAINT_PROPER("require");
3747 path_searchable = path_is_searchable(name);
3750 /* The key in the %ENV hash is in the syntax of file passed as the argument
3751 * usually this is in UNIX format, but sometimes in VMS format, which
3752 * can result in a module being pulled in more than once.
3753 * To prevent this, the key must be stored in UNIX format if the VMS
3754 * name can be translated to UNIX.
3757 if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))
3758 && (unixname = tounixspec(name, unixnamebuf)) != NULL) {
3759 unixlen = strlen(unixname);
3765 /* if not VMS or VMS name can not be translated to UNIX, pass it
3768 unixname = (char *) name;
3771 if (PL_op->op_type == OP_REQUIRE) {
3772 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3773 unixname, unixlen, 0);
3775 if (*svp != &PL_sv_undef)
3778 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3779 "Compilation failed in require", unixname);
3783 LOADING_FILE_PROBE(unixname);
3785 /* prepare to compile file */
3787 if (!path_searchable) {
3788 /* At this point, name is SvPVX(sv) */
3790 tryrsfp = doopen_pm(sv);
3792 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3793 AV * const ar = GvAVn(PL_incgv);
3799 namesv = newSV_type(SVt_PV);
3800 for (i = 0; i <= AvFILL(ar); i++) {
3801 SV * const dirsv = *av_fetch(ar, i, TRUE);
3803 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3810 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3811 && !sv_isobject(loader))
3813 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3816 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3817 PTR2UV(SvRV(dirsv)), name);
3818 tryname = SvPVX_const(namesv);
3821 ENTER_with_name("call_INC");
3829 if (sv_isobject(loader))
3830 count = call_method("INC", G_ARRAY);
3832 count = call_sv(loader, G_ARRAY);
3842 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3843 && !isGV_with_GP(SvRV(arg))) {
3844 filter_cache = SvRV(arg);
3851 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3855 if (isGV_with_GP(arg)) {
3856 IO * const io = GvIO((const GV *)arg);
3861 tryrsfp = IoIFP(io);
3862 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3863 PerlIO_close(IoOFP(io));
3874 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3876 SvREFCNT_inc_simple_void_NN(filter_sub);
3879 filter_state = SP[i];
3880 SvREFCNT_inc_simple_void(filter_state);
3884 if (!tryrsfp && (filter_cache || filter_sub)) {
3885 tryrsfp = PerlIO_open(BIT_BUCKET,
3893 LEAVE_with_name("call_INC");
3895 /* Adjust file name if the hook has set an %INC entry.
3896 This needs to happen after the FREETMPS above. */
3897 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3899 tryname = SvPV_nolen_const(*svp);
3906 filter_has_file = 0;
3907 filter_cache = NULL;
3909 SvREFCNT_dec(filter_state);
3910 filter_state = NULL;
3913 SvREFCNT_dec(filter_sub);
3918 if (path_searchable) {
3923 dir = SvPV_const(dirsv, dirlen);
3930 if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL)
3931 || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL))
3933 sv_setpv(namesv, unixdir);
3934 sv_catpv(namesv, unixname);
3936 # ifdef __SYMBIAN32__
3937 if (PL_origfilename[0] &&
3938 PL_origfilename[1] == ':' &&
3939 !(dir[0] && dir[1] == ':'))
3940 Perl_sv_setpvf(aTHX_ namesv,
3945 Perl_sv_setpvf(aTHX_ namesv,
3949 /* The equivalent of
3950 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3951 but without the need to parse the format string, or
3952 call strlen on either pointer, and with the correct
3953 allocation up front. */
3955 char *tmp = SvGROW(namesv, dirlen + len + 2);
3957 memcpy(tmp, dir, dirlen);
3960 /* Avoid '<dir>//<file>' */
3961 if (!dirlen || *(tmp-1) != '/') {
3965 /* name came from an SV, so it will have a '\0' at the
3966 end that we can copy as part of this memcpy(). */
3967 memcpy(tmp, name, len + 1);
3969 SvCUR_set(namesv, dirlen + len + 1);
3974 TAINT_PROPER("require");
3975 tryname = SvPVX_const(namesv);
3976 tryrsfp = doopen_pm(namesv);
3978 if (tryname[0] == '.' && tryname[1] == '/') {
3980 while (*++tryname == '/') {}
3984 else if (errno == EMFILE || errno == EACCES) {
3985 /* no point in trying other paths if out of handles;
3986 * on the other hand, if we couldn't open one of the
3987 * files, then going on with the search could lead to
3988 * unexpected results; see perl #113422
3997 saved_errno = errno; /* sv_2mortal can realloc things */
4000 if (PL_op->op_type == OP_REQUIRE) {
4001 if(saved_errno == EMFILE || saved_errno == EACCES) {
4002 /* diag_listed_as: Can't locate %s */
4003 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno));
4005 if (namesv) { /* did we lookup @INC? */
4006 AV * const ar = GvAVn(PL_incgv);
4008 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4009 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4010 for (i = 0; i <= AvFILL(ar); i++) {
4011 sv_catpvs(inc, " ");
4012 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4014 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4015 const char *c, *e = name + len - 3;
4016 sv_catpv(msg, " (you may need to install the ");
4017 for (c = name; c < e; c++) {
4019 sv_catpvn(msg, "::", 2);
4022 sv_catpvn(msg, c, 1);
4025 sv_catpv(msg, " module)");
4027 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4028 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4030 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4031 sv_catpv(msg, " (did you run h2ph?)");
4034 /* diag_listed_as: Can't locate %s */
4036 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4040 DIE(aTHX_ "Can't locate %s", name);
4047 SETERRNO(0, SS_NORMAL);
4049 /* Assume success here to prevent recursive requirement. */
4050 /* name is never assigned to again, so len is still strlen(name) */
4051 /* Check whether a hook in @INC has already filled %INC */
4053 (void)hv_store(GvHVn(PL_incgv),
4054 unixname, unixlen, newSVpv(tryname,0),0);
4056 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4058 (void)hv_store(GvHVn(PL_incgv),
4059 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4062 ENTER_with_name("eval");
4064 SAVECOPFILE_FREE(&PL_compiling);
4065 CopFILE_set(&PL_compiling, tryname);
4066 lex_start(NULL, tryrsfp, 0);
4068 if (filter_sub || filter_cache) {
4069 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4070 than hanging another SV from it. In turn, filter_add() optionally
4071 takes the SV to use as the filter (or creates a new SV if passed
4072 NULL), so simply pass in whatever value filter_cache has. */
4073 SV * const fc = filter_cache ? newSV(0) : NULL;
4075 if (fc) sv_copypv(fc, filter_cache);
4076 datasv = filter_add(S_run_user_filter, fc);
4077 IoLINES(datasv) = filter_has_file;
4078 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4079 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4082 /* switch to eval mode */
4083 PUSHBLOCK(cx, CXt_EVAL, SP);
4085 cx->blk_eval.retop = PL_op->op_next;
4087 SAVECOPLINE(&PL_compiling);
4088 CopLINE_set(&PL_compiling, 0);
4092 /* Store and reset encoding. */
4093 encoding = PL_encoding;
4096 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4097 op = DOCATCH(PL_eval_start);
4099 op = PL_op->op_next;
4101 /* Restore encoding. */
4102 PL_encoding = encoding;
4104 LOADED_FILE_PROBE(unixname);
4109 /* This is a op added to hold the hints hash for
4110 pp_entereval. The hash can be modified by the code
4111 being eval'ed, so we return a copy instead. */
4117 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4127 const I32 gimme = GIMME_V;
4128 const U32 was = PL_breakable_sub_gen;
4129 char tbuf[TYPE_DIGITS(long) + 12];
4130 bool saved_delete = FALSE;
4131 char *tmpbuf = tbuf;
4134 U32 seq, lex_flags = 0;
4135 HV *saved_hh = NULL;
4136 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4138 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4139 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4141 else if (PL_hints & HINT_LOCALIZE_HH || (
4142 PL_op->op_private & OPpEVAL_COPHH
4143 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4145 saved_hh = cop_hints_2hv(PL_curcop, 0);
4146 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4150 /* make sure we've got a plain PV (no overload etc) before testing
4151 * for taint. Making a copy here is probably overkill, but better
4152 * safe than sorry */
4154 const char * const p = SvPV_const(sv, len);
4156 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4157 lex_flags |= LEX_START_COPIED;
4159 if (bytes && SvUTF8(sv))
4160 SvPVbyte_force(sv, len);
4162 else if (bytes && SvUTF8(sv)) {
4163 /* Don't modify someone else's scalar */
4166 (void)sv_2mortal(sv);
4167 SvPVbyte_force(sv,len);
4168 lex_flags |= LEX_START_COPIED;
4171 TAINT_IF(SvTAINTED(sv));
4172 TAINT_PROPER("eval");
4174 ENTER_with_name("eval");
4175 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4176 ? LEX_IGNORE_UTF8_HINTS
4177 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4182 /* switch to eval mode */
4184 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4185 SV * const temp_sv = sv_newmortal();
4186 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4187 (unsigned long)++PL_evalseq,
4188 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4189 tmpbuf = SvPVX(temp_sv);
4190 len = SvCUR(temp_sv);
4193 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4194 SAVECOPFILE_FREE(&PL_compiling);
4195 CopFILE_set(&PL_compiling, tmpbuf+2);
4196 SAVECOPLINE(&PL_compiling);
4197 CopLINE_set(&PL_compiling, 1);
4198 /* special case: an eval '' executed within the DB package gets lexically
4199 * placed in the first non-DB CV rather than the current CV - this
4200 * allows the debugger to execute code, find lexicals etc, in the
4201 * scope of the code being debugged. Passing &seq gets find_runcv
4202 * to do the dirty work for us */
4203 runcv = find_runcv(&seq);
4205 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4207 cx->blk_eval.retop = PL_op->op_next;
4209 /* prepare to compile string */
4211 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4212 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4214 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4215 deleting the eval's FILEGV from the stash before gv_check() runs
4216 (i.e. before run-time proper). To work around the coredump that
4217 ensues, we always turn GvMULTI_on for any globals that were
4218 introduced within evals. See force_ident(). GSAR 96-10-12 */
4219 char *const safestr = savepvn(tmpbuf, len);
4220 SAVEDELETE(PL_defstash, safestr, len);
4221 saved_delete = TRUE;
4226 if (doeval(gimme, runcv, seq, saved_hh)) {
4227 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4228 ? (PERLDB_LINE || PERLDB_SAVESRC)
4229 : PERLDB_SAVESRC_NOSUBS) {
4230 /* Retain the filegv we created. */
4231 } else if (!saved_delete) {
4232 char *const safestr = savepvn(tmpbuf, len);
4233 SAVEDELETE(PL_defstash, safestr, len);
4235 return DOCATCH(PL_eval_start);
4237 /* We have already left the scope set up earlier thanks to the LEAVE
4239 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4240 ? (PERLDB_LINE || PERLDB_SAVESRC)
4241 : PERLDB_SAVESRC_INVALID) {
4242 /* Retain the filegv we created. */
4243 } else if (!saved_delete) {
4244 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4246 return PL_op->op_next;
4258 const U8 save_flags = PL_op -> op_flags;
4266 namesv = cx->blk_eval.old_namesv;
4267 retop = cx->blk_eval.retop;
4268 evalcv = cx->blk_eval.cv;
4271 SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4273 PL_curpm = newpm; /* Don't pop $1 et al till now */
4276 assert(CvDEPTH(evalcv) == 1);
4278 CvDEPTH(evalcv) = 0;
4280 if (optype == OP_REQUIRE &&
4281 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4283 /* Unassume the success we assumed earlier. */
4284 (void)hv_delete(GvHVn(PL_incgv),
4285 SvPVX_const(namesv),
4286 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4288 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4290 /* die_unwind() did LEAVE, or we won't be here */
4293 LEAVE_with_name("eval");
4294 if (!(save_flags & OPf_SPECIAL)) {
4302 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4303 close to the related Perl_create_eval_scope. */
4305 Perl_delete_eval_scope(pTHX)
4316 LEAVE_with_name("eval_scope");
4317 PERL_UNUSED_VAR(newsp);
4318 PERL_UNUSED_VAR(gimme);
4319 PERL_UNUSED_VAR(optype);
4322 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4323 also needed by Perl_fold_constants. */
4325 Perl_create_eval_scope(pTHX_ U32 flags)
4328 const I32 gimme = GIMME_V;
4330 ENTER_with_name("eval_scope");
4333 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4336 PL_in_eval = EVAL_INEVAL;
4337 if (flags & G_KEEPERR)
4338 PL_in_eval |= EVAL_KEEPERR;
4341 if (flags & G_FAKINGEVAL) {
4342 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4350 PERL_CONTEXT * const cx = create_eval_scope(0);
4351 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4352 return DOCATCH(PL_op->op_next);
4367 PERL_UNUSED_VAR(optype);
4370 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4371 PL_curpm = newpm; /* Don't pop $1 et al till now */
4373 LEAVE_with_name("eval_scope");
4382 const I32 gimme = GIMME_V;
4384 ENTER_with_name("given");
4387 if (PL_op->op_targ) {
4388 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4389 SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4390 PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4397 PUSHBLOCK(cx, CXt_GIVEN, SP);
4410 PERL_UNUSED_CONTEXT;
4413 assert(CxTYPE(cx) == CXt_GIVEN);
4416 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4417 PL_curpm = newpm; /* Don't pop $1 et al till now */
4419 LEAVE_with_name("given");
4423 /* Helper routines used by pp_smartmatch */
4425 S_make_matcher(pTHX_ REGEXP *re)
4428 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4430 PERL_ARGS_ASSERT_MAKE_MATCHER;
4432 PM_SETRE(matcher, ReREFCNT_inc(re));
4434 SAVEFREEOP((OP *) matcher);
4435 ENTER_with_name("matcher"); SAVETMPS;
4441 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4446 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4448 PL_op = (OP *) matcher;
4451 (void) Perl_pp_match(aTHX);
4453 return (SvTRUEx(POPs));
4457 S_destroy_matcher(pTHX_ PMOP *matcher)
4461 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4462 PERL_UNUSED_ARG(matcher);
4465 LEAVE_with_name("matcher");
4468 /* Do a smart match */
4471 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4472 return do_smartmatch(NULL, NULL, 0);
4475 /* This version of do_smartmatch() implements the
4476 * table of smart matches that is found in perlsyn.
4479 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4484 bool object_on_left = FALSE;
4485 SV *e = TOPs; /* e is for 'expression' */
4486 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4488 /* Take care only to invoke mg_get() once for each argument.
4489 * Currently we do this by copying the SV if it's magical. */
4491 if (!copied && SvGMAGICAL(d))
4492 d = sv_mortalcopy(d);
4499 e = sv_mortalcopy(e);
4501 /* First of all, handle overload magic of the rightmost argument */
4504 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4505 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4507 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4514 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4517 SP -= 2; /* Pop the values */
4522 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4529 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4530 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4531 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4533 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4534 object_on_left = TRUE;
4537 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4539 if (object_on_left) {
4540 goto sm_any_sub; /* Treat objects like scalars */
4542 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4543 /* Test sub truth for each key */
4545 bool andedresults = TRUE;
4546 HV *hv = (HV*) SvRV(d);
4547 I32 numkeys = hv_iterinit(hv);
4548 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4551 while ( (he = hv_iternext(hv)) ) {
4552 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4553 ENTER_with_name("smartmatch_hash_key_test");
4556 PUSHs(hv_iterkeysv(he));
4558 c = call_sv(e, G_SCALAR);
4561 andedresults = FALSE;
4563 andedresults = SvTRUEx(POPs) && andedresults;
4565 LEAVE_with_name("smartmatch_hash_key_test");
4572 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4573 /* Test sub truth for each element */
4575 bool andedresults = TRUE;
4576 AV *av = (AV*) SvRV(d);
4577 const I32 len = av_len(av);
4578 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4581 for (i = 0; i <= len; ++i) {
4582 SV * const * const svp = av_fetch(av, i, FALSE);
4583 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4584 ENTER_with_name("smartmatch_array_elem_test");
4590 c = call_sv(e, G_SCALAR);
4593 andedresults = FALSE;
4595 andedresults = SvTRUEx(POPs) && andedresults;
4597 LEAVE_with_name("smartmatch_array_elem_test");
4606 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4607 ENTER_with_name("smartmatch_coderef");
4612 c = call_sv(e, G_SCALAR);
4616 else if (SvTEMP(TOPs))
4617 SvREFCNT_inc_void(TOPs);
4619 LEAVE_with_name("smartmatch_coderef");
4624 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4625 if (object_on_left) {
4626 goto sm_any_hash; /* Treat objects like scalars */
4628 else if (!SvOK(d)) {
4629 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4632 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4633 /* Check that the key-sets are identical */
4635 HV *other_hv = MUTABLE_HV(SvRV(d));
4637 bool other_tied = FALSE;
4638 U32 this_key_count = 0,
4639 other_key_count = 0;
4640 HV *hv = MUTABLE_HV(SvRV(e));
4642 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4643 /* Tied hashes don't know how many keys they have. */
4644 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4647 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4648 HV * const temp = other_hv;
4653 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4656 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4659 /* The hashes have the same number of keys, so it suffices
4660 to check that one is a subset of the other. */
4661 (void) hv_iterinit(hv);
4662 while ( (he = hv_iternext(hv)) ) {
4663 SV *key = hv_iterkeysv(he);
4665 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4668 if(!hv_exists_ent(other_hv, key, 0)) {
4669 (void) hv_iterinit(hv); /* reset iterator */
4675 (void) hv_iterinit(other_hv);
4676 while ( hv_iternext(other_hv) )
4680 other_key_count = HvUSEDKEYS(other_hv);
4682 if (this_key_count != other_key_count)
4687 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4688 AV * const other_av = MUTABLE_AV(SvRV(d));
4689 const SSize_t other_len = av_len(other_av) + 1;
4691 HV *hv = MUTABLE_HV(SvRV(e));
4693 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4694 for (i = 0; i < other_len; ++i) {
4695 SV ** const svp = av_fetch(other_av, i, FALSE);
4696 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4697 if (svp) { /* ??? When can this not happen? */
4698 if (hv_exists_ent(hv, *svp, 0))
4704 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4705 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4708 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4710 HV *hv = MUTABLE_HV(SvRV(e));
4712 (void) hv_iterinit(hv);
4713 while ( (he = hv_iternext(hv)) ) {
4714 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4715 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4716 (void) hv_iterinit(hv);
4717 destroy_matcher(matcher);
4721 destroy_matcher(matcher);
4727 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4728 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4735 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4736 if (object_on_left) {
4737 goto sm_any_array; /* Treat objects like scalars */
4739 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4740 AV * const other_av = MUTABLE_AV(SvRV(e));
4741 const SSize_t other_len = av_len(other_av) + 1;
4744 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4745 for (i = 0; i < other_len; ++i) {
4746 SV ** const svp = av_fetch(other_av, i, FALSE);
4748 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4749 if (svp) { /* ??? When can this not happen? */
4750 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4756 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4757 AV *other_av = MUTABLE_AV(SvRV(d));
4758 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4759 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4763 const SSize_t other_len = av_len(other_av);
4765 if (NULL == seen_this) {
4766 seen_this = newHV();
4767 (void) sv_2mortal(MUTABLE_SV(seen_this));
4769 if (NULL == seen_other) {
4770 seen_other = newHV();
4771 (void) sv_2mortal(MUTABLE_SV(seen_other));
4773 for(i = 0; i <= other_len; ++i) {
4774 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4775 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4777 if (!this_elem || !other_elem) {
4778 if ((this_elem && SvOK(*this_elem))
4779 || (other_elem && SvOK(*other_elem)))
4782 else if (hv_exists_ent(seen_this,
4783 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4784 hv_exists_ent(seen_other,
4785 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4787 if (*this_elem != *other_elem)
4791 (void)hv_store_ent(seen_this,
4792 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4794 (void)hv_store_ent(seen_other,
4795 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4801 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4802 (void) do_smartmatch(seen_this, seen_other, 0);
4804 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4813 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4814 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4817 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4818 const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
4821 for(i = 0; i <= this_len; ++i) {
4822 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4823 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4824 if (svp && matcher_matches_sv(matcher, *svp)) {
4825 destroy_matcher(matcher);
4829 destroy_matcher(matcher);
4833 else if (!SvOK(d)) {
4834 /* undef ~~ array */
4835 const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
4838 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4839 for (i = 0; i <= this_len; ++i) {
4840 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4841 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4842 if (!svp || !SvOK(*svp))
4851 const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
4853 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4854 for (i = 0; i <= this_len; ++i) {
4855 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4862 /* infinite recursion isn't supposed to happen here */
4863 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4864 (void) do_smartmatch(NULL, NULL, 1);
4866 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4875 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4876 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4877 SV *t = d; d = e; e = t;
4878 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4881 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4882 SV *t = d; d = e; e = t;
4883 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4884 goto sm_regex_array;
4887 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4889 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4891 PUSHs(matcher_matches_sv(matcher, d)
4894 destroy_matcher(matcher);
4899 /* See if there is overload magic on left */
4900 else if (object_on_left && SvAMAGIC(d)) {
4902 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4903 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4906 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4914 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4917 else if (!SvOK(d)) {
4918 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4919 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4924 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4925 DEBUG_M(if (SvNIOK(e))
4926 Perl_deb(aTHX_ " applying rule Any-Num\n");
4928 Perl_deb(aTHX_ " applying rule Num-numish\n");
4930 /* numeric comparison */
4933 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4934 (void) Perl_pp_i_eq(aTHX);
4936 (void) Perl_pp_eq(aTHX);
4944 /* As a last resort, use string comparison */
4945 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4948 return Perl_pp_seq(aTHX);
4955 const I32 gimme = GIMME_V;
4957 /* This is essentially an optimization: if the match
4958 fails, we don't want to push a context and then
4959 pop it again right away, so we skip straight
4960 to the op that follows the leavewhen.
4961 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4963 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4964 RETURNOP(cLOGOP->op_other->op_next);
4966 ENTER_with_name("when");
4969 PUSHBLOCK(cx, CXt_WHEN, SP);
4984 cxix = dopoptogiven(cxstack_ix);
4986 /* diag_listed_as: Can't "when" outside a topicalizer */
4987 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
4988 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
4991 assert(CxTYPE(cx) == CXt_WHEN);
4994 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4995 PL_curpm = newpm; /* pop $1 et al */
4997 LEAVE_with_name("when");
4999 if (cxix < cxstack_ix)
5002 cx = &cxstack[cxix];
5004 if (CxFOREACH(cx)) {
5005 /* clear off anything above the scope we're re-entering */
5006 I32 inner = PL_scopestack_ix;
5009 if (PL_scopestack_ix < inner)
5010 leave_scope(PL_scopestack[PL_scopestack_ix]);
5011 PL_curcop = cx->blk_oldcop;
5014 return cx->blk_loop.my_op->op_nextop;
5018 RETURNOP(cx->blk_givwhen.leave_op);
5031 PERL_UNUSED_VAR(gimme);
5033 cxix = dopoptowhen(cxstack_ix);
5035 DIE(aTHX_ "Can't \"continue\" outside a when block");
5037 if (cxix < cxstack_ix)
5041 assert(CxTYPE(cx) == CXt_WHEN);
5044 PL_curpm = newpm; /* pop $1 et al */
5046 LEAVE_with_name("when");
5047 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5056 cxix = dopoptogiven(cxstack_ix);
5058 DIE(aTHX_ "Can't \"break\" outside a given block");
5060 cx = &cxstack[cxix];
5062 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5064 if (cxix < cxstack_ix)
5067 /* Restore the sp at the time we entered the given block */
5070 return cx->blk_givwhen.leave_op;
5074 S_doparseform(pTHX_ SV *sv)
5077 char *s = SvPV(sv, len);
5079 char *base = NULL; /* start of current field */
5080 I32 skipspaces = 0; /* number of contiguous spaces seen */
5081 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5082 bool repeat = FALSE; /* ~~ seen on this line */
5083 bool postspace = FALSE; /* a text field may need right padding */
5086 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5088 bool ischop; /* it's a ^ rather than a @ */
5089 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5090 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5094 PERL_ARGS_ASSERT_DOPARSEFORM;
5097 Perl_croak(aTHX_ "Null picture in formline");
5099 if (SvTYPE(sv) >= SVt_PVMG) {
5100 /* This might, of course, still return NULL. */
5101 mg = mg_find(sv, PERL_MAGIC_fm);
5103 sv_upgrade(sv, SVt_PVMG);
5107 /* still the same as previously-compiled string? */
5108 SV *old = mg->mg_obj;
5109 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5110 && len == SvCUR(old)
5111 && strnEQ(SvPVX(old), SvPVX(sv), len)
5113 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5117 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5118 Safefree(mg->mg_ptr);
5124 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5125 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5128 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5129 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5133 /* estimate the buffer size needed */
5134 for (base = s; s <= send; s++) {
5135 if (*s == '\n' || *s == '@' || *s == '^')
5141 Newx(fops, maxops, U32);
5146 *fpc++ = FF_LINEMARK;
5147 noblank = repeat = FALSE;
5165 case ' ': case '\t':
5172 } /* else FALL THROUGH */
5180 *fpc++ = FF_LITERAL;
5188 *fpc++ = (U32)skipspaces;
5192 *fpc++ = FF_NEWLINE;
5196 arg = fpc - linepc + 1;
5203 *fpc++ = FF_LINEMARK;
5204 noblank = repeat = FALSE;
5213 ischop = s[-1] == '^';
5219 arg = (s - base) - 1;
5221 *fpc++ = FF_LITERAL;
5227 if (*s == '*') { /* @* or ^* */
5229 *fpc++ = 2; /* skip the @* or ^* */
5231 *fpc++ = FF_LINESNGL;
5234 *fpc++ = FF_LINEGLOB;
5236 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5237 arg = ischop ? FORM_NUM_BLANK : 0;
5242 const char * const f = ++s;
5245 arg |= FORM_NUM_POINT + (s - f);
5247 *fpc++ = s - base; /* fieldsize for FETCH */
5248 *fpc++ = FF_DECIMAL;
5250 unchopnum |= ! ischop;
5252 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5253 arg = ischop ? FORM_NUM_BLANK : 0;
5255 s++; /* skip the '0' first */
5259 const char * const f = ++s;
5262 arg |= FORM_NUM_POINT + (s - f);
5264 *fpc++ = s - base; /* fieldsize for FETCH */
5265 *fpc++ = FF_0DECIMAL;
5267 unchopnum |= ! ischop;
5269 else { /* text field */
5271 bool ismore = FALSE;
5274 while (*++s == '>') ;
5275 prespace = FF_SPACE;
5277 else if (*s == '|') {
5278 while (*++s == '|') ;
5279 prespace = FF_HALFSPACE;
5284 while (*++s == '<') ;
5287 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5291 *fpc++ = s - base; /* fieldsize for FETCH */
5293 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5296 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5310 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5313 mg->mg_ptr = (char *) fops;
5314 mg->mg_len = arg * sizeof(U32);
5315 mg->mg_obj = sv_copy;
5316 mg->mg_flags |= MGf_REFCOUNTED;
5318 if (unchopnum && repeat)
5319 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5326 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5328 /* Can value be printed in fldsize chars, using %*.*f ? */
5332 int intsize = fldsize - (value < 0 ? 1 : 0);
5334 if (frcsize & FORM_NUM_POINT)
5336 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5339 while (intsize--) pwr *= 10.0;
5340 while (frcsize--) eps /= 10.0;
5343 if (value + eps >= pwr)
5346 if (value - eps <= -pwr)
5353 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5356 SV * const datasv = FILTER_DATA(idx);
5357 const int filter_has_file = IoLINES(datasv);
5358 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5359 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5364 char *prune_from = NULL;
5365 bool read_from_cache = FALSE;
5369 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5371 assert(maxlen >= 0);
5374 /* I was having segfault trouble under Linux 2.2.5 after a
5375 parse error occured. (Had to hack around it with a test
5376 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5377 not sure where the trouble is yet. XXX */
5380 SV *const cache = datasv;
5383 const char *cache_p = SvPV(cache, cache_len);
5387 /* Running in block mode and we have some cached data already.
5389 if (cache_len >= umaxlen) {
5390 /* In fact, so much data we don't even need to call
5395 const char *const first_nl =
5396 (const char *)memchr(cache_p, '\n', cache_len);
5398 take = first_nl + 1 - cache_p;
5402 sv_catpvn(buf_sv, cache_p, take);
5403 sv_chop(cache, cache_p + take);
5404 /* Definitely not EOF */
5408 sv_catsv(buf_sv, cache);
5410 umaxlen -= cache_len;
5413 read_from_cache = TRUE;
5417 /* Filter API says that the filter appends to the contents of the buffer.
5418 Usually the buffer is "", so the details don't matter. But if it's not,
5419 then clearly what it contains is already filtered by this filter, so we
5420 don't want to pass it in a second time.
5421 I'm going to use a mortal in case the upstream filter croaks. */
5422 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5423 ? sv_newmortal() : buf_sv;
5424 SvUPGRADE(upstream, SVt_PV);
5426 if (filter_has_file) {
5427 status = FILTER_READ(idx+1, upstream, 0);
5430 if (filter_sub && status >= 0) {
5434 ENTER_with_name("call_filter_sub");
5439 DEFSV_set(upstream);
5443 PUSHs(filter_state);
5446 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5456 SV * const errsv = ERRSV;
5457 if (SvTRUE_NN(errsv))
5458 err = newSVsv(errsv);
5464 LEAVE_with_name("call_filter_sub");
5467 if (SvGMAGICAL(upstream)) {
5469 if (upstream == buf_sv) mg_free(buf_sv);
5471 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5472 if(!err && SvOK(upstream)) {
5473 got_p = SvPV_nomg(upstream, got_len);
5475 if (got_len > umaxlen) {
5476 prune_from = got_p + umaxlen;
5479 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5480 if (first_nl && first_nl + 1 < got_p + got_len) {
5481 /* There's a second line here... */
5482 prune_from = first_nl + 1;
5486 if (!err && prune_from) {
5487 /* Oh. Too long. Stuff some in our cache. */
5488 STRLEN cached_len = got_p + got_len - prune_from;
5489 SV *const cache = datasv;
5492 /* Cache should be empty. */
5493 assert(!SvCUR(cache));
5496 sv_setpvn(cache, prune_from, cached_len);
5497 /* If you ask for block mode, you may well split UTF-8 characters.
5498 "If it breaks, you get to keep both parts"
5499 (Your code is broken if you don't put them back together again
5500 before something notices.) */
5501 if (SvUTF8(upstream)) {
5504 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5506 /* Cannot just use sv_setpvn, as that could free the buffer
5507 before we have a chance to assign it. */
5508 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5509 got_len - cached_len);
5511 /* Can't yet be EOF */
5516 /* If they are at EOF but buf_sv has something in it, then they may never
5517 have touched the SV upstream, so it may be undefined. If we naively
5518 concatenate it then we get a warning about use of uninitialised value.
5520 if (!err && upstream != buf_sv &&
5522 sv_catsv_nomg(buf_sv, upstream);
5524 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5527 IoLINES(datasv) = 0;
5529 SvREFCNT_dec(filter_state);
5530 IoTOP_GV(datasv) = NULL;
5533 SvREFCNT_dec(filter_sub);
5534 IoBOTTOM_GV(datasv) = NULL;
5536 filter_del(S_run_user_filter);
5542 if (status == 0 && read_from_cache) {
5543 /* If we read some data from the cache (and by getting here it implies
5544 that we emptied the cache) then we aren't yet at EOF, and mustn't
5545 report that to our caller. */
5553 * c-indentation-style: bsd
5555 * indent-tabs-mode: nil
5558 * ex: set ts=8 sts=4 sw=4 et: