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);
217 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
219 if (cx->sb_iters++) {
220 const I32 saviters = cx->sb_iters;
221 if (cx->sb_iters > cx->sb_maxiters)
222 DIE(aTHX_ "Substitution loop");
224 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
226 /* See "how taint works" above pp_subst() */
228 cx->sb_rxtainted |= SUBST_TAINT_REPL;
229 sv_catsv_nomg(dstr, POPs);
230 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
234 if (CxONCE(cx) || s < orig ||
235 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
236 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
237 (REXEC_IGNOREPOS|REXEC_NOT_FIRST)))
239 SV *targ = cx->sb_targ;
241 assert(cx->sb_strend >= s);
242 if(cx->sb_strend > s) {
243 if (DO_UTF8(dstr) && !SvUTF8(targ))
244 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
246 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
248 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
249 cx->sb_rxtainted |= SUBST_TAINT_PAT;
251 if (pm->op_pmflags & PMf_NONDESTRUCT) {
253 /* From here on down we're using the copy, and leaving the
254 original untouched. */
259 sv_force_normal_flags(targ, SV_COW_DROP_PV);
264 SvPV_set(targ, SvPVX(dstr));
265 SvCUR_set(targ, SvCUR(dstr));
266 SvLEN_set(targ, SvLEN(dstr));
269 SvPV_set(dstr, NULL);
272 mPUSHi(saviters - 1);
274 (void)SvPOK_only_UTF8(targ);
277 /* update the taint state of various various variables in
278 * preparation for final exit.
279 * See "how taint works" above pp_subst() */
281 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
282 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
283 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
285 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
287 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
288 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
290 SvTAINTED_on(TOPs); /* taint return value */
291 /* needed for mg_set below */
293 cBOOL(cx->sb_rxtainted &
294 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
298 /* PL_tainted must be correctly set for this mg_set */
301 LEAVE_SCOPE(cx->sb_oldsave);
304 RETURNOP(pm->op_next);
305 assert(0); /* NOTREACHED */
307 cx->sb_iters = saviters;
309 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
312 assert(!RX_SUBOFFSET(rx));
313 cx->sb_orig = orig = RX_SUBBEG(rx);
315 cx->sb_strend = s + (cx->sb_strend - m);
317 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
319 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
320 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
322 sv_catpvn_nomg(dstr, s, m-s);
324 cx->sb_s = RX_OFFS(rx)[0].end + orig;
325 { /* Update the pos() information. */
327 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
329 SvUPGRADE(sv, SVt_PVMG);
330 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
331 #ifdef PERL_OLD_COPY_ON_WRITE
333 sv_force_normal_flags(sv, 0);
335 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
338 mg->mg_len = m - orig;
341 (void)ReREFCNT_inc(rx);
342 /* update the taint state of various various variables in preparation
343 * for calling the code block.
344 * See "how taint works" above pp_subst() */
346 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
347 cx->sb_rxtainted |= SUBST_TAINT_PAT;
349 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
350 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
351 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
353 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
355 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
356 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
357 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
358 ? cx->sb_dstr : cx->sb_targ);
361 rxres_save(&cx->sb_rxres, rx);
363 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
367 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
372 PERL_ARGS_ASSERT_RXRES_SAVE;
375 if (!p || p[1] < RX_NPARENS(rx)) {
377 i = 7 + (RX_NPARENS(rx)+1) * 2;
379 i = 6 + (RX_NPARENS(rx)+1) * 2;
388 /* what (if anything) to free on croak */
389 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
390 RX_MATCH_COPIED_off(rx);
391 *p++ = RX_NPARENS(rx);
394 *p++ = PTR2UV(RX_SAVED_COPY(rx));
395 RX_SAVED_COPY(rx) = NULL;
398 *p++ = PTR2UV(RX_SUBBEG(rx));
399 *p++ = (UV)RX_SUBLEN(rx);
400 *p++ = (UV)RX_SUBOFFSET(rx);
401 *p++ = (UV)RX_SUBCOFFSET(rx);
402 for (i = 0; i <= RX_NPARENS(rx); ++i) {
403 *p++ = (UV)RX_OFFS(rx)[i].start;
404 *p++ = (UV)RX_OFFS(rx)[i].end;
409 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
414 PERL_ARGS_ASSERT_RXRES_RESTORE;
417 RX_MATCH_COPY_FREE(rx);
418 RX_MATCH_COPIED_set(rx, *p);
420 RX_NPARENS(rx) = *p++;
423 if (RX_SAVED_COPY(rx))
424 SvREFCNT_dec (RX_SAVED_COPY(rx));
425 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
429 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
430 RX_SUBLEN(rx) = (I32)(*p++);
431 RX_SUBOFFSET(rx) = (I32)*p++;
432 RX_SUBCOFFSET(rx) = (I32)*p++;
433 for (i = 0; i <= RX_NPARENS(rx); ++i) {
434 RX_OFFS(rx)[i].start = (I32)(*p++);
435 RX_OFFS(rx)[i].end = (I32)(*p++);
440 S_rxres_free(pTHX_ void **rsp)
442 UV * const p = (UV*)*rsp;
444 PERL_ARGS_ASSERT_RXRES_FREE;
448 void *tmp = INT2PTR(char*,*p);
451 U32 i = 9 + p[1] * 2;
453 U32 i = 8 + p[1] * 2;
458 SvREFCNT_dec (INT2PTR(SV*,p[2]));
461 PoisonFree(p, i, sizeof(UV));
470 #define FORM_NUM_BLANK (1<<30)
471 #define FORM_NUM_POINT (1<<29)
475 dVAR; dSP; dMARK; dORIGMARK;
476 SV * const tmpForm = *++MARK;
477 SV *formsv; /* contains text of original format */
478 U32 *fpc; /* format ops program counter */
479 char *t; /* current append position in target string */
480 const char *f; /* current position in format string */
482 SV *sv = NULL; /* current item */
483 const char *item = NULL;/* string value of current item */
484 I32 itemsize = 0; /* length of current item, possibly truncated */
485 I32 fieldsize = 0; /* width of current field */
486 I32 lines = 0; /* number of lines that have been output */
487 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
488 const char *chophere = NULL; /* where to chop current item */
489 STRLEN linemark = 0; /* pos of start of line in output */
491 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
493 STRLEN linemax; /* estimate of output size in bytes */
494 bool item_is_utf8 = FALSE;
495 bool targ_is_utf8 = FALSE;
498 U8 *source; /* source of bytes to append */
499 STRLEN to_copy; /* how may bytes to append */
500 char trans; /* what chars to translate */
502 mg = doparseform(tmpForm);
504 fpc = (U32*)mg->mg_ptr;
505 /* the actual string the format was compiled from.
506 * with overload etc, this may not match tmpForm */
510 SvPV_force(PL_formtarget, len);
511 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
512 SvTAINTED_on(PL_formtarget);
513 if (DO_UTF8(PL_formtarget))
515 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
516 t = SvGROW(PL_formtarget, len + linemax + 1);
517 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
519 f = SvPV_const(formsv, len);
523 const char *name = "???";
526 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
527 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
528 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
529 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
530 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
532 case FF_CHECKNL: name = "CHECKNL"; break;
533 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
534 case FF_SPACE: name = "SPACE"; break;
535 case FF_HALFSPACE: name = "HALFSPACE"; break;
536 case FF_ITEM: name = "ITEM"; break;
537 case FF_CHOP: name = "CHOP"; break;
538 case FF_LINEGLOB: name = "LINEGLOB"; break;
539 case FF_NEWLINE: name = "NEWLINE"; break;
540 case FF_MORE: name = "MORE"; break;
541 case FF_LINEMARK: name = "LINEMARK"; break;
542 case FF_END: name = "END"; break;
543 case FF_0DECIMAL: name = "0DECIMAL"; break;
544 case FF_LINESNGL: name = "LINESNGL"; break;
547 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
549 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
553 linemark = t - SvPVX(PL_formtarget);
563 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
579 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
582 SvTAINTED_on(PL_formtarget);
588 const char *s = item = SvPV_const(sv, len);
591 itemsize = sv_len_utf8(sv);
592 if (itemsize != (I32)len) {
594 if (itemsize > fieldsize) {
595 itemsize = fieldsize;
596 itembytes = itemsize;
597 sv_pos_u2b(sv, &itembytes, 0);
601 send = chophere = s + itembytes;
611 sv_pos_b2u(sv, &itemsize);
615 item_is_utf8 = FALSE;
616 if (itemsize > fieldsize)
617 itemsize = fieldsize;
618 send = chophere = s + itemsize;
632 const char *s = item = SvPV_const(sv, len);
635 itemsize = sv_len_utf8(sv);
636 if (itemsize != (I32)len) {
638 if (itemsize <= fieldsize) {
639 const char *send = chophere = s + itemsize;
652 itemsize = fieldsize;
653 itembytes = itemsize;
654 sv_pos_u2b(sv, &itembytes, 0);
655 send = chophere = s + itembytes;
656 while (s < send || (s == send && isSPACE(*s))) {
666 if (strchr(PL_chopset, *s))
671 itemsize = chophere - item;
672 sv_pos_b2u(sv, &itemsize);
678 item_is_utf8 = FALSE;
679 if (itemsize <= fieldsize) {
680 const char *const send = chophere = s + itemsize;
693 itemsize = fieldsize;
694 send = chophere = s + itemsize;
695 while (s < send || (s == send && isSPACE(*s))) {
705 if (strchr(PL_chopset, *s))
710 itemsize = chophere - item;
716 arg = fieldsize - itemsize;
725 arg = fieldsize - itemsize;
739 /* convert to_copy from chars to bytes */
743 to_copy = s - source;
749 const char *s = chophere;
763 const bool oneline = fpc[-1] == FF_LINESNGL;
764 const char *s = item = SvPV_const(sv, len);
765 const char *const send = s + len;
767 item_is_utf8 = DO_UTF8(sv);
778 to_copy = s - SvPVX_const(sv) - 1;
792 /* append to_copy bytes from source to PL_formstring.
793 * item_is_utf8 implies source is utf8.
794 * if trans, translate certain characters during the copy */
799 SvCUR_set(PL_formtarget,
800 t - SvPVX_const(PL_formtarget));
802 if (targ_is_utf8 && !item_is_utf8) {
803 source = tmp = bytes_to_utf8(source, &to_copy);
805 if (item_is_utf8 && !targ_is_utf8) {
807 /* Upgrade targ to UTF8, and then we reduce it to
808 a problem we have a simple solution for.
809 Don't need get magic. */
810 sv_utf8_upgrade_nomg(PL_formtarget);
812 /* re-calculate linemark */
813 s = (U8*)SvPVX(PL_formtarget);
814 /* the bytes we initially allocated to append the
815 * whole line may have been gobbled up during the
816 * upgrade, so allocate a whole new line's worth
821 linemark = s - (U8*)SvPVX(PL_formtarget);
823 /* Easy. They agree. */
824 assert (item_is_utf8 == targ_is_utf8);
827 /* @* and ^* are the only things that can exceed
828 * the linemax, so grow by the output size, plus
829 * a whole new form's worth in case of any further
831 grow = linemax + to_copy;
833 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
834 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
836 Copy(source, t, to_copy, char);
838 /* blank out ~ or control chars, depending on trans.
839 * works on bytes not chars, so relies on not
840 * matching utf8 continuation bytes */
842 U8 *send = s + to_copy;
845 if (trans == '~' ? (ch == '~') :
858 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
866 #if defined(USE_LONG_DOUBLE)
868 ((arg & FORM_NUM_POINT) ?
869 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
872 ((arg & FORM_NUM_POINT) ?
873 "%#0*.*f" : "%0*.*f");
878 #if defined(USE_LONG_DOUBLE)
880 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
883 ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
886 /* If the field is marked with ^ and the value is undefined,
888 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
896 /* overflow evidence */
897 if (num_overflow(value, fieldsize, arg)) {
903 /* Formats aren't yet marked for locales, so assume "yes". */
905 STORE_NUMERIC_STANDARD_SET_LOCAL();
906 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
907 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
908 RESTORE_NUMERIC_STANDARD();
915 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
923 if (arg) { /* repeat until fields exhausted? */
929 t = SvPVX(PL_formtarget) + linemark;
936 const char *s = chophere;
937 const char *send = item + len;
939 while (isSPACE(*s) && (s < send))
944 arg = fieldsize - itemsize;
951 if (strnEQ(s1," ",3)) {
952 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
963 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
965 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
967 SvUTF8_on(PL_formtarget);
968 FmLINES(PL_formtarget) += lines;
970 if (fpc[-1] == FF_BLANK)
971 RETURNOP(cLISTOP->op_first);
983 if (PL_stack_base + *PL_markstack_ptr == SP) {
985 if (GIMME_V == G_SCALAR)
987 RETURNOP(PL_op->op_next->op_next);
989 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
990 Perl_pp_pushmark(aTHX); /* push dst */
991 Perl_pp_pushmark(aTHX); /* push src */
992 ENTER_with_name("grep"); /* enter outer scope */
995 if (PL_op->op_private & OPpGREP_LEX)
996 SAVESPTR(PAD_SVl(PL_op->op_targ));
999 ENTER_with_name("grep_item"); /* enter inner scope */
1002 src = PL_stack_base[*PL_markstack_ptr];
1004 if (PL_op->op_private & OPpGREP_LEX)
1005 PAD_SVl(PL_op->op_targ) = src;
1010 if (PL_op->op_type == OP_MAPSTART)
1011 Perl_pp_pushmark(aTHX); /* push top */
1012 return ((LOGOP*)PL_op->op_next)->op_other;
1018 const I32 gimme = GIMME_V;
1019 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1025 /* first, move source pointer to the next item in the source list */
1026 ++PL_markstack_ptr[-1];
1028 /* if there are new items, push them into the destination list */
1029 if (items && gimme != G_VOID) {
1030 /* might need to make room back there first */
1031 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1032 /* XXX this implementation is very pessimal because the stack
1033 * is repeatedly extended for every set of items. Is possible
1034 * to do this without any stack extension or copying at all
1035 * by maintaining a separate list over which the map iterates
1036 * (like foreach does). --gsar */
1038 /* everything in the stack after the destination list moves
1039 * towards the end the stack by the amount of room needed */
1040 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1042 /* items to shift up (accounting for the moved source pointer) */
1043 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1045 /* This optimization is by Ben Tilly and it does
1046 * things differently from what Sarathy (gsar)
1047 * is describing. The downside of this optimization is
1048 * that leaves "holes" (uninitialized and hopefully unused areas)
1049 * to the Perl stack, but on the other hand this
1050 * shouldn't be a problem. If Sarathy's idea gets
1051 * implemented, this optimization should become
1052 * irrelevant. --jhi */
1054 shift = count; /* Avoid shifting too often --Ben Tilly */
1058 dst = (SP += shift);
1059 PL_markstack_ptr[-1] += shift;
1060 *PL_markstack_ptr += shift;
1064 /* copy the new items down to the destination list */
1065 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1066 if (gimme == G_ARRAY) {
1067 /* add returned items to the collection (making mortal copies
1068 * if necessary), then clear the current temps stack frame
1069 * *except* for those items. We do this splicing the items
1070 * into the start of the tmps frame (so some items may be on
1071 * the tmps stack twice), then moving PL_tmps_floor above
1072 * them, then freeing the frame. That way, the only tmps that
1073 * accumulate over iterations are the return values for map.
1074 * We have to do to this way so that everything gets correctly
1075 * freed if we die during the map.
1079 /* make space for the slice */
1080 EXTEND_MORTAL(items);
1081 tmpsbase = PL_tmps_floor + 1;
1082 Move(PL_tmps_stack + tmpsbase,
1083 PL_tmps_stack + tmpsbase + items,
1084 PL_tmps_ix - PL_tmps_floor,
1086 PL_tmps_ix += items;
1091 sv = sv_mortalcopy(sv);
1093 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1095 /* clear the stack frame except for the items */
1096 PL_tmps_floor += items;
1098 /* FREETMPS may have cleared the TEMP flag on some of the items */
1101 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1104 /* scalar context: we don't care about which values map returns
1105 * (we use undef here). And so we certainly don't want to do mortal
1106 * copies of meaningless values. */
1107 while (items-- > 0) {
1109 *dst-- = &PL_sv_undef;
1117 LEAVE_with_name("grep_item"); /* exit inner scope */
1120 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1122 (void)POPMARK; /* pop top */
1123 LEAVE_with_name("grep"); /* exit outer scope */
1124 (void)POPMARK; /* pop src */
1125 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1126 (void)POPMARK; /* pop dst */
1127 SP = PL_stack_base + POPMARK; /* pop original mark */
1128 if (gimme == G_SCALAR) {
1129 if (PL_op->op_private & OPpGREP_LEX) {
1130 SV* sv = sv_newmortal();
1131 sv_setiv(sv, items);
1139 else if (gimme == G_ARRAY)
1146 ENTER_with_name("grep_item"); /* enter inner scope */
1149 /* set $_ to the new source item */
1150 src = PL_stack_base[PL_markstack_ptr[-1]];
1152 if (PL_op->op_private & OPpGREP_LEX)
1153 PAD_SVl(PL_op->op_targ) = src;
1157 RETURNOP(cLOGOP->op_other);
1166 if (GIMME == G_ARRAY)
1168 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1169 return cLOGOP->op_other;
1179 if (GIMME == G_ARRAY) {
1180 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1184 SV * const targ = PAD_SV(PL_op->op_targ);
1187 if (PL_op->op_private & OPpFLIP_LINENUM) {
1188 if (GvIO(PL_last_in_gv)) {
1189 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1192 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1194 flip = SvIV(sv) == SvIV(GvSV(gv));
1200 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1201 if (PL_op->op_flags & OPf_SPECIAL) {
1209 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1212 sv_setpvs(TARG, "");
1218 /* This code tries to decide if "$left .. $right" should use the
1219 magical string increment, or if the range is numeric (we make
1220 an exception for .."0" [#18165]). AMS 20021031. */
1222 #define RANGE_IS_NUMERIC(left,right) ( \
1223 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1224 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1225 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1226 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1227 && (!SvOK(right) || looks_like_number(right))))
1233 if (GIMME == G_ARRAY) {
1239 if (RANGE_IS_NUMERIC(left,right)) {
1242 if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) ||
1243 (SvOK(right) && SvNV_nomg(right) > IV_MAX))
1244 DIE(aTHX_ "Range iterator outside integer range");
1245 i = SvIV_nomg(left);
1246 max = SvIV_nomg(right);
1255 SV * const sv = sv_2mortal(newSViv(i++));
1261 const char * const lpv = SvPV_nomg_const(left, llen);
1262 const char * const tmps = SvPV_nomg_const(right, len);
1264 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1265 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1267 if (strEQ(SvPVX_const(sv),tmps))
1269 sv = sv_2mortal(newSVsv(sv));
1276 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1280 if (PL_op->op_private & OPpFLIP_LINENUM) {
1281 if (GvIO(PL_last_in_gv)) {
1282 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1285 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1286 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1294 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1295 sv_catpvs(targ, "E0");
1305 static const char * const context_name[] = {
1307 NULL, /* CXt_WHEN never actually needs "block" */
1308 NULL, /* CXt_BLOCK never actually needs "block" */
1309 NULL, /* CXt_GIVEN never actually needs "block" */
1310 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1311 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1312 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1313 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1321 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1326 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1328 for (i = cxstack_ix; i >= 0; i--) {
1329 const PERL_CONTEXT * const cx = &cxstack[i];
1330 switch (CxTYPE(cx)) {
1336 /* diag_listed_as: Exiting subroutine via %s */
1337 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1338 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1339 if (CxTYPE(cx) == CXt_NULL)
1342 case CXt_LOOP_LAZYIV:
1343 case CXt_LOOP_LAZYSV:
1345 case CXt_LOOP_PLAIN:
1347 STRLEN cx_label_len = 0;
1348 U32 cx_label_flags = 0;
1349 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1351 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1354 (const U8*)cx_label, cx_label_len,
1355 (const U8*)label, len) == 0)
1357 (const U8*)label, len,
1358 (const U8*)cx_label, cx_label_len) == 0)
1359 : (len == cx_label_len && ((cx_label == label)
1360 || memEQ(cx_label, label, len))) )) {
1361 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1362 (long)i, cx_label));
1365 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1376 Perl_dowantarray(pTHX)
1379 const I32 gimme = block_gimme();
1380 return (gimme == G_VOID) ? G_SCALAR : gimme;
1384 Perl_block_gimme(pTHX)
1387 const I32 cxix = dopoptosub(cxstack_ix);
1391 switch (cxstack[cxix].blk_gimme) {
1399 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1400 assert(0); /* NOTREACHED */
1406 Perl_is_lvalue_sub(pTHX)
1409 const I32 cxix = dopoptosub(cxstack_ix);
1410 assert(cxix >= 0); /* We should only be called from inside subs */
1412 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1413 return CxLVAL(cxstack + cxix);
1418 /* only used by PUSHSUB */
1420 Perl_was_lvalue_sub(pTHX)
1423 const I32 cxix = dopoptosub(cxstack_ix-1);
1424 assert(cxix >= 0); /* We should only be called from inside subs */
1426 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1427 return CxLVAL(cxstack + cxix);
1433 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1438 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1440 for (i = startingblock; i >= 0; i--) {
1441 const PERL_CONTEXT * const cx = &cxstk[i];
1442 switch (CxTYPE(cx)) {
1446 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1447 * twice; the first for the normal foo() call, and the second
1448 * for a faked up re-entry into the sub to execute the
1449 * code block. Hide this faked entry from the world. */
1450 if (cx->cx_type & CXp_SUB_RE_FAKE)
1454 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1462 S_dopoptoeval(pTHX_ I32 startingblock)
1466 for (i = startingblock; i >= 0; i--) {
1467 const PERL_CONTEXT *cx = &cxstack[i];
1468 switch (CxTYPE(cx)) {
1472 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1480 S_dopoptoloop(pTHX_ I32 startingblock)
1484 for (i = startingblock; i >= 0; i--) {
1485 const PERL_CONTEXT * const cx = &cxstack[i];
1486 switch (CxTYPE(cx)) {
1492 /* diag_listed_as: Exiting subroutine via %s */
1493 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1494 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1495 if ((CxTYPE(cx)) == CXt_NULL)
1498 case CXt_LOOP_LAZYIV:
1499 case CXt_LOOP_LAZYSV:
1501 case CXt_LOOP_PLAIN:
1502 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1510 S_dopoptogiven(pTHX_ I32 startingblock)
1514 for (i = startingblock; i >= 0; i--) {
1515 const PERL_CONTEXT *cx = &cxstack[i];
1516 switch (CxTYPE(cx)) {
1520 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1522 case CXt_LOOP_PLAIN:
1523 assert(!CxFOREACHDEF(cx));
1525 case CXt_LOOP_LAZYIV:
1526 case CXt_LOOP_LAZYSV:
1528 if (CxFOREACHDEF(cx)) {
1529 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1538 S_dopoptowhen(pTHX_ I32 startingblock)
1542 for (i = startingblock; i >= 0; i--) {
1543 const PERL_CONTEXT *cx = &cxstack[i];
1544 switch (CxTYPE(cx)) {
1548 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1556 Perl_dounwind(pTHX_ I32 cxix)
1561 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1564 while (cxstack_ix > cxix) {
1566 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1567 DEBUG_CX("UNWIND"); \
1568 /* Note: we don't need to restore the base context info till the end. */
1569 switch (CxTYPE(cx)) {
1572 continue; /* not break */
1580 case CXt_LOOP_LAZYIV:
1581 case CXt_LOOP_LAZYSV:
1583 case CXt_LOOP_PLAIN:
1594 PERL_UNUSED_VAR(optype);
1598 Perl_qerror(pTHX_ SV *err)
1602 PERL_ARGS_ASSERT_QERROR;
1605 if (PL_in_eval & EVAL_KEEPERR) {
1606 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1610 sv_catsv(ERRSV, err);
1613 sv_catsv(PL_errors, err);
1615 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1617 ++PL_parser->error_count;
1621 Perl_die_unwind(pTHX_ SV *msv)
1624 SV *exceptsv = sv_mortalcopy(msv);
1625 U8 in_eval = PL_in_eval;
1626 PERL_ARGS_ASSERT_DIE_UNWIND;
1633 * Historically, perl used to set ERRSV ($@) early in the die
1634 * process and rely on it not getting clobbered during unwinding.
1635 * That sucked, because it was liable to get clobbered, so the
1636 * setting of ERRSV used to emit the exception from eval{} has
1637 * been moved to much later, after unwinding (see just before
1638 * JMPENV_JUMP below). However, some modules were relying on the
1639 * early setting, by examining $@ during unwinding to use it as
1640 * a flag indicating whether the current unwinding was caused by
1641 * an exception. It was never a reliable flag for that purpose,
1642 * being totally open to false positives even without actual
1643 * clobberage, but was useful enough for production code to
1644 * semantically rely on it.
1646 * We'd like to have a proper introspective interface that
1647 * explicitly describes the reason for whatever unwinding
1648 * operations are currently in progress, so that those modules
1649 * work reliably and $@ isn't further overloaded. But we don't
1650 * have one yet. In its absence, as a stopgap measure, ERRSV is
1651 * now *additionally* set here, before unwinding, to serve as the
1652 * (unreliable) flag that it used to.
1654 * This behaviour is temporary, and should be removed when a
1655 * proper way to detect exceptional unwinding has been developed.
1656 * As of 2010-12, the authors of modules relying on the hack
1657 * are aware of the issue, because the modules failed on
1658 * perls 5.13.{1..7} which had late setting of $@ without this
1659 * early-setting hack.
1661 if (!(in_eval & EVAL_KEEPERR)) {
1662 SvTEMP_off(exceptsv);
1663 sv_setsv(ERRSV, exceptsv);
1666 if (in_eval & EVAL_KEEPERR) {
1667 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1671 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1672 && PL_curstackinfo->si_prev)
1684 JMPENV *restartjmpenv;
1687 if (cxix < cxstack_ix)
1690 POPBLOCK(cx,PL_curpm);
1691 if (CxTYPE(cx) != CXt_EVAL) {
1693 const char* message = SvPVx_const(exceptsv, msglen);
1694 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1695 PerlIO_write(Perl_error_log, message, msglen);
1699 namesv = cx->blk_eval.old_namesv;
1700 oldcop = cx->blk_oldcop;
1701 restartjmpenv = cx->blk_eval.cur_top_env;
1702 restartop = cx->blk_eval.retop;
1704 if (gimme == G_SCALAR)
1705 *++newsp = &PL_sv_undef;
1706 PL_stack_sp = newsp;
1710 /* LEAVE could clobber PL_curcop (see save_re_context())
1711 * XXX it might be better to find a way to avoid messing with
1712 * PL_curcop in save_re_context() instead, but this is a more
1713 * minimal fix --GSAR */
1716 if (optype == OP_REQUIRE) {
1717 (void)hv_store(GvHVn(PL_incgv),
1718 SvPVX_const(namesv),
1719 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1721 /* note that unlike pp_entereval, pp_require isn't
1722 * supposed to trap errors. So now that we've popped the
1723 * EVAL that pp_require pushed, and processed the error
1724 * message, rethrow the error */
1725 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1726 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1729 if (!(in_eval & EVAL_KEEPERR))
1730 sv_setsv(ERRSV, exceptsv);
1731 PL_restartjmpenv = restartjmpenv;
1732 PL_restartop = restartop;
1734 assert(0); /* NOTREACHED */
1738 write_to_stderr(exceptsv);
1740 assert(0); /* NOTREACHED */
1745 dVAR; dSP; dPOPTOPssrl;
1746 if (SvTRUE(left) != SvTRUE(right))
1753 =for apidoc caller_cx
1755 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1756 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1757 information returned to Perl by C<caller>. Note that XSUBs don't get a
1758 stack frame, so C<caller_cx(0, NULL)> will return information for the
1759 immediately-surrounding Perl code.
1761 This function skips over the automatic calls to C<&DB::sub> made on the
1762 behalf of the debugger. If the stack frame requested was a sub called by
1763 C<DB::sub>, the return value will be the frame for the call to
1764 C<DB::sub>, since that has the correct line number/etc. for the call
1765 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1766 frame for the sub call itself.
1771 const PERL_CONTEXT *
1772 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1774 I32 cxix = dopoptosub(cxstack_ix);
1775 const PERL_CONTEXT *cx;
1776 const PERL_CONTEXT *ccstack = cxstack;
1777 const PERL_SI *top_si = PL_curstackinfo;
1780 /* we may be in a higher stacklevel, so dig down deeper */
1781 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1782 top_si = top_si->si_prev;
1783 ccstack = top_si->si_cxstack;
1784 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1788 /* caller() should not report the automatic calls to &DB::sub */
1789 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1790 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1794 cxix = dopoptosub_at(ccstack, cxix - 1);
1797 cx = &ccstack[cxix];
1798 if (dbcxp) *dbcxp = cx;
1800 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1801 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1802 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1803 field below is defined for any cx. */
1804 /* caller() should not report the automatic calls to &DB::sub */
1805 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1806 cx = &ccstack[dbcxix];
1816 const PERL_CONTEXT *cx;
1817 const PERL_CONTEXT *dbcx;
1819 const HEK *stash_hek;
1821 bool has_arg = MAXARG && TOPs;
1829 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1831 if (GIMME != G_ARRAY) {
1839 assert(CopSTASH(cx->blk_oldcop));
1840 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1841 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1843 if (GIMME != G_ARRAY) {
1846 PUSHs(&PL_sv_undef);
1849 sv_sethek(TARG, stash_hek);
1858 PUSHs(&PL_sv_undef);
1861 sv_sethek(TARG, stash_hek);
1864 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1865 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1868 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1869 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1870 /* So is ccstack[dbcxix]. */
1871 if (cvgv && isGV(cvgv)) {
1872 SV * const sv = newSV(0);
1873 gv_efullname3(sv, cvgv, NULL);
1875 PUSHs(boolSV(CxHASARGS(cx)));
1878 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1879 PUSHs(boolSV(CxHASARGS(cx)));
1883 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1886 gimme = (I32)cx->blk_gimme;
1887 if (gimme == G_VOID)
1888 PUSHs(&PL_sv_undef);
1890 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1891 if (CxTYPE(cx) == CXt_EVAL) {
1893 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1894 PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
1895 SvCUR(cx->blk_eval.cur_text)-2,
1896 SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
1900 else if (cx->blk_eval.old_namesv) {
1901 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1904 /* eval BLOCK (try blocks have old_namesv == 0) */
1906 PUSHs(&PL_sv_undef);
1907 PUSHs(&PL_sv_undef);
1911 PUSHs(&PL_sv_undef);
1912 PUSHs(&PL_sv_undef);
1914 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1915 && CopSTASH_eq(PL_curcop, PL_debstash))
1917 AV * const ary = cx->blk_sub.argarray;
1918 const int off = AvARRAY(ary) - AvALLOC(ary);
1920 Perl_init_dbargs(aTHX);
1922 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1923 av_extend(PL_dbargs, AvFILLp(ary) + off);
1924 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1925 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1927 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1930 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1932 if (old_warnings == pWARN_NONE)
1933 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1934 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1935 mask = &PL_sv_undef ;
1936 else if (old_warnings == pWARN_ALL ||
1937 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1938 /* Get the bit mask for $warnings::Bits{all}, because
1939 * it could have been extended by warnings::register */
1941 HV * const bits = get_hv("warnings::Bits", 0);
1942 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1943 mask = newSVsv(*bits_all);
1946 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1950 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1954 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1955 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1966 if (MAXARG < 1 || (!TOPs && !POPs))
1967 tmps = NULL, len = 0;
1969 tmps = SvPVx_const(POPs, len);
1970 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1975 /* like pp_nextstate, but used instead when the debugger is active */
1980 PL_curcop = (COP*)PL_op;
1981 TAINT_NOT; /* Each statement is presumed innocent */
1982 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1987 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1988 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1992 const I32 gimme = G_ARRAY;
1994 GV * const gv = PL_DBgv;
1997 if (gv && isGV_with_GP(gv))
2000 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2001 DIE(aTHX_ "No DB::DB routine defined");
2003 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2004 /* don't do recursive DB::DB call */
2018 (void)(*CvXSUB(cv))(aTHX_ cv);
2024 PUSHBLOCK(cx, CXt_SUB, SP);
2026 cx->blk_sub.retop = PL_op->op_next;
2028 if (CvDEPTH(cv) >= 2) {
2029 PERL_STACK_OVERFLOW_CHECK();
2030 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2033 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2034 RETURNOP(CvSTART(cv));
2042 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
2045 PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2047 if (flags & SVs_PADTMP) {
2048 flags &= ~SVs_PADTMP;
2051 if (gimme == G_SCALAR) {
2053 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2054 ? *SP : sv_mortalcopy(*SP);
2056 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2059 *++MARK = &PL_sv_undef;
2063 else if (gimme == G_ARRAY) {
2064 /* in case LEAVE wipes old return values */
2065 while (++MARK <= SP) {
2066 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2069 *++newsp = sv_mortalcopy(*MARK);
2070 TAINT_NOT; /* Each item is independent */
2073 /* When this function was called with MARK == newsp, we reach this
2074 * point with SP == newsp. */
2084 I32 gimme = GIMME_V;
2086 ENTER_with_name("block");
2089 PUSHBLOCK(cx, CXt_BLOCK, SP);
2102 if (PL_op->op_flags & OPf_SPECIAL) {
2103 cx = &cxstack[cxstack_ix];
2104 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2109 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2112 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
2113 PL_curpm = newpm; /* Don't pop $1 et al till now */
2115 LEAVE_with_name("block");
2124 const I32 gimme = GIMME_V;
2125 void *itervar; /* location of the iteration variable */
2126 U8 cxtype = CXt_LOOP_FOR;
2128 ENTER_with_name("loop1");
2131 if (PL_op->op_targ) { /* "my" variable */
2132 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2133 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2134 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2135 SVs_PADSTALE, SVs_PADSTALE);
2137 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2139 itervar = PL_comppad;
2141 itervar = &PAD_SVl(PL_op->op_targ);
2144 else { /* symbol table variable */
2145 GV * const gv = MUTABLE_GV(POPs);
2146 SV** svp = &GvSV(gv);
2147 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2149 itervar = (void *)gv;
2152 if (PL_op->op_private & OPpITER_DEF)
2153 cxtype |= CXp_FOR_DEF;
2155 ENTER_with_name("loop2");
2157 PUSHBLOCK(cx, cxtype, SP);
2158 PUSHLOOP_FOR(cx, itervar, MARK);
2159 if (PL_op->op_flags & OPf_STACKED) {
2160 SV *maybe_ary = POPs;
2161 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2163 SV * const right = maybe_ary;
2166 if (RANGE_IS_NUMERIC(sv,right)) {
2167 cx->cx_type &= ~CXTYPEMASK;
2168 cx->cx_type |= CXt_LOOP_LAZYIV;
2169 /* Make sure that no-one re-orders cop.h and breaks our
2171 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2172 #ifdef NV_PRESERVES_UV
2173 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2174 (SvNV_nomg(sv) > (NV)IV_MAX)))
2176 (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2177 (SvNV_nomg(right) < (NV)IV_MIN))))
2179 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
2181 ((SvNV_nomg(sv) > 0) &&
2182 ((SvUV_nomg(sv) > (UV)IV_MAX) ||
2183 (SvNV_nomg(sv) > (NV)UV_MAX)))))
2185 (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
2187 ((SvNV_nomg(right) > 0) &&
2188 ((SvUV_nomg(right) > (UV)IV_MAX) ||
2189 (SvNV_nomg(right) > (NV)UV_MAX))
2192 DIE(aTHX_ "Range iterator outside integer range");
2193 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2194 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2196 /* for correct -Dstv display */
2197 cx->blk_oldsp = sp - PL_stack_base;
2201 cx->cx_type &= ~CXTYPEMASK;
2202 cx->cx_type |= CXt_LOOP_LAZYSV;
2203 /* Make sure that no-one re-orders cop.h and breaks our
2205 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2206 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2207 cx->blk_loop.state_u.lazysv.end = right;
2208 SvREFCNT_inc(right);
2209 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2210 /* This will do the upgrade to SVt_PV, and warn if the value
2211 is uninitialised. */
2212 (void) SvPV_nolen_const(right);
2213 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2214 to replace !SvOK() with a pointer to "". */
2216 SvREFCNT_dec(right);
2217 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2221 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2222 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2223 SvREFCNT_inc(maybe_ary);
2224 cx->blk_loop.state_u.ary.ix =
2225 (PL_op->op_private & OPpITER_REVERSED) ?
2226 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2230 else { /* iterating over items on the stack */
2231 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2232 if (PL_op->op_private & OPpITER_REVERSED) {
2233 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2236 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2247 const I32 gimme = GIMME_V;
2249 ENTER_with_name("loop1");
2251 ENTER_with_name("loop2");
2253 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2254 PUSHLOOP_PLAIN(cx, SP);
2269 assert(CxTYPE_is_LOOP(cx));
2271 newsp = PL_stack_base + cx->blk_loop.resetsp;
2274 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
2277 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2278 PL_curpm = newpm; /* ... and pop $1 et al */
2280 LEAVE_with_name("loop2");
2281 LEAVE_with_name("loop1");
2287 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2288 PERL_CONTEXT *cx, PMOP *newpm)
2290 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2291 if (gimme == G_SCALAR) {
2292 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2294 const char *what = NULL;
2296 assert(MARK+1 == SP);
2297 if ((SvPADTMP(TOPs) ||
2298 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2301 !SvSMAGICAL(TOPs)) {
2303 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2304 : "a readonly value" : "a temporary";
2309 /* sub:lvalue{} will take us here. */
2318 "Can't return %s from lvalue subroutine", what
2323 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2324 if (!SvPADTMP(*SP)) {
2325 *++newsp = SvREFCNT_inc(*SP);
2330 /* FREETMPS could clobber it */
2331 SV *sv = SvREFCNT_inc(*SP);
2333 *++newsp = sv_mortalcopy(sv);
2340 ? sv_mortalcopy(*SP)
2342 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2347 *++newsp = &PL_sv_undef;
2349 if (CxLVAL(cx) & OPpDEREF) {
2352 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2356 else if (gimme == G_ARRAY) {
2357 assert (!(CxLVAL(cx) & OPpDEREF));
2358 if (ref || !CxLVAL(cx))
2359 while (++MARK <= SP)
2361 SvFLAGS(*MARK) & SVs_PADTMP
2362 ? sv_mortalcopy(*MARK)
2365 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2366 else while (++MARK <= SP) {
2367 if (*MARK != &PL_sv_undef
2369 || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2374 /* Might be flattened array after $#array = */
2381 /* diag_listed_as: Can't return %s from lvalue subroutine */
2383 "Can't return a %s from lvalue subroutine",
2384 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2390 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2393 PL_stack_sp = newsp;
2400 bool popsub2 = FALSE;
2401 bool clear_errsv = FALSE;
2411 const I32 cxix = dopoptosub(cxstack_ix);
2414 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2415 * sort block, which is a CXt_NULL
2418 PL_stack_base[1] = *PL_stack_sp;
2419 PL_stack_sp = PL_stack_base + 1;
2423 DIE(aTHX_ "Can't return outside a subroutine");
2425 if (cxix < cxstack_ix)
2428 if (CxMULTICALL(&cxstack[cxix])) {
2429 gimme = cxstack[cxix].blk_gimme;
2430 if (gimme == G_VOID)
2431 PL_stack_sp = PL_stack_base;
2432 else if (gimme == G_SCALAR) {
2433 PL_stack_base[1] = *PL_stack_sp;
2434 PL_stack_sp = PL_stack_base + 1;
2440 switch (CxTYPE(cx)) {
2443 lval = !!CvLVALUE(cx->blk_sub.cv);
2444 retop = cx->blk_sub.retop;
2445 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2448 if (!(PL_in_eval & EVAL_KEEPERR))
2451 namesv = cx->blk_eval.old_namesv;
2452 retop = cx->blk_eval.retop;
2455 if (optype == OP_REQUIRE &&
2456 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2458 /* Unassume the success we assumed earlier. */
2459 (void)hv_delete(GvHVn(PL_incgv),
2460 SvPVX_const(namesv),
2461 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2463 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2468 retop = cx->blk_sub.retop;
2471 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2475 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2477 if (gimme == G_SCALAR) {
2480 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2481 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2482 && !SvMAGICAL(TOPs)) {
2483 *++newsp = SvREFCNT_inc(*SP);
2488 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2490 *++newsp = sv_mortalcopy(sv);
2494 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2495 && !SvMAGICAL(*SP)) {
2499 *++newsp = sv_mortalcopy(*SP);
2502 *++newsp = sv_mortalcopy(*SP);
2505 *++newsp = &PL_sv_undef;
2507 else if (gimme == G_ARRAY) {
2508 while (++MARK <= SP) {
2509 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2510 && !SvGMAGICAL(*MARK)
2511 ? *MARK : sv_mortalcopy(*MARK);
2512 TAINT_NOT; /* Each item is independent */
2515 PL_stack_sp = newsp;
2519 /* Stack values are safe: */
2522 POPSUB(cx,sv); /* release CV and @_ ... */
2526 PL_curpm = newpm; /* ... and pop $1 et al */
2535 /* This duplicates parts of pp_leavesub, so that it can share code with
2546 if (CxMULTICALL(&cxstack[cxstack_ix]))
2550 cxstack_ix++; /* temporarily protect top context */
2554 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2558 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2559 PL_curpm = newpm; /* ... and pop $1 et al */
2562 return cx->blk_sub.retop;
2566 S_unwind_loop(pTHX_ const char * const opname)
2570 if (PL_op->op_flags & OPf_SPECIAL) {
2571 cxix = dopoptoloop(cxstack_ix);
2573 /* diag_listed_as: Can't "last" outside a loop block */
2574 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2579 const char * const label =
2580 PL_op->op_flags & OPf_STACKED
2581 ? SvPV(TOPs,label_len)
2582 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2583 const U32 label_flags =
2584 PL_op->op_flags & OPf_STACKED
2586 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2588 cxix = dopoptolabel(label, label_len, label_flags);
2590 /* diag_listed_as: Label not found for "last %s" */
2591 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2593 SVfARG(PL_op->op_flags & OPf_STACKED
2594 && !SvGMAGICAL(TOPp1s)
2596 : newSVpvn_flags(label,
2598 label_flags | SVs_TEMP)));
2600 if (cxix < cxstack_ix)
2618 S_unwind_loop(aTHX_ "last");
2621 cxstack_ix++; /* temporarily protect top context */
2623 switch (CxTYPE(cx)) {
2624 case CXt_LOOP_LAZYIV:
2625 case CXt_LOOP_LAZYSV:
2627 case CXt_LOOP_PLAIN:
2629 newsp = PL_stack_base + cx->blk_loop.resetsp;
2630 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2634 nextop = cx->blk_sub.retop;
2638 nextop = cx->blk_eval.retop;
2642 nextop = cx->blk_sub.retop;
2645 DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2649 PL_stack_sp = adjust_stack_on_leave(newsp, PL_stack_sp, MARK, gimme,
2650 pop2 == CXt_SUB ? SVs_TEMP : 0);
2654 /* Stack values are safe: */
2656 case CXt_LOOP_LAZYIV:
2657 case CXt_LOOP_PLAIN:
2658 case CXt_LOOP_LAZYSV:
2660 POPLOOP(cx); /* release loop vars ... */
2664 POPSUB(cx,sv); /* release CV and @_ ... */
2667 PL_curpm = newpm; /* ... and pop $1 et al */
2670 PERL_UNUSED_VAR(optype);
2671 PERL_UNUSED_VAR(gimme);
2679 const I32 inner = PL_scopestack_ix;
2681 S_unwind_loop(aTHX_ "next");
2683 /* clear off anything above the scope we're re-entering, but
2684 * save the rest until after a possible continue block */
2686 if (PL_scopestack_ix < inner)
2687 leave_scope(PL_scopestack[PL_scopestack_ix]);
2688 PL_curcop = cx->blk_oldcop;
2690 return (cx)->blk_loop.my_op->op_nextop;
2696 const I32 cxix = S_unwind_loop(aTHX_ "redo");
2699 OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2701 if (redo_op->op_type == OP_ENTER) {
2702 /* pop one less context to avoid $x being freed in while (my $x..) */
2704 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2705 redo_op = redo_op->op_next;
2709 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2710 LEAVE_SCOPE(oldsave);
2712 PL_curcop = cx->blk_oldcop;
2718 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2722 static const char* const too_deep = "Target of goto is too deeply nested";
2724 PERL_ARGS_ASSERT_DOFINDLABEL;
2727 Perl_croak(aTHX_ "%s", too_deep);
2728 if (o->op_type == OP_LEAVE ||
2729 o->op_type == OP_SCOPE ||
2730 o->op_type == OP_LEAVELOOP ||
2731 o->op_type == OP_LEAVESUB ||
2732 o->op_type == OP_LEAVETRY)
2734 *ops++ = cUNOPo->op_first;
2736 Perl_croak(aTHX_ "%s", too_deep);
2739 if (o->op_flags & OPf_KIDS) {
2741 /* First try all the kids at this level, since that's likeliest. */
2742 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2743 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2744 STRLEN kid_label_len;
2745 U32 kid_label_flags;
2746 const char *kid_label = CopLABEL_len_flags(kCOP,
2747 &kid_label_len, &kid_label_flags);
2749 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2752 (const U8*)kid_label, kid_label_len,
2753 (const U8*)label, len) == 0)
2755 (const U8*)label, len,
2756 (const U8*)kid_label, kid_label_len) == 0)
2757 : ( len == kid_label_len && ((kid_label == label)
2758 || memEQ(kid_label, label, len)))))
2762 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2763 if (kid == PL_lastgotoprobe)
2765 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2768 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2769 ops[-1]->op_type == OP_DBSTATE)
2774 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2788 #define GOTO_DEPTH 64
2789 OP *enterops[GOTO_DEPTH];
2790 const char *label = NULL;
2791 STRLEN label_len = 0;
2792 U32 label_flags = 0;
2793 const bool do_dump = (PL_op->op_type == OP_DUMP);
2794 static const char* const must_have_label = "goto must have label";
2796 if (PL_op->op_flags & OPf_STACKED) {
2797 SV * const sv = POPs;
2800 /* This egregious kludge implements goto &subroutine */
2801 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2804 CV *cv = MUTABLE_CV(SvRV(sv));
2805 AV *arg = GvAV(PL_defgv);
2809 if (!CvROOT(cv) && !CvXSUB(cv)) {
2810 const GV * const gv = CvGV(cv);
2814 /* autoloaded stub? */
2815 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2817 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2819 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2820 if (autogv && (cv = GvCV(autogv)))
2822 tmpstr = sv_newmortal();
2823 gv_efullname3(tmpstr, gv, NULL);
2824 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2826 DIE(aTHX_ "Goto undefined subroutine");
2829 /* First do some returnish stuff. */
2830 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2832 cxix = dopoptosub(cxstack_ix);
2833 if (cxix < cxstack_ix) {
2836 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2842 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2843 if (CxTYPE(cx) == CXt_EVAL) {
2846 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2847 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2849 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2850 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2852 else if (CxMULTICALL(cx))
2855 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2857 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2858 AV* av = cx->blk_sub.argarray;
2860 /* abandon the original @_ if it got reified or if it is
2861 the same as the current @_ */
2862 if (AvREAL(av) || av == arg) {
2866 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2868 else CLEAR_ARGARRAY(av);
2870 /* We donate this refcount later to the callee’s pad. */
2871 SvREFCNT_inc_simple_void(arg);
2872 if (CxTYPE(cx) == CXt_SUB &&
2873 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2874 SvREFCNT_dec(cx->blk_sub.cv);
2875 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2876 LEAVE_SCOPE(oldsave);
2878 /* A destructor called during LEAVE_SCOPE could have undefined
2879 * our precious cv. See bug #99850. */
2880 if (!CvROOT(cv) && !CvXSUB(cv)) {
2881 const GV * const gv = CvGV(cv);
2884 SV * const tmpstr = sv_newmortal();
2885 gv_efullname3(tmpstr, gv, NULL);
2886 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2889 DIE(aTHX_ "Goto undefined subroutine");
2892 /* Now do some callish stuff. */
2894 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2896 OP* const retop = cx->blk_sub.retop;
2899 const SSize_t items = AvFILLp(arg) + 1;
2902 PERL_UNUSED_VAR(newsp);
2903 PERL_UNUSED_VAR(gimme);
2905 /* put GvAV(defgv) back onto stack */
2906 EXTEND(SP, items+1); /* @_ could have been extended. */
2907 Copy(AvARRAY(arg), SP + 1, items, SV*);
2912 for (index=0; index<items; index++)
2913 SvREFCNT_inc_void(sv_2mortal(SP[-index]));
2916 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2917 /* Restore old @_ */
2918 arg = GvAV(PL_defgv);
2919 GvAV(PL_defgv) = cx->blk_sub.savearray;
2923 /* XS subs don't have a CxSUB, so pop it */
2924 POPBLOCK(cx, PL_curpm);
2925 /* Push a mark for the start of arglist */
2928 (void)(*CvXSUB(cv))(aTHX_ cv);
2934 PADLIST * const padlist = CvPADLIST(cv);
2935 cx->blk_sub.cv = cv;
2936 cx->blk_sub.olddepth = CvDEPTH(cv);
2939 if (CvDEPTH(cv) < 2)
2940 SvREFCNT_inc_simple_void_NN(cv);
2942 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2943 sub_crush_depth(cv);
2944 pad_push(padlist, CvDEPTH(cv));
2946 PL_curcop = cx->blk_oldcop;
2948 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2951 CX_CURPAD_SAVE(cx->blk_sub);
2953 /* cx->blk_sub.argarray has no reference count, so we
2954 need something to hang on to our argument array so
2955 that cx->blk_sub.argarray does not end up pointing
2956 to freed memory as the result of undef *_. So put
2957 it in the callee’s pad, donating our refer-
2959 SvREFCNT_dec(PAD_SVl(0));
2960 PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2962 /* GvAV(PL_defgv) might have been modified on scope
2963 exit, so restore it. */
2964 if (arg != GvAV(PL_defgv)) {
2965 AV * const av = GvAV(PL_defgv);
2966 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2970 else SvREFCNT_dec(arg);
2971 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2972 Perl_get_db_sub(aTHX_ NULL, cv);
2974 CV * const gotocv = get_cvs("DB::goto", 0);
2976 PUSHMARK( PL_stack_sp );
2977 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2983 RETURNOP(CvSTART(cv));
2987 label = SvPV_nomg_const(sv, label_len);
2988 label_flags = SvUTF8(sv);
2991 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2992 label = cPVOP->op_pv;
2993 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2994 label_len = strlen(label);
2996 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
3001 OP *gotoprobe = NULL;
3002 bool leaving_eval = FALSE;
3003 bool in_block = FALSE;
3004 PERL_CONTEXT *last_eval_cx = NULL;
3008 PL_lastgotoprobe = NULL;
3010 for (ix = cxstack_ix; ix >= 0; ix--) {
3012 switch (CxTYPE(cx)) {
3014 leaving_eval = TRUE;
3015 if (!CxTRYBLOCK(cx)) {
3016 gotoprobe = (last_eval_cx ?
3017 last_eval_cx->blk_eval.old_eval_root :
3022 /* else fall through */
3023 case CXt_LOOP_LAZYIV:
3024 case CXt_LOOP_LAZYSV:
3026 case CXt_LOOP_PLAIN:
3029 gotoprobe = cx->blk_oldcop->op_sibling;
3035 gotoprobe = cx->blk_oldcop->op_sibling;
3038 gotoprobe = PL_main_root;
3041 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3042 gotoprobe = CvROOT(cx->blk_sub.cv);
3048 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3051 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3052 CxTYPE(cx), (long) ix);
3053 gotoprobe = PL_main_root;
3057 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3058 enterops, enterops + GOTO_DEPTH);
3061 if (gotoprobe->op_sibling &&
3062 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3063 gotoprobe->op_sibling->op_sibling) {
3064 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3065 label, label_len, label_flags, enterops,
3066 enterops + GOTO_DEPTH);
3071 PL_lastgotoprobe = gotoprobe;
3074 DIE(aTHX_ "Can't find label %"SVf,
3075 SVfARG(newSVpvn_flags(label, label_len,
3076 SVs_TEMP | label_flags)));
3078 /* if we're leaving an eval, check before we pop any frames
3079 that we're not going to punt, otherwise the error
3082 if (leaving_eval && *enterops && enterops[1]) {
3084 for (i = 1; enterops[i]; i++)
3085 if (enterops[i]->op_type == OP_ENTERITER)
3086 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3089 if (*enterops && enterops[1]) {
3090 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3092 deprecate("\"goto\" to jump into a construct");
3095 /* pop unwanted frames */
3097 if (ix < cxstack_ix) {
3104 oldsave = PL_scopestack[PL_scopestack_ix];
3105 LEAVE_SCOPE(oldsave);
3108 /* push wanted frames */
3110 if (*enterops && enterops[1]) {
3111 OP * const oldop = PL_op;
3112 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3113 for (; enterops[ix]; ix++) {
3114 PL_op = enterops[ix];
3115 /* Eventually we may want to stack the needed arguments
3116 * for each op. For now, we punt on the hard ones. */
3117 if (PL_op->op_type == OP_ENTERITER)
3118 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3119 PL_op->op_ppaddr(aTHX);
3127 if (!retop) retop = PL_main_start;
3129 PL_restartop = retop;
3130 PL_do_undump = TRUE;
3134 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3135 PL_do_undump = FALSE;
3151 anum = 0; (void)POPs;
3156 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3158 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3161 PL_exit_flags |= PERL_EXIT_EXPECTED;
3163 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3164 if (anum || !(PL_minus_c && PL_madskills))
3169 PUSHs(&PL_sv_undef);
3176 S_save_lines(pTHX_ AV *array, SV *sv)
3178 const char *s = SvPVX_const(sv);
3179 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3182 PERL_ARGS_ASSERT_SAVE_LINES;
3184 while (s && s < send) {
3186 SV * const tmpstr = newSV_type(SVt_PVMG);
3188 t = (const char *)memchr(s, '\n', send - s);
3194 sv_setpvn(tmpstr, s, t - s);
3195 av_store(array, line++, tmpstr);
3203 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3205 0 is used as continue inside eval,
3207 3 is used for a die caught by an inner eval - continue inner loop
3209 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3210 establish a local jmpenv to handle exception traps.
3215 S_docatch(pTHX_ OP *o)
3219 OP * const oldop = PL_op;
3223 assert(CATCH_GET == TRUE);
3230 assert(cxstack_ix >= 0);
3231 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3232 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3237 /* die caught by an inner eval - continue inner loop */
3238 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3239 PL_restartjmpenv = NULL;
3240 PL_op = PL_restartop;
3249 assert(0); /* NOTREACHED */
3258 =for apidoc find_runcv
3260 Locate the CV corresponding to the currently executing sub or eval.
3261 If db_seqp is non_null, skip CVs that are in the DB package and populate
3262 *db_seqp with the cop sequence number at the point that the DB:: code was
3263 entered. (allows debuggers to eval in the scope of the breakpoint rather
3264 than in the scope of the debugger itself).
3270 Perl_find_runcv(pTHX_ U32 *db_seqp)
3272 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3275 /* If this becomes part of the API, it might need a better name. */
3277 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3284 *db_seqp = PL_curcop->cop_seq;
3285 for (si = PL_curstackinfo; si; si = si->si_prev) {
3287 for (ix = si->si_cxix; ix >= 0; ix--) {
3288 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3290 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3291 cv = cx->blk_sub.cv;
3292 /* skip DB:: code */
3293 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3294 *db_seqp = cx->blk_oldcop->cop_seq;
3297 if (cx->cx_type & CXp_SUB_RE)
3300 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3301 cv = cx->blk_eval.cv;
3304 case FIND_RUNCV_padid_eq:
3306 || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
3309 case FIND_RUNCV_level_eq:
3310 if (level++ != arg) continue;
3318 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3322 /* Run yyparse() in a setjmp wrapper. Returns:
3323 * 0: yyparse() successful
3324 * 1: yyparse() failed
3328 S_try_yyparse(pTHX_ int gramtype)
3333 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3337 ret = yyparse(gramtype) ? 1 : 0;
3344 assert(0); /* NOTREACHED */
3351 /* Compile a require/do or an eval ''.
3353 * outside is the lexically enclosing CV (if any) that invoked us.
3354 * seq is the current COP scope value.
3355 * hh is the saved hints hash, if any.
3357 * Returns a bool indicating whether the compile was successful; if so,
3358 * PL_eval_start contains the first op of the compiled code; otherwise,
3361 * This function is called from two places: pp_require and pp_entereval.
3362 * These can be distinguished by whether PL_op is entereval.
3366 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3369 OP * const saveop = PL_op;
3370 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3371 COP * const oldcurcop = PL_curcop;
3372 bool in_require = (saveop->op_type == OP_REQUIRE);
3376 PL_in_eval = (in_require
3377 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3379 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3380 ? EVAL_RE_REPARSING : 0)));
3384 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3386 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3387 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3388 cxstack[cxstack_ix].blk_gimme = gimme;
3390 CvOUTSIDE_SEQ(evalcv) = seq;
3391 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3393 /* set up a scratch pad */
3395 CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3396 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3400 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3402 /* make sure we compile in the right package */
3404 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3405 SAVEGENERICSV(PL_curstash);
3406 PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop));
3408 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3409 SAVESPTR(PL_beginav);
3410 PL_beginav = newAV();
3411 SAVEFREESV(PL_beginav);
3412 SAVESPTR(PL_unitcheckav);
3413 PL_unitcheckav = newAV();
3414 SAVEFREESV(PL_unitcheckav);
3417 SAVEBOOL(PL_madskills);
3421 ENTER_with_name("evalcomp");
3422 SAVESPTR(PL_compcv);
3425 /* try to compile it */
3427 PL_eval_root = NULL;
3428 PL_curcop = &PL_compiling;
3429 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3430 PL_in_eval |= EVAL_KEEPERR;
3437 hv_clear(GvHV(PL_hintgv));
3440 PL_hints = saveop->op_private & OPpEVAL_COPHH
3441 ? oldcurcop->cop_hints : saveop->op_targ;
3443 /* making 'use re eval' not be in scope when compiling the
3444 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3445 * infinite recursion when S_has_runtime_code() gives a false
3446 * positive: the second time round, HINT_RE_EVAL isn't set so we
3447 * don't bother calling S_has_runtime_code() */
3448 if (PL_in_eval & EVAL_RE_REPARSING)
3449 PL_hints &= ~HINT_RE_EVAL;
3452 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3453 SvREFCNT_dec(GvHV(PL_hintgv));
3454 GvHV(PL_hintgv) = hh;
3457 SAVECOMPILEWARNINGS();
3459 if (PL_dowarn & G_WARN_ALL_ON)
3460 PL_compiling.cop_warnings = pWARN_ALL ;
3461 else if (PL_dowarn & G_WARN_ALL_OFF)
3462 PL_compiling.cop_warnings = pWARN_NONE ;
3464 PL_compiling.cop_warnings = pWARN_STD ;
3467 PL_compiling.cop_warnings =
3468 DUP_WARNINGS(oldcurcop->cop_warnings);
3469 cophh_free(CopHINTHASH_get(&PL_compiling));
3470 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3471 /* The label, if present, is the first entry on the chain. So rather
3472 than writing a blank label in front of it (which involves an
3473 allocation), just use the next entry in the chain. */
3474 PL_compiling.cop_hints_hash
3475 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3476 /* Check the assumption that this removed the label. */
3477 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3480 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3483 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3485 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3486 * so honour CATCH_GET and trap it here if necessary */
3488 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3490 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3491 SV **newsp; /* Used by POPBLOCK. */
3493 I32 optype; /* Used by POPEVAL. */
3499 PERL_UNUSED_VAR(newsp);
3500 PERL_UNUSED_VAR(optype);
3502 /* note that if yystatus == 3, then the EVAL CX block has already
3503 * been popped, and various vars restored */
3505 if (yystatus != 3) {
3507 op_free(PL_eval_root);
3508 PL_eval_root = NULL;
3510 SP = PL_stack_base + POPMARK; /* pop original mark */
3511 POPBLOCK(cx,PL_curpm);
3513 namesv = cx->blk_eval.old_namesv;
3514 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3515 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3521 /* If cx is still NULL, it means that we didn't go in the
3522 * POPEVAL branch. */
3523 cx = &cxstack[cxstack_ix];
3524 assert(CxTYPE(cx) == CXt_EVAL);
3525 namesv = cx->blk_eval.old_namesv;
3527 (void)hv_store(GvHVn(PL_incgv),
3528 SvPVX_const(namesv),
3529 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3531 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3534 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3537 if (!*(SvPV_nolen_const(errsv))) {
3538 sv_setpvs(errsv, "Compilation error");
3541 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3546 LEAVE_with_name("evalcomp");
3548 CopLINE_set(&PL_compiling, 0);
3549 SAVEFREEOP(PL_eval_root);
3550 cv_forget_slab(evalcv);
3552 DEBUG_x(dump_eval());
3554 /* Register with debugger: */
3555 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3556 CV * const cv = get_cvs("DB::postponed", 0);
3560 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3562 call_sv(MUTABLE_SV(cv), G_DISCARD);
3566 if (PL_unitcheckav) {
3567 OP *es = PL_eval_start;
3568 call_list(PL_scopestack_ix, PL_unitcheckav);
3572 /* compiled okay, so do it */
3574 CvDEPTH(evalcv) = 1;
3575 SP = PL_stack_base + POPMARK; /* pop original mark */
3576 PL_op = saveop; /* The caller may need it. */
3577 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3584 S_check_type_and_open(pTHX_ SV *name)
3587 const char *p = SvPV_nolen_const(name);
3588 const int st_rc = PerlLIO_stat(p, &st);
3590 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3592 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3596 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3597 return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3599 return PerlIO_open(p, PERL_SCRIPT_MODE);
3603 #ifndef PERL_DISABLE_PMC
3605 S_doopen_pm(pTHX_ SV *name)
3608 const char *p = SvPV_const(name, namelen);
3610 PERL_ARGS_ASSERT_DOOPEN_PM;
3612 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3613 SV *const pmcsv = sv_newmortal();
3616 SvSetSV_nosteal(pmcsv,name);
3617 sv_catpvn(pmcsv, "c", 1);
3619 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3620 return check_type_and_open(pmcsv);
3622 return check_type_and_open(name);
3625 # define doopen_pm(name) check_type_and_open(name)
3626 #endif /* !PERL_DISABLE_PMC */
3638 int vms_unixname = 0;
3643 const char *tryname = NULL;
3645 const I32 gimme = GIMME_V;
3646 int filter_has_file = 0;
3647 PerlIO *tryrsfp = NULL;
3648 SV *filter_cache = NULL;
3649 SV *filter_state = NULL;
3650 SV *filter_sub = NULL;
3657 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3658 sv = sv_2mortal(new_version(sv));
3659 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3660 upg_version(PL_patchlevel, TRUE);
3661 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3662 if ( vcmp(sv,PL_patchlevel) <= 0 )
3663 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3664 SVfARG(sv_2mortal(vnormal(sv))),
3665 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3669 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3672 SV * const req = SvRV(sv);
3673 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3675 /* get the left hand term */
3676 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3678 first = SvIV(*av_fetch(lav,0,0));
3679 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3680 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3681 || av_len(lav) > 1 /* FP with > 3 digits */
3682 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3684 DIE(aTHX_ "Perl %"SVf" required--this is only "
3686 SVfARG(sv_2mortal(vnormal(req))),
3687 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3690 else { /* probably 'use 5.10' or 'use 5.8' */
3695 second = SvIV(*av_fetch(lav,1,0));
3697 second /= second >= 600 ? 100 : 10;
3698 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3699 (int)first, (int)second);
3700 upg_version(hintsv, TRUE);
3702 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3703 "--this is only %"SVf", stopped",
3704 SVfARG(sv_2mortal(vnormal(req))),
3705 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3706 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3714 name = SvPV_const(sv, len);
3715 if (!(name && len > 0 && *name))
3716 DIE(aTHX_ "Null filename used");
3717 TAINT_PROPER("require");
3721 /* The key in the %ENV hash is in the syntax of file passed as the argument
3722 * usually this is in UNIX format, but sometimes in VMS format, which
3723 * can result in a module being pulled in more than once.
3724 * To prevent this, the key must be stored in UNIX format if the VMS
3725 * name can be translated to UNIX.
3728 if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))
3729 && (unixname = tounixspec(name, unixnamebuf)) != NULL) {
3730 unixlen = strlen(unixname);
3736 /* if not VMS or VMS name can not be translated to UNIX, pass it
3739 unixname = (char *) name;
3742 if (PL_op->op_type == OP_REQUIRE) {
3743 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3744 unixname, unixlen, 0);
3746 if (*svp != &PL_sv_undef)
3749 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3750 "Compilation failed in require", unixname);
3754 LOADING_FILE_PROBE(unixname);
3756 /* prepare to compile file */
3758 if (path_is_absolute(name)) {
3759 /* At this point, name is SvPVX(sv) */
3761 tryrsfp = doopen_pm(sv);
3763 if (!tryrsfp && !(errno == EACCES && path_is_absolute(name))) {
3764 AV * const ar = GvAVn(PL_incgv);
3770 namesv = newSV_type(SVt_PV);
3771 for (i = 0; i <= AvFILL(ar); i++) {
3772 SV * const dirsv = *av_fetch(ar, i, TRUE);
3774 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3781 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3782 && !sv_isobject(loader))
3784 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3787 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3788 PTR2UV(SvRV(dirsv)), name);
3789 tryname = SvPVX_const(namesv);
3792 ENTER_with_name("call_INC");
3800 if (sv_isobject(loader))
3801 count = call_method("INC", G_ARRAY);
3803 count = call_sv(loader, G_ARRAY);
3813 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3814 && !isGV_with_GP(SvRV(arg))) {
3815 filter_cache = SvRV(arg);
3816 SvREFCNT_inc_simple_void_NN(filter_cache);
3823 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3827 if (isGV_with_GP(arg)) {
3828 IO * const io = GvIO((const GV *)arg);
3833 tryrsfp = IoIFP(io);
3834 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3835 PerlIO_close(IoOFP(io));
3846 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3848 SvREFCNT_inc_simple_void_NN(filter_sub);
3851 filter_state = SP[i];
3852 SvREFCNT_inc_simple_void(filter_state);
3856 if (!tryrsfp && (filter_cache || filter_sub)) {
3857 tryrsfp = PerlIO_open(BIT_BUCKET,
3865 LEAVE_with_name("call_INC");
3867 /* Adjust file name if the hook has set an %INC entry.
3868 This needs to happen after the FREETMPS above. */
3869 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3871 tryname = SvPV_nolen_const(*svp);
3878 filter_has_file = 0;
3880 SvREFCNT_dec(filter_cache);
3881 filter_cache = NULL;
3884 SvREFCNT_dec(filter_state);
3885 filter_state = NULL;
3888 SvREFCNT_dec(filter_sub);
3893 if (!path_is_absolute(name)
3899 dir = SvPV_const(dirsv, dirlen);
3906 if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL)
3907 || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL))
3909 sv_setpv(namesv, unixdir);
3910 sv_catpv(namesv, unixname);
3912 # ifdef __SYMBIAN32__
3913 if (PL_origfilename[0] &&
3914 PL_origfilename[1] == ':' &&
3915 !(dir[0] && dir[1] == ':'))
3916 Perl_sv_setpvf(aTHX_ namesv,
3921 Perl_sv_setpvf(aTHX_ namesv,
3925 /* The equivalent of
3926 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3927 but without the need to parse the format string, or
3928 call strlen on either pointer, and with the correct
3929 allocation up front. */
3931 char *tmp = SvGROW(namesv, dirlen + len + 2);
3933 memcpy(tmp, dir, dirlen);
3936 /* Avoid '<dir>//<file>' */
3937 if (!dirlen || *(tmp-1) != '/') {
3941 /* name came from an SV, so it will have a '\0' at the
3942 end that we can copy as part of this memcpy(). */
3943 memcpy(tmp, name, len + 1);
3945 SvCUR_set(namesv, dirlen + len + 1);
3950 TAINT_PROPER("require");
3951 tryname = SvPVX_const(namesv);
3952 tryrsfp = doopen_pm(namesv);
3954 if (tryname[0] == '.' && tryname[1] == '/') {
3956 while (*++tryname == '/') {}
3960 else if (errno == EMFILE || errno == EACCES) {
3961 /* no point in trying other paths if out of handles;
3962 * on the other hand, if we couldn't open one of the
3963 * files, then going on with the search could lead to
3964 * unexpected results; see perl #113422
3973 saved_errno = errno; /* sv_2mortal can realloc things */
3976 if (PL_op->op_type == OP_REQUIRE) {
3977 if(saved_errno == EMFILE || saved_errno == EACCES) {
3978 /* diag_listed_as: Can't locate %s */
3979 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno));
3981 if (namesv) { /* did we lookup @INC? */
3982 AV * const ar = GvAVn(PL_incgv);
3984 SV *const msg = newSVpvs_flags("", SVs_TEMP);
3985 SV *const inc = newSVpvs_flags("", SVs_TEMP);
3986 for (i = 0; i <= AvFILL(ar); i++) {
3987 sv_catpvs(inc, " ");
3988 sv_catsv(inc, *av_fetch(ar, i, TRUE));
3990 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
3991 const char *c, *e = name + len - 3;
3992 sv_catpv(msg, " (you may need to install the ");
3993 for (c = name; c < e; c++) {
3995 sv_catpvn(msg, "::", 2);
3998 sv_catpvn(msg, c, 1);
4001 sv_catpv(msg, " module)");
4003 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4004 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4006 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4007 sv_catpv(msg, " (did you run h2ph?)");
4010 /* diag_listed_as: Can't locate %s */
4012 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4016 DIE(aTHX_ "Can't locate %s", name);
4023 SETERRNO(0, SS_NORMAL);
4025 /* Assume success here to prevent recursive requirement. */
4026 /* name is never assigned to again, so len is still strlen(name) */
4027 /* Check whether a hook in @INC has already filled %INC */
4029 (void)hv_store(GvHVn(PL_incgv),
4030 unixname, unixlen, newSVpv(tryname,0),0);
4032 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4034 (void)hv_store(GvHVn(PL_incgv),
4035 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4038 ENTER_with_name("eval");
4040 SAVECOPFILE_FREE(&PL_compiling);
4041 CopFILE_set(&PL_compiling, tryname);
4042 lex_start(NULL, tryrsfp, 0);
4044 if (filter_sub || filter_cache) {
4045 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4046 than hanging another SV from it. In turn, filter_add() optionally
4047 takes the SV to use as the filter (or creates a new SV if passed
4048 NULL), so simply pass in whatever value filter_cache has. */
4049 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
4050 IoLINES(datasv) = filter_has_file;
4051 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4052 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4055 /* switch to eval mode */
4056 PUSHBLOCK(cx, CXt_EVAL, SP);
4058 cx->blk_eval.retop = PL_op->op_next;
4060 SAVECOPLINE(&PL_compiling);
4061 CopLINE_set(&PL_compiling, 0);
4065 /* Store and reset encoding. */
4066 encoding = PL_encoding;
4069 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4070 op = DOCATCH(PL_eval_start);
4072 op = PL_op->op_next;
4074 /* Restore encoding. */
4075 PL_encoding = encoding;
4077 LOADED_FILE_PROBE(unixname);
4082 /* This is a op added to hold the hints hash for
4083 pp_entereval. The hash can be modified by the code
4084 being eval'ed, so we return a copy instead. */
4090 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4100 const I32 gimme = GIMME_V;
4101 const U32 was = PL_breakable_sub_gen;
4102 char tbuf[TYPE_DIGITS(long) + 12];
4103 bool saved_delete = FALSE;
4104 char *tmpbuf = tbuf;
4107 U32 seq, lex_flags = 0;
4108 HV *saved_hh = NULL;
4109 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4111 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4112 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4114 else if (PL_hints & HINT_LOCALIZE_HH || (
4115 PL_op->op_private & OPpEVAL_COPHH
4116 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4118 saved_hh = cop_hints_2hv(PL_curcop, 0);
4119 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4123 /* make sure we've got a plain PV (no overload etc) before testing
4124 * for taint. Making a copy here is probably overkill, but better
4125 * safe than sorry */
4127 const char * const p = SvPV_const(sv, len);
4129 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4130 lex_flags |= LEX_START_COPIED;
4132 if (bytes && SvUTF8(sv))
4133 SvPVbyte_force(sv, len);
4135 else if (bytes && SvUTF8(sv)) {
4136 /* Don't modify someone else's scalar */
4139 (void)sv_2mortal(sv);
4140 SvPVbyte_force(sv,len);
4141 lex_flags |= LEX_START_COPIED;
4144 TAINT_IF(SvTAINTED(sv));
4145 TAINT_PROPER("eval");
4147 ENTER_with_name("eval");
4148 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4149 ? LEX_IGNORE_UTF8_HINTS
4150 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4155 /* switch to eval mode */
4157 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4158 SV * const temp_sv = sv_newmortal();
4159 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4160 (unsigned long)++PL_evalseq,
4161 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4162 tmpbuf = SvPVX(temp_sv);
4163 len = SvCUR(temp_sv);
4166 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4167 SAVECOPFILE_FREE(&PL_compiling);
4168 CopFILE_set(&PL_compiling, tmpbuf+2);
4169 SAVECOPLINE(&PL_compiling);
4170 CopLINE_set(&PL_compiling, 1);
4171 /* special case: an eval '' executed within the DB package gets lexically
4172 * placed in the first non-DB CV rather than the current CV - this
4173 * allows the debugger to execute code, find lexicals etc, in the
4174 * scope of the code being debugged. Passing &seq gets find_runcv
4175 * to do the dirty work for us */
4176 runcv = find_runcv(&seq);
4178 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4180 cx->blk_eval.retop = PL_op->op_next;
4182 /* prepare to compile string */
4184 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4185 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4187 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4188 deleting the eval's FILEGV from the stash before gv_check() runs
4189 (i.e. before run-time proper). To work around the coredump that
4190 ensues, we always turn GvMULTI_on for any globals that were
4191 introduced within evals. See force_ident(). GSAR 96-10-12 */
4192 char *const safestr = savepvn(tmpbuf, len);
4193 SAVEDELETE(PL_defstash, safestr, len);
4194 saved_delete = TRUE;
4199 if (doeval(gimme, runcv, seq, saved_hh)) {
4200 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4201 ? (PERLDB_LINE || PERLDB_SAVESRC)
4202 : PERLDB_SAVESRC_NOSUBS) {
4203 /* Retain the filegv we created. */
4204 } else if (!saved_delete) {
4205 char *const safestr = savepvn(tmpbuf, len);
4206 SAVEDELETE(PL_defstash, safestr, len);
4208 return DOCATCH(PL_eval_start);
4210 /* We have already left the scope set up earlier thanks to the LEAVE
4212 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4213 ? (PERLDB_LINE || PERLDB_SAVESRC)
4214 : PERLDB_SAVESRC_INVALID) {
4215 /* Retain the filegv we created. */
4216 } else if (!saved_delete) {
4217 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4219 return PL_op->op_next;
4231 const U8 save_flags = PL_op -> op_flags;
4239 namesv = cx->blk_eval.old_namesv;
4240 retop = cx->blk_eval.retop;
4241 evalcv = cx->blk_eval.cv;
4244 SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4246 PL_curpm = newpm; /* Don't pop $1 et al till now */
4249 assert(CvDEPTH(evalcv) == 1);
4251 CvDEPTH(evalcv) = 0;
4253 if (optype == OP_REQUIRE &&
4254 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4256 /* Unassume the success we assumed earlier. */
4257 (void)hv_delete(GvHVn(PL_incgv),
4258 SvPVX_const(namesv),
4259 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4261 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4263 /* die_unwind() did LEAVE, or we won't be here */
4266 LEAVE_with_name("eval");
4267 if (!(save_flags & OPf_SPECIAL)) {
4275 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4276 close to the related Perl_create_eval_scope. */
4278 Perl_delete_eval_scope(pTHX)
4289 LEAVE_with_name("eval_scope");
4290 PERL_UNUSED_VAR(newsp);
4291 PERL_UNUSED_VAR(gimme);
4292 PERL_UNUSED_VAR(optype);
4295 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4296 also needed by Perl_fold_constants. */
4298 Perl_create_eval_scope(pTHX_ U32 flags)
4301 const I32 gimme = GIMME_V;
4303 ENTER_with_name("eval_scope");
4306 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4309 PL_in_eval = EVAL_INEVAL;
4310 if (flags & G_KEEPERR)
4311 PL_in_eval |= EVAL_KEEPERR;
4314 if (flags & G_FAKINGEVAL) {
4315 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4323 PERL_CONTEXT * const cx = create_eval_scope(0);
4324 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4325 return DOCATCH(PL_op->op_next);
4340 PERL_UNUSED_VAR(optype);
4343 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4344 PL_curpm = newpm; /* Don't pop $1 et al till now */
4346 LEAVE_with_name("eval_scope");
4355 const I32 gimme = GIMME_V;
4357 ENTER_with_name("given");
4360 if (PL_op->op_targ) {
4361 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4362 SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4363 PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4370 PUSHBLOCK(cx, CXt_GIVEN, SP);
4383 PERL_UNUSED_CONTEXT;
4386 assert(CxTYPE(cx) == CXt_GIVEN);
4389 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4390 PL_curpm = newpm; /* Don't pop $1 et al till now */
4392 LEAVE_with_name("given");
4396 /* Helper routines used by pp_smartmatch */
4398 S_make_matcher(pTHX_ REGEXP *re)
4401 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4403 PERL_ARGS_ASSERT_MAKE_MATCHER;
4405 PM_SETRE(matcher, ReREFCNT_inc(re));
4407 SAVEFREEOP((OP *) matcher);
4408 ENTER_with_name("matcher"); SAVETMPS;
4414 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4419 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4421 PL_op = (OP *) matcher;
4424 (void) Perl_pp_match(aTHX);
4426 return (SvTRUEx(POPs));
4430 S_destroy_matcher(pTHX_ PMOP *matcher)
4434 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4435 PERL_UNUSED_ARG(matcher);
4438 LEAVE_with_name("matcher");
4441 /* Do a smart match */
4444 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4445 return do_smartmatch(NULL, NULL, 0);
4448 /* This version of do_smartmatch() implements the
4449 * table of smart matches that is found in perlsyn.
4452 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4457 bool object_on_left = FALSE;
4458 SV *e = TOPs; /* e is for 'expression' */
4459 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4461 /* Take care only to invoke mg_get() once for each argument.
4462 * Currently we do this by copying the SV if it's magical. */
4464 if (!copied && SvGMAGICAL(d))
4465 d = sv_mortalcopy(d);
4472 e = sv_mortalcopy(e);
4474 /* First of all, handle overload magic of the rightmost argument */
4477 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4478 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4480 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4487 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4490 SP -= 2; /* Pop the values */
4495 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4502 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4503 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4504 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4506 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4507 object_on_left = TRUE;
4510 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4512 if (object_on_left) {
4513 goto sm_any_sub; /* Treat objects like scalars */
4515 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4516 /* Test sub truth for each key */
4518 bool andedresults = TRUE;
4519 HV *hv = (HV*) SvRV(d);
4520 I32 numkeys = hv_iterinit(hv);
4521 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4524 while ( (he = hv_iternext(hv)) ) {
4525 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4526 ENTER_with_name("smartmatch_hash_key_test");
4529 PUSHs(hv_iterkeysv(he));
4531 c = call_sv(e, G_SCALAR);
4534 andedresults = FALSE;
4536 andedresults = SvTRUEx(POPs) && andedresults;
4538 LEAVE_with_name("smartmatch_hash_key_test");
4545 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4546 /* Test sub truth for each element */
4548 bool andedresults = TRUE;
4549 AV *av = (AV*) SvRV(d);
4550 const I32 len = av_len(av);
4551 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4554 for (i = 0; i <= len; ++i) {
4555 SV * const * const svp = av_fetch(av, i, FALSE);
4556 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4557 ENTER_with_name("smartmatch_array_elem_test");
4563 c = call_sv(e, G_SCALAR);
4566 andedresults = FALSE;
4568 andedresults = SvTRUEx(POPs) && andedresults;
4570 LEAVE_with_name("smartmatch_array_elem_test");
4579 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4580 ENTER_with_name("smartmatch_coderef");
4585 c = call_sv(e, G_SCALAR);
4589 else if (SvTEMP(TOPs))
4590 SvREFCNT_inc_void(TOPs);
4592 LEAVE_with_name("smartmatch_coderef");
4597 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4598 if (object_on_left) {
4599 goto sm_any_hash; /* Treat objects like scalars */
4601 else if (!SvOK(d)) {
4602 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4605 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4606 /* Check that the key-sets are identical */
4608 HV *other_hv = MUTABLE_HV(SvRV(d));
4610 bool other_tied = FALSE;
4611 U32 this_key_count = 0,
4612 other_key_count = 0;
4613 HV *hv = MUTABLE_HV(SvRV(e));
4615 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4616 /* Tied hashes don't know how many keys they have. */
4617 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4620 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4621 HV * const temp = other_hv;
4626 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4629 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4632 /* The hashes have the same number of keys, so it suffices
4633 to check that one is a subset of the other. */
4634 (void) hv_iterinit(hv);
4635 while ( (he = hv_iternext(hv)) ) {
4636 SV *key = hv_iterkeysv(he);
4638 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4641 if(!hv_exists_ent(other_hv, key, 0)) {
4642 (void) hv_iterinit(hv); /* reset iterator */
4648 (void) hv_iterinit(other_hv);
4649 while ( hv_iternext(other_hv) )
4653 other_key_count = HvUSEDKEYS(other_hv);
4655 if (this_key_count != other_key_count)
4660 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4661 AV * const other_av = MUTABLE_AV(SvRV(d));
4662 const I32 other_len = av_len(other_av) + 1;
4664 HV *hv = MUTABLE_HV(SvRV(e));
4666 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4667 for (i = 0; i < other_len; ++i) {
4668 SV ** const svp = av_fetch(other_av, i, FALSE);
4669 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4670 if (svp) { /* ??? When can this not happen? */
4671 if (hv_exists_ent(hv, *svp, 0))
4677 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4678 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4681 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4683 HV *hv = MUTABLE_HV(SvRV(e));
4685 (void) hv_iterinit(hv);
4686 while ( (he = hv_iternext(hv)) ) {
4687 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4688 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4689 (void) hv_iterinit(hv);
4690 destroy_matcher(matcher);
4694 destroy_matcher(matcher);
4700 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4701 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4708 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4709 if (object_on_left) {
4710 goto sm_any_array; /* Treat objects like scalars */
4712 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4713 AV * const other_av = MUTABLE_AV(SvRV(e));
4714 const I32 other_len = av_len(other_av) + 1;
4717 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4718 for (i = 0; i < other_len; ++i) {
4719 SV ** const svp = av_fetch(other_av, i, FALSE);
4721 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4722 if (svp) { /* ??? When can this not happen? */
4723 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4729 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4730 AV *other_av = MUTABLE_AV(SvRV(d));
4731 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4732 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4736 const I32 other_len = av_len(other_av);
4738 if (NULL == seen_this) {
4739 seen_this = newHV();
4740 (void) sv_2mortal(MUTABLE_SV(seen_this));
4742 if (NULL == seen_other) {
4743 seen_other = newHV();
4744 (void) sv_2mortal(MUTABLE_SV(seen_other));
4746 for(i = 0; i <= other_len; ++i) {
4747 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4748 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4750 if (!this_elem || !other_elem) {
4751 if ((this_elem && SvOK(*this_elem))
4752 || (other_elem && SvOK(*other_elem)))
4755 else if (hv_exists_ent(seen_this,
4756 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4757 hv_exists_ent(seen_other,
4758 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4760 if (*this_elem != *other_elem)
4764 (void)hv_store_ent(seen_this,
4765 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4767 (void)hv_store_ent(seen_other,
4768 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4774 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4775 (void) do_smartmatch(seen_this, seen_other, 0);
4777 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4786 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4787 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4790 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4791 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4794 for(i = 0; i <= this_len; ++i) {
4795 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4796 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4797 if (svp && matcher_matches_sv(matcher, *svp)) {
4798 destroy_matcher(matcher);
4802 destroy_matcher(matcher);
4806 else if (!SvOK(d)) {
4807 /* undef ~~ array */
4808 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4811 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4812 for (i = 0; i <= this_len; ++i) {
4813 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4814 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4815 if (!svp || !SvOK(*svp))
4824 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4826 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4827 for (i = 0; i <= this_len; ++i) {
4828 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4835 /* infinite recursion isn't supposed to happen here */
4836 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4837 (void) do_smartmatch(NULL, NULL, 1);
4839 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4848 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4849 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4850 SV *t = d; d = e; e = t;
4851 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4854 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4855 SV *t = d; d = e; e = t;
4856 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4857 goto sm_regex_array;
4860 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4862 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4864 PUSHs(matcher_matches_sv(matcher, d)
4867 destroy_matcher(matcher);
4872 /* See if there is overload magic on left */
4873 else if (object_on_left && SvAMAGIC(d)) {
4875 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4876 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4879 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4887 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4890 else if (!SvOK(d)) {
4891 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4892 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4897 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4898 DEBUG_M(if (SvNIOK(e))
4899 Perl_deb(aTHX_ " applying rule Any-Num\n");
4901 Perl_deb(aTHX_ " applying rule Num-numish\n");
4903 /* numeric comparison */
4906 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4907 (void) Perl_pp_i_eq(aTHX);
4909 (void) Perl_pp_eq(aTHX);
4917 /* As a last resort, use string comparison */
4918 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4921 return Perl_pp_seq(aTHX);
4928 const I32 gimme = GIMME_V;
4930 /* This is essentially an optimization: if the match
4931 fails, we don't want to push a context and then
4932 pop it again right away, so we skip straight
4933 to the op that follows the leavewhen.
4934 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4936 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4937 RETURNOP(cLOGOP->op_other->op_next);
4939 ENTER_with_name("when");
4942 PUSHBLOCK(cx, CXt_WHEN, SP);
4957 cxix = dopoptogiven(cxstack_ix);
4959 /* diag_listed_as: Can't "when" outside a topicalizer */
4960 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
4961 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
4964 assert(CxTYPE(cx) == CXt_WHEN);
4967 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4968 PL_curpm = newpm; /* pop $1 et al */
4970 LEAVE_with_name("when");
4972 if (cxix < cxstack_ix)
4975 cx = &cxstack[cxix];
4977 if (CxFOREACH(cx)) {
4978 /* clear off anything above the scope we're re-entering */
4979 I32 inner = PL_scopestack_ix;
4982 if (PL_scopestack_ix < inner)
4983 leave_scope(PL_scopestack[PL_scopestack_ix]);
4984 PL_curcop = cx->blk_oldcop;
4987 return cx->blk_loop.my_op->op_nextop;
4991 RETURNOP(cx->blk_givwhen.leave_op);
5004 PERL_UNUSED_VAR(gimme);
5006 cxix = dopoptowhen(cxstack_ix);
5008 DIE(aTHX_ "Can't \"continue\" outside a when block");
5010 if (cxix < cxstack_ix)
5014 assert(CxTYPE(cx) == CXt_WHEN);
5017 PL_curpm = newpm; /* pop $1 et al */
5019 LEAVE_with_name("when");
5020 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5029 cxix = dopoptogiven(cxstack_ix);
5031 DIE(aTHX_ "Can't \"break\" outside a given block");
5033 cx = &cxstack[cxix];
5035 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5037 if (cxix < cxstack_ix)
5040 /* Restore the sp at the time we entered the given block */
5043 return cx->blk_givwhen.leave_op;
5047 S_doparseform(pTHX_ SV *sv)
5050 char *s = SvPV(sv, len);
5052 char *base = NULL; /* start of current field */
5053 I32 skipspaces = 0; /* number of contiguous spaces seen */
5054 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5055 bool repeat = FALSE; /* ~~ seen on this line */
5056 bool postspace = FALSE; /* a text field may need right padding */
5059 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5061 bool ischop; /* it's a ^ rather than a @ */
5062 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5063 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5067 PERL_ARGS_ASSERT_DOPARSEFORM;
5070 Perl_croak(aTHX_ "Null picture in formline");
5072 if (SvTYPE(sv) >= SVt_PVMG) {
5073 /* This might, of course, still return NULL. */
5074 mg = mg_find(sv, PERL_MAGIC_fm);
5076 sv_upgrade(sv, SVt_PVMG);
5080 /* still the same as previously-compiled string? */
5081 SV *old = mg->mg_obj;
5082 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5083 && len == SvCUR(old)
5084 && strnEQ(SvPVX(old), SvPVX(sv), len)
5086 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5090 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5091 Safefree(mg->mg_ptr);
5097 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5098 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5101 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5102 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5106 /* estimate the buffer size needed */
5107 for (base = s; s <= send; s++) {
5108 if (*s == '\n' || *s == '@' || *s == '^')
5114 Newx(fops, maxops, U32);
5119 *fpc++ = FF_LINEMARK;
5120 noblank = repeat = FALSE;
5138 case ' ': case '\t':
5145 } /* else FALL THROUGH */
5153 *fpc++ = FF_LITERAL;
5161 *fpc++ = (U32)skipspaces;
5165 *fpc++ = FF_NEWLINE;
5169 arg = fpc - linepc + 1;
5176 *fpc++ = FF_LINEMARK;
5177 noblank = repeat = FALSE;
5186 ischop = s[-1] == '^';
5192 arg = (s - base) - 1;
5194 *fpc++ = FF_LITERAL;
5200 if (*s == '*') { /* @* or ^* */
5202 *fpc++ = 2; /* skip the @* or ^* */
5204 *fpc++ = FF_LINESNGL;
5207 *fpc++ = FF_LINEGLOB;
5209 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5210 arg = ischop ? FORM_NUM_BLANK : 0;
5215 const char * const f = ++s;
5218 arg |= FORM_NUM_POINT + (s - f);
5220 *fpc++ = s - base; /* fieldsize for FETCH */
5221 *fpc++ = FF_DECIMAL;
5223 unchopnum |= ! ischop;
5225 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5226 arg = ischop ? FORM_NUM_BLANK : 0;
5228 s++; /* skip the '0' first */
5232 const char * const f = ++s;
5235 arg |= FORM_NUM_POINT + (s - f);
5237 *fpc++ = s - base; /* fieldsize for FETCH */
5238 *fpc++ = FF_0DECIMAL;
5240 unchopnum |= ! ischop;
5242 else { /* text field */
5244 bool ismore = FALSE;
5247 while (*++s == '>') ;
5248 prespace = FF_SPACE;
5250 else if (*s == '|') {
5251 while (*++s == '|') ;
5252 prespace = FF_HALFSPACE;
5257 while (*++s == '<') ;
5260 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5264 *fpc++ = s - base; /* fieldsize for FETCH */
5266 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5269 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5283 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5286 mg->mg_ptr = (char *) fops;
5287 mg->mg_len = arg * sizeof(U32);
5288 mg->mg_obj = sv_copy;
5289 mg->mg_flags |= MGf_REFCOUNTED;
5291 if (unchopnum && repeat)
5292 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5299 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5301 /* Can value be printed in fldsize chars, using %*.*f ? */
5305 int intsize = fldsize - (value < 0 ? 1 : 0);
5307 if (frcsize & FORM_NUM_POINT)
5309 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5312 while (intsize--) pwr *= 10.0;
5313 while (frcsize--) eps /= 10.0;
5316 if (value + eps >= pwr)
5319 if (value - eps <= -pwr)
5326 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5329 SV * const datasv = FILTER_DATA(idx);
5330 const int filter_has_file = IoLINES(datasv);
5331 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5332 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5337 char *prune_from = NULL;
5338 bool read_from_cache = FALSE;
5342 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5344 assert(maxlen >= 0);
5347 /* I was having segfault trouble under Linux 2.2.5 after a
5348 parse error occured. (Had to hack around it with a test
5349 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5350 not sure where the trouble is yet. XXX */
5353 SV *const cache = datasv;
5356 const char *cache_p = SvPV(cache, cache_len);
5360 /* Running in block mode and we have some cached data already.
5362 if (cache_len >= umaxlen) {
5363 /* In fact, so much data we don't even need to call
5368 const char *const first_nl =
5369 (const char *)memchr(cache_p, '\n', cache_len);
5371 take = first_nl + 1 - cache_p;
5375 sv_catpvn(buf_sv, cache_p, take);
5376 sv_chop(cache, cache_p + take);
5377 /* Definitely not EOF */
5381 sv_catsv(buf_sv, cache);
5383 umaxlen -= cache_len;
5386 read_from_cache = TRUE;
5390 /* Filter API says that the filter appends to the contents of the buffer.
5391 Usually the buffer is "", so the details don't matter. But if it's not,
5392 then clearly what it contains is already filtered by this filter, so we
5393 don't want to pass it in a second time.
5394 I'm going to use a mortal in case the upstream filter croaks. */
5395 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5396 ? sv_newmortal() : buf_sv;
5397 SvUPGRADE(upstream, SVt_PV);
5399 if (filter_has_file) {
5400 status = FILTER_READ(idx+1, upstream, 0);
5403 if (filter_sub && status >= 0) {
5407 ENTER_with_name("call_filter_sub");
5412 DEFSV_set(upstream);
5416 PUSHs(filter_state);
5419 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5428 SV * const errsv = ERRSV;
5429 if (SvTRUE_NN(errsv))
5430 err = newSVsv(errsv);
5436 LEAVE_with_name("call_filter_sub");
5439 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5440 if(!err && SvOK(upstream)) {
5441 got_p = SvPV(upstream, got_len);
5443 if (got_len > umaxlen) {
5444 prune_from = got_p + umaxlen;
5447 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5448 if (first_nl && first_nl + 1 < got_p + got_len) {
5449 /* There's a second line here... */
5450 prune_from = first_nl + 1;
5454 if (!err && prune_from) {
5455 /* Oh. Too long. Stuff some in our cache. */
5456 STRLEN cached_len = got_p + got_len - prune_from;
5457 SV *const cache = datasv;
5460 /* Cache should be empty. */
5461 assert(!SvCUR(cache));
5464 sv_setpvn(cache, prune_from, cached_len);
5465 /* If you ask for block mode, you may well split UTF-8 characters.
5466 "If it breaks, you get to keep both parts"
5467 (Your code is broken if you don't put them back together again
5468 before something notices.) */
5469 if (SvUTF8(upstream)) {
5472 SvCUR_set(upstream, got_len - cached_len);
5474 /* Can't yet be EOF */
5479 /* If they are at EOF but buf_sv has something in it, then they may never
5480 have touched the SV upstream, so it may be undefined. If we naively
5481 concatenate it then we get a warning about use of uninitialised value.
5483 if (!err && upstream != buf_sv &&
5484 (SvOK(upstream) || SvGMAGICAL(upstream))) {
5485 sv_catsv(buf_sv, upstream);
5489 IoLINES(datasv) = 0;
5491 SvREFCNT_dec(filter_state);
5492 IoTOP_GV(datasv) = NULL;
5495 SvREFCNT_dec(filter_sub);
5496 IoBOTTOM_GV(datasv) = NULL;
5498 filter_del(S_run_user_filter);
5504 if (status == 0 && read_from_cache) {
5505 /* If we read some data from the cache (and by getting here it implies
5506 that we emptied the cache) then we aren't yet at EOF, and mustn't
5507 report that to our caller. */
5513 /* perhaps someone can come up with a better name for
5514 this? it is not really "absolute", per se ... */
5516 S_path_is_absolute(const char *name)
5518 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5520 if (PERL_FILE_IS_ABSOLUTE(name)
5522 || (*name == '.' && ((name[1] == '/' ||
5523 (name[1] == '.' && name[2] == '/'))
5524 || (name[1] == '\\' ||
5525 ( name[1] == '.' && name[2] == '\\')))
5528 || (*name == '.' && (name[1] == '/' ||
5529 (name[1] == '.' && name[2] == '/')))
5541 * c-indentation-style: bsd
5543 * indent-tabs-mode: nil
5546 * ex: set ts=8 sts=4 sw=4 et: