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;
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();
110 new_re = (eng->op_comp
112 : &Perl_re_op_compile
113 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
115 (pm->op_pmflags & RXf_PMf_COMPILETIME),
117 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
118 if (pm->op_pmflags & PMf_HAS_CV)
119 ReANY(new_re)->qr_anoncv
120 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
124 /* The match's LHS's get-magic might need to access this op's regexp
125 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
126 get-magic now before we replace the regexp. Hopefully this hack can
127 be replaced with the approach described at
128 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
130 if (pm->op_type == OP_MATCH) {
132 const bool was_tainted = TAINT_get;
133 if (pm->op_flags & OPf_STACKED)
135 else if (pm->op_private & OPpTARGET_MY)
136 lhs = PAD_SV(pm->op_targ);
139 /* Restore the previous value of PL_tainted (which may have been
140 modified by get-magic), to avoid incorrectly setting the
141 RXf_TAINTED flag with RX_TAINT_on further down. */
142 TAINT_set(was_tainted);
144 tmp = reg_temp_copy(NULL, new_re);
145 ReREFCNT_dec(new_re);
150 PM_SETRE(pm, new_re);
153 #ifndef INCOMPLETE_TAINTS
154 if (TAINTING_get && TAINT_get) {
155 SvTAINTED_on((SV*)new_re);
160 #if !defined(USE_ITHREADS)
161 /* can't change the optree at runtime either */
162 /* PMf_KEEP is handled differently under threads to avoid these problems */
163 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
165 if (pm->op_pmflags & PMf_KEEP) {
166 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
167 cLOGOP->op_first->op_next = PL_op->op_next;
180 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
181 PMOP * const pm = (PMOP*) cLOGOP->op_other;
182 SV * const dstr = cx->sb_dstr;
185 char *orig = cx->sb_orig;
186 REGEXP * const rx = cx->sb_rx;
188 REGEXP *old = PM_GETRE(pm);
195 PM_SETRE(pm,ReREFCNT_inc(rx));
198 rxres_restore(&cx->sb_rxres, rx);
199 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
201 if (cx->sb_iters++) {
202 const I32 saviters = cx->sb_iters;
203 if (cx->sb_iters > cx->sb_maxiters)
204 DIE(aTHX_ "Substitution loop");
206 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
208 /* See "how taint works" above pp_subst() */
210 cx->sb_rxtainted |= SUBST_TAINT_REPL;
211 sv_catsv_nomg(dstr, POPs);
212 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
216 if (CxONCE(cx) || s < orig ||
217 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
218 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
219 (REXEC_IGNOREPOS|REXEC_NOT_FIRST)))
221 SV *targ = cx->sb_targ;
223 assert(cx->sb_strend >= s);
224 if(cx->sb_strend > s) {
225 if (DO_UTF8(dstr) && !SvUTF8(targ))
226 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
228 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
230 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
231 cx->sb_rxtainted |= SUBST_TAINT_PAT;
233 if (pm->op_pmflags & PMf_NONDESTRUCT) {
235 /* From here on down we're using the copy, and leaving the
236 original untouched. */
241 sv_force_normal_flags(targ, SV_COW_DROP_PV);
246 SvPV_set(targ, SvPVX(dstr));
247 SvCUR_set(targ, SvCUR(dstr));
248 SvLEN_set(targ, SvLEN(dstr));
251 SvPV_set(dstr, NULL);
254 mPUSHi(saviters - 1);
256 (void)SvPOK_only_UTF8(targ);
259 /* update the taint state of various various variables in
260 * preparation for final exit.
261 * See "how taint works" above pp_subst() */
263 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
264 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
265 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
267 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
269 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
270 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
272 SvTAINTED_on(TOPs); /* taint return value */
273 /* needed for mg_set below */
275 cBOOL(cx->sb_rxtainted &
276 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
280 /* PL_tainted must be correctly set for this mg_set */
283 LEAVE_SCOPE(cx->sb_oldsave);
285 RETURNOP(pm->op_next);
286 assert(0); /* NOTREACHED */
288 cx->sb_iters = saviters;
290 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
293 assert(!RX_SUBOFFSET(rx));
294 cx->sb_orig = orig = RX_SUBBEG(rx);
296 cx->sb_strend = s + (cx->sb_strend - m);
298 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
300 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
301 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
303 sv_catpvn_nomg(dstr, s, m-s);
305 cx->sb_s = RX_OFFS(rx)[0].end + orig;
306 { /* Update the pos() information. */
308 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
310 SvUPGRADE(sv, SVt_PVMG);
311 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
312 #ifdef PERL_OLD_COPY_ON_WRITE
314 sv_force_normal_flags(sv, 0);
316 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
319 mg->mg_len = m - orig;
322 (void)ReREFCNT_inc(rx);
323 /* update the taint state of various various variables in preparation
324 * for calling the code block.
325 * See "how taint works" above pp_subst() */
327 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
328 cx->sb_rxtainted |= SUBST_TAINT_PAT;
330 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
331 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
332 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
334 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
336 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
337 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
338 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
339 ? cx->sb_dstr : cx->sb_targ);
342 rxres_save(&cx->sb_rxres, rx);
344 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
348 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
353 PERL_ARGS_ASSERT_RXRES_SAVE;
356 if (!p || p[1] < RX_NPARENS(rx)) {
357 #ifdef PERL_OLD_COPY_ON_WRITE
358 i = 7 + (RX_NPARENS(rx)+1) * 2;
360 i = 6 + (RX_NPARENS(rx)+1) * 2;
369 /* what (if anything) to free on croak */
370 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
371 RX_MATCH_COPIED_off(rx);
372 *p++ = RX_NPARENS(rx);
374 #ifdef PERL_OLD_COPY_ON_WRITE
375 *p++ = PTR2UV(RX_SAVED_COPY(rx));
376 RX_SAVED_COPY(rx) = NULL;
379 *p++ = PTR2UV(RX_SUBBEG(rx));
380 *p++ = (UV)RX_SUBLEN(rx);
381 *p++ = (UV)RX_SUBOFFSET(rx);
382 *p++ = (UV)RX_SUBCOFFSET(rx);
383 for (i = 0; i <= RX_NPARENS(rx); ++i) {
384 *p++ = (UV)RX_OFFS(rx)[i].start;
385 *p++ = (UV)RX_OFFS(rx)[i].end;
390 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
395 PERL_ARGS_ASSERT_RXRES_RESTORE;
398 RX_MATCH_COPY_FREE(rx);
399 RX_MATCH_COPIED_set(rx, *p);
401 RX_NPARENS(rx) = *p++;
403 #ifdef PERL_OLD_COPY_ON_WRITE
404 if (RX_SAVED_COPY(rx))
405 SvREFCNT_dec (RX_SAVED_COPY(rx));
406 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
410 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
411 RX_SUBLEN(rx) = (I32)(*p++);
412 RX_SUBOFFSET(rx) = (I32)*p++;
413 RX_SUBCOFFSET(rx) = (I32)*p++;
414 for (i = 0; i <= RX_NPARENS(rx); ++i) {
415 RX_OFFS(rx)[i].start = (I32)(*p++);
416 RX_OFFS(rx)[i].end = (I32)(*p++);
421 S_rxres_free(pTHX_ void **rsp)
423 UV * const p = (UV*)*rsp;
425 PERL_ARGS_ASSERT_RXRES_FREE;
429 void *tmp = INT2PTR(char*,*p);
431 #ifdef PERL_OLD_COPY_ON_WRITE
432 U32 i = 9 + p[1] * 2;
434 U32 i = 8 + p[1] * 2;
438 #ifdef PERL_OLD_COPY_ON_WRITE
439 SvREFCNT_dec (INT2PTR(SV*,p[2]));
442 PoisonFree(p, i, sizeof(UV));
451 #define FORM_NUM_BLANK (1<<30)
452 #define FORM_NUM_POINT (1<<29)
456 dVAR; dSP; dMARK; dORIGMARK;
457 SV * const tmpForm = *++MARK;
458 SV *formsv; /* contains text of original format */
459 U32 *fpc; /* format ops program counter */
460 char *t; /* current append position in target string */
461 const char *f; /* current position in format string */
463 SV *sv = NULL; /* current item */
464 const char *item = NULL;/* string value of current item */
465 I32 itemsize = 0; /* length of current item, possibly truncated */
466 I32 fieldsize = 0; /* width of current field */
467 I32 lines = 0; /* number of lines that have been output */
468 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
469 const char *chophere = NULL; /* where to chop current item */
470 STRLEN linemark = 0; /* pos of start of line in output */
472 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
474 STRLEN linemax; /* estimate of output size in bytes */
475 bool item_is_utf8 = FALSE;
476 bool targ_is_utf8 = FALSE;
479 U8 *source; /* source of bytes to append */
480 STRLEN to_copy; /* how may bytes to append */
481 char trans; /* what chars to translate */
483 mg = doparseform(tmpForm);
485 fpc = (U32*)mg->mg_ptr;
486 /* the actual string the format was compiled from.
487 * with overload etc, this may not match tmpForm */
491 SvPV_force(PL_formtarget, len);
492 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
493 SvTAINTED_on(PL_formtarget);
494 if (DO_UTF8(PL_formtarget))
496 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
497 t = SvGROW(PL_formtarget, len + linemax + 1);
498 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
500 f = SvPV_const(formsv, len);
504 const char *name = "???";
507 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
508 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
509 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
510 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
511 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
513 case FF_CHECKNL: name = "CHECKNL"; break;
514 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
515 case FF_SPACE: name = "SPACE"; break;
516 case FF_HALFSPACE: name = "HALFSPACE"; break;
517 case FF_ITEM: name = "ITEM"; break;
518 case FF_CHOP: name = "CHOP"; break;
519 case FF_LINEGLOB: name = "LINEGLOB"; break;
520 case FF_NEWLINE: name = "NEWLINE"; break;
521 case FF_MORE: name = "MORE"; break;
522 case FF_LINEMARK: name = "LINEMARK"; break;
523 case FF_END: name = "END"; break;
524 case FF_0DECIMAL: name = "0DECIMAL"; break;
525 case FF_LINESNGL: name = "LINESNGL"; break;
528 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
530 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
534 linemark = t - SvPVX(PL_formtarget);
544 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
560 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
563 SvTAINTED_on(PL_formtarget);
569 const char *s = item = SvPV_const(sv, len);
572 itemsize = sv_len_utf8(sv);
573 if (itemsize != (I32)len) {
575 if (itemsize > fieldsize) {
576 itemsize = fieldsize;
577 itembytes = itemsize;
578 sv_pos_u2b(sv, &itembytes, 0);
582 send = chophere = s + itembytes;
592 sv_pos_b2u(sv, &itemsize);
596 item_is_utf8 = FALSE;
597 if (itemsize > fieldsize)
598 itemsize = fieldsize;
599 send = chophere = s + itemsize;
613 const char *s = item = SvPV_const(sv, len);
616 itemsize = sv_len_utf8(sv);
617 if (itemsize != (I32)len) {
619 if (itemsize <= fieldsize) {
620 const char *send = chophere = s + itemsize;
633 itemsize = fieldsize;
634 itembytes = itemsize;
635 sv_pos_u2b(sv, &itembytes, 0);
636 send = chophere = s + itembytes;
637 while (s < send || (s == send && isSPACE(*s))) {
647 if (strchr(PL_chopset, *s))
652 itemsize = chophere - item;
653 sv_pos_b2u(sv, &itemsize);
659 item_is_utf8 = FALSE;
660 if (itemsize <= fieldsize) {
661 const char *const send = chophere = s + itemsize;
674 itemsize = fieldsize;
675 send = chophere = s + itemsize;
676 while (s < send || (s == send && isSPACE(*s))) {
686 if (strchr(PL_chopset, *s))
691 itemsize = chophere - item;
697 arg = fieldsize - itemsize;
706 arg = fieldsize - itemsize;
720 /* convert to_copy from chars to bytes */
724 to_copy = s - source;
730 const char *s = chophere;
744 const bool oneline = fpc[-1] == FF_LINESNGL;
745 const char *s = item = SvPV_const(sv, len);
746 const char *const send = s + len;
748 item_is_utf8 = DO_UTF8(sv);
759 to_copy = s - SvPVX_const(sv) - 1;
773 /* append to_copy bytes from source to PL_formstring.
774 * item_is_utf8 implies source is utf8.
775 * if trans, translate certain characters during the copy */
780 SvCUR_set(PL_formtarget,
781 t - SvPVX_const(PL_formtarget));
783 if (targ_is_utf8 && !item_is_utf8) {
784 source = tmp = bytes_to_utf8(source, &to_copy);
786 if (item_is_utf8 && !targ_is_utf8) {
788 /* Upgrade targ to UTF8, and then we reduce it to
789 a problem we have a simple solution for.
790 Don't need get magic. */
791 sv_utf8_upgrade_nomg(PL_formtarget);
793 /* re-calculate linemark */
794 s = (U8*)SvPVX(PL_formtarget);
795 /* the bytes we initially allocated to append the
796 * whole line may have been gobbled up during the
797 * upgrade, so allocate a whole new line's worth
802 linemark = s - (U8*)SvPVX(PL_formtarget);
804 /* Easy. They agree. */
805 assert (item_is_utf8 == targ_is_utf8);
808 /* @* and ^* are the only things that can exceed
809 * the linemax, so grow by the output size, plus
810 * a whole new form's worth in case of any further
812 grow = linemax + to_copy;
814 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
815 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
817 Copy(source, t, to_copy, char);
819 /* blank out ~ or control chars, depending on trans.
820 * works on bytes not chars, so relies on not
821 * matching utf8 continuation bytes */
823 U8 *send = s + to_copy;
826 if (trans == '~' ? (ch == '~') :
839 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
847 #if defined(USE_LONG_DOUBLE)
849 ((arg & FORM_NUM_POINT) ?
850 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
853 ((arg & FORM_NUM_POINT) ?
854 "%#0*.*f" : "%0*.*f");
859 #if defined(USE_LONG_DOUBLE)
861 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
864 ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
867 /* If the field is marked with ^ and the value is undefined,
869 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
877 /* overflow evidence */
878 if (num_overflow(value, fieldsize, arg)) {
884 /* Formats aren't yet marked for locales, so assume "yes". */
886 STORE_NUMERIC_STANDARD_SET_LOCAL();
887 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
888 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
889 RESTORE_NUMERIC_STANDARD();
896 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
904 if (arg) { /* repeat until fields exhausted? */
910 t = SvPVX(PL_formtarget) + linemark;
917 const char *s = chophere;
918 const char *send = item + len;
920 while (isSPACE(*s) && (s < send))
925 arg = fieldsize - itemsize;
932 if (strnEQ(s1," ",3)) {
933 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
944 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
946 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
948 SvUTF8_on(PL_formtarget);
949 FmLINES(PL_formtarget) += lines;
951 if (fpc[-1] == FF_BLANK)
952 RETURNOP(cLISTOP->op_first);
964 if (PL_stack_base + *PL_markstack_ptr == SP) {
966 if (GIMME_V == G_SCALAR)
968 RETURNOP(PL_op->op_next->op_next);
970 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
971 Perl_pp_pushmark(aTHX); /* push dst */
972 Perl_pp_pushmark(aTHX); /* push src */
973 ENTER_with_name("grep"); /* enter outer scope */
976 if (PL_op->op_private & OPpGREP_LEX)
977 SAVESPTR(PAD_SVl(PL_op->op_targ));
980 ENTER_with_name("grep_item"); /* enter inner scope */
983 src = PL_stack_base[*PL_markstack_ptr];
985 if (PL_op->op_private & OPpGREP_LEX)
986 PAD_SVl(PL_op->op_targ) = src;
991 if (PL_op->op_type == OP_MAPSTART)
992 Perl_pp_pushmark(aTHX); /* push top */
993 return ((LOGOP*)PL_op->op_next)->op_other;
999 const I32 gimme = GIMME_V;
1000 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1006 /* first, move source pointer to the next item in the source list */
1007 ++PL_markstack_ptr[-1];
1009 /* if there are new items, push them into the destination list */
1010 if (items && gimme != G_VOID) {
1011 /* might need to make room back there first */
1012 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1013 /* XXX this implementation is very pessimal because the stack
1014 * is repeatedly extended for every set of items. Is possible
1015 * to do this without any stack extension or copying at all
1016 * by maintaining a separate list over which the map iterates
1017 * (like foreach does). --gsar */
1019 /* everything in the stack after the destination list moves
1020 * towards the end the stack by the amount of room needed */
1021 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1023 /* items to shift up (accounting for the moved source pointer) */
1024 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1026 /* This optimization is by Ben Tilly and it does
1027 * things differently from what Sarathy (gsar)
1028 * is describing. The downside of this optimization is
1029 * that leaves "holes" (uninitialized and hopefully unused areas)
1030 * to the Perl stack, but on the other hand this
1031 * shouldn't be a problem. If Sarathy's idea gets
1032 * implemented, this optimization should become
1033 * irrelevant. --jhi */
1035 shift = count; /* Avoid shifting too often --Ben Tilly */
1039 dst = (SP += shift);
1040 PL_markstack_ptr[-1] += shift;
1041 *PL_markstack_ptr += shift;
1045 /* copy the new items down to the destination list */
1046 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1047 if (gimme == G_ARRAY) {
1048 /* add returned items to the collection (making mortal copies
1049 * if necessary), then clear the current temps stack frame
1050 * *except* for those items. We do this splicing the items
1051 * into the start of the tmps frame (so some items may be on
1052 * the tmps stack twice), then moving PL_tmps_floor above
1053 * them, then freeing the frame. That way, the only tmps that
1054 * accumulate over iterations are the return values for map.
1055 * We have to do to this way so that everything gets correctly
1056 * freed if we die during the map.
1060 /* make space for the slice */
1061 EXTEND_MORTAL(items);
1062 tmpsbase = PL_tmps_floor + 1;
1063 Move(PL_tmps_stack + tmpsbase,
1064 PL_tmps_stack + tmpsbase + items,
1065 PL_tmps_ix - PL_tmps_floor,
1067 PL_tmps_ix += items;
1072 sv = sv_mortalcopy(sv);
1074 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1076 /* clear the stack frame except for the items */
1077 PL_tmps_floor += items;
1079 /* FREETMPS may have cleared the TEMP flag on some of the items */
1082 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1085 /* scalar context: we don't care about which values map returns
1086 * (we use undef here). And so we certainly don't want to do mortal
1087 * copies of meaningless values. */
1088 while (items-- > 0) {
1090 *dst-- = &PL_sv_undef;
1098 LEAVE_with_name("grep_item"); /* exit inner scope */
1101 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1103 (void)POPMARK; /* pop top */
1104 LEAVE_with_name("grep"); /* exit outer scope */
1105 (void)POPMARK; /* pop src */
1106 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1107 (void)POPMARK; /* pop dst */
1108 SP = PL_stack_base + POPMARK; /* pop original mark */
1109 if (gimme == G_SCALAR) {
1110 if (PL_op->op_private & OPpGREP_LEX) {
1111 SV* sv = sv_newmortal();
1112 sv_setiv(sv, items);
1120 else if (gimme == G_ARRAY)
1127 ENTER_with_name("grep_item"); /* enter inner scope */
1130 /* set $_ to the new source item */
1131 src = PL_stack_base[PL_markstack_ptr[-1]];
1133 if (PL_op->op_private & OPpGREP_LEX)
1134 PAD_SVl(PL_op->op_targ) = src;
1138 RETURNOP(cLOGOP->op_other);
1147 if (GIMME == G_ARRAY)
1149 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1150 return cLOGOP->op_other;
1160 if (GIMME == G_ARRAY) {
1161 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1165 SV * const targ = PAD_SV(PL_op->op_targ);
1168 if (PL_op->op_private & OPpFLIP_LINENUM) {
1169 if (GvIO(PL_last_in_gv)) {
1170 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1173 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1175 flip = SvIV(sv) == SvIV(GvSV(gv));
1181 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1182 if (PL_op->op_flags & OPf_SPECIAL) {
1190 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1193 sv_setpvs(TARG, "");
1199 /* This code tries to decide if "$left .. $right" should use the
1200 magical string increment, or if the range is numeric (we make
1201 an exception for .."0" [#18165]). AMS 20021031. */
1203 #define RANGE_IS_NUMERIC(left,right) ( \
1204 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1205 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1206 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1207 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1208 && (!SvOK(right) || looks_like_number(right))))
1214 if (GIMME == G_ARRAY) {
1220 if (RANGE_IS_NUMERIC(left,right)) {
1223 if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) ||
1224 (SvOK(right) && SvNV_nomg(right) > IV_MAX))
1225 DIE(aTHX_ "Range iterator outside integer range");
1226 i = SvIV_nomg(left);
1227 max = SvIV_nomg(right);
1236 SV * const sv = sv_2mortal(newSViv(i++));
1242 const char * const lpv = SvPV_nomg_const(left, llen);
1243 const char * const tmps = SvPV_nomg_const(right, len);
1245 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1246 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1248 if (strEQ(SvPVX_const(sv),tmps))
1250 sv = sv_2mortal(newSVsv(sv));
1257 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1261 if (PL_op->op_private & OPpFLIP_LINENUM) {
1262 if (GvIO(PL_last_in_gv)) {
1263 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1266 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1267 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1275 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1276 sv_catpvs(targ, "E0");
1286 static const char * const context_name[] = {
1288 NULL, /* CXt_WHEN never actually needs "block" */
1289 NULL, /* CXt_BLOCK never actually needs "block" */
1290 NULL, /* CXt_GIVEN never actually needs "block" */
1291 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1292 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1293 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1294 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1302 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1307 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1309 for (i = cxstack_ix; i >= 0; i--) {
1310 const PERL_CONTEXT * const cx = &cxstack[i];
1311 switch (CxTYPE(cx)) {
1317 /* diag_listed_as: Exiting subroutine via %s */
1318 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1319 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1320 if (CxTYPE(cx) == CXt_NULL)
1323 case CXt_LOOP_LAZYIV:
1324 case CXt_LOOP_LAZYSV:
1326 case CXt_LOOP_PLAIN:
1328 STRLEN cx_label_len = 0;
1329 U32 cx_label_flags = 0;
1330 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1332 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1335 (const U8*)cx_label, cx_label_len,
1336 (const U8*)label, len) == 0)
1338 (const U8*)label, len,
1339 (const U8*)cx_label, cx_label_len) == 0)
1340 : (len == cx_label_len && ((cx_label == label)
1341 || memEQ(cx_label, label, len))) )) {
1342 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1343 (long)i, cx_label));
1346 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1357 Perl_dowantarray(pTHX)
1360 const I32 gimme = block_gimme();
1361 return (gimme == G_VOID) ? G_SCALAR : gimme;
1365 Perl_block_gimme(pTHX)
1368 const I32 cxix = dopoptosub(cxstack_ix);
1372 switch (cxstack[cxix].blk_gimme) {
1380 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1381 assert(0); /* NOTREACHED */
1387 Perl_is_lvalue_sub(pTHX)
1390 const I32 cxix = dopoptosub(cxstack_ix);
1391 assert(cxix >= 0); /* We should only be called from inside subs */
1393 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1394 return CxLVAL(cxstack + cxix);
1399 /* only used by PUSHSUB */
1401 Perl_was_lvalue_sub(pTHX)
1404 const I32 cxix = dopoptosub(cxstack_ix-1);
1405 assert(cxix >= 0); /* We should only be called from inside subs */
1407 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1408 return CxLVAL(cxstack + cxix);
1414 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1419 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1421 for (i = startingblock; i >= 0; i--) {
1422 const PERL_CONTEXT * const cx = &cxstk[i];
1423 switch (CxTYPE(cx)) {
1429 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1437 S_dopoptoeval(pTHX_ I32 startingblock)
1441 for (i = startingblock; i >= 0; i--) {
1442 const PERL_CONTEXT *cx = &cxstack[i];
1443 switch (CxTYPE(cx)) {
1447 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1455 S_dopoptoloop(pTHX_ I32 startingblock)
1459 for (i = startingblock; i >= 0; i--) {
1460 const PERL_CONTEXT * const cx = &cxstack[i];
1461 switch (CxTYPE(cx)) {
1467 /* diag_listed_as: Exiting subroutine via %s */
1468 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1469 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1470 if ((CxTYPE(cx)) == CXt_NULL)
1473 case CXt_LOOP_LAZYIV:
1474 case CXt_LOOP_LAZYSV:
1476 case CXt_LOOP_PLAIN:
1477 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1485 S_dopoptogiven(pTHX_ I32 startingblock)
1489 for (i = startingblock; i >= 0; i--) {
1490 const PERL_CONTEXT *cx = &cxstack[i];
1491 switch (CxTYPE(cx)) {
1495 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1497 case CXt_LOOP_PLAIN:
1498 assert(!CxFOREACHDEF(cx));
1500 case CXt_LOOP_LAZYIV:
1501 case CXt_LOOP_LAZYSV:
1503 if (CxFOREACHDEF(cx)) {
1504 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1513 S_dopoptowhen(pTHX_ I32 startingblock)
1517 for (i = startingblock; i >= 0; i--) {
1518 const PERL_CONTEXT *cx = &cxstack[i];
1519 switch (CxTYPE(cx)) {
1523 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1531 Perl_dounwind(pTHX_ I32 cxix)
1536 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1539 while (cxstack_ix > cxix) {
1541 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1542 DEBUG_CX("UNWIND"); \
1543 /* Note: we don't need to restore the base context info till the end. */
1544 switch (CxTYPE(cx)) {
1547 continue; /* not break */
1555 case CXt_LOOP_LAZYIV:
1556 case CXt_LOOP_LAZYSV:
1558 case CXt_LOOP_PLAIN:
1569 PERL_UNUSED_VAR(optype);
1573 Perl_qerror(pTHX_ SV *err)
1577 PERL_ARGS_ASSERT_QERROR;
1580 if (PL_in_eval & EVAL_KEEPERR) {
1581 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1585 sv_catsv(ERRSV, err);
1588 sv_catsv(PL_errors, err);
1590 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1592 ++PL_parser->error_count;
1596 Perl_die_unwind(pTHX_ SV *msv)
1599 SV *exceptsv = sv_mortalcopy(msv);
1600 U8 in_eval = PL_in_eval;
1601 PERL_ARGS_ASSERT_DIE_UNWIND;
1608 * Historically, perl used to set ERRSV ($@) early in the die
1609 * process and rely on it not getting clobbered during unwinding.
1610 * That sucked, because it was liable to get clobbered, so the
1611 * setting of ERRSV used to emit the exception from eval{} has
1612 * been moved to much later, after unwinding (see just before
1613 * JMPENV_JUMP below). However, some modules were relying on the
1614 * early setting, by examining $@ during unwinding to use it as
1615 * a flag indicating whether the current unwinding was caused by
1616 * an exception. It was never a reliable flag for that purpose,
1617 * being totally open to false positives even without actual
1618 * clobberage, but was useful enough for production code to
1619 * semantically rely on it.
1621 * We'd like to have a proper introspective interface that
1622 * explicitly describes the reason for whatever unwinding
1623 * operations are currently in progress, so that those modules
1624 * work reliably and $@ isn't further overloaded. But we don't
1625 * have one yet. In its absence, as a stopgap measure, ERRSV is
1626 * now *additionally* set here, before unwinding, to serve as the
1627 * (unreliable) flag that it used to.
1629 * This behaviour is temporary, and should be removed when a
1630 * proper way to detect exceptional unwinding has been developed.
1631 * As of 2010-12, the authors of modules relying on the hack
1632 * are aware of the issue, because the modules failed on
1633 * perls 5.13.{1..7} which had late setting of $@ without this
1634 * early-setting hack.
1636 if (!(in_eval & EVAL_KEEPERR)) {
1637 SvTEMP_off(exceptsv);
1638 sv_setsv(ERRSV, exceptsv);
1641 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1642 && PL_curstackinfo->si_prev)
1654 JMPENV *restartjmpenv;
1657 if (cxix < cxstack_ix)
1660 POPBLOCK(cx,PL_curpm);
1661 if (CxTYPE(cx) != CXt_EVAL) {
1663 const char* message = SvPVx_const(exceptsv, msglen);
1664 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1665 PerlIO_write(Perl_error_log, message, msglen);
1669 namesv = cx->blk_eval.old_namesv;
1670 oldcop = cx->blk_oldcop;
1671 restartjmpenv = cx->blk_eval.cur_top_env;
1672 restartop = cx->blk_eval.retop;
1674 if (gimme == G_SCALAR)
1675 *++newsp = &PL_sv_undef;
1676 PL_stack_sp = newsp;
1680 /* LEAVE could clobber PL_curcop (see save_re_context())
1681 * XXX it might be better to find a way to avoid messing with
1682 * PL_curcop in save_re_context() instead, but this is a more
1683 * minimal fix --GSAR */
1686 if (optype == OP_REQUIRE) {
1687 (void)hv_store(GvHVn(PL_incgv),
1688 SvPVX_const(namesv),
1689 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1691 /* note that unlike pp_entereval, pp_require isn't
1692 * supposed to trap errors. So now that we've popped the
1693 * EVAL that pp_require pushed, and processed the error
1694 * message, rethrow the error */
1695 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1696 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1699 if (in_eval & EVAL_KEEPERR) {
1700 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1704 sv_setsv(ERRSV, exceptsv);
1706 PL_restartjmpenv = restartjmpenv;
1707 PL_restartop = restartop;
1709 assert(0); /* NOTREACHED */
1713 write_to_stderr(exceptsv);
1715 assert(0); /* NOTREACHED */
1720 dVAR; dSP; dPOPTOPssrl;
1721 if (SvTRUE(left) != SvTRUE(right))
1728 =for apidoc caller_cx
1730 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1731 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1732 information returned to Perl by C<caller>. Note that XSUBs don't get a
1733 stack frame, so C<caller_cx(0, NULL)> will return information for the
1734 immediately-surrounding Perl code.
1736 This function skips over the automatic calls to C<&DB::sub> made on the
1737 behalf of the debugger. If the stack frame requested was a sub called by
1738 C<DB::sub>, the return value will be the frame for the call to
1739 C<DB::sub>, since that has the correct line number/etc. for the call
1740 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1741 frame for the sub call itself.
1746 const PERL_CONTEXT *
1747 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1749 I32 cxix = dopoptosub(cxstack_ix);
1750 const PERL_CONTEXT *cx;
1751 const PERL_CONTEXT *ccstack = cxstack;
1752 const PERL_SI *top_si = PL_curstackinfo;
1755 /* we may be in a higher stacklevel, so dig down deeper */
1756 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1757 top_si = top_si->si_prev;
1758 ccstack = top_si->si_cxstack;
1759 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1763 /* caller() should not report the automatic calls to &DB::sub */
1764 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1765 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1769 cxix = dopoptosub_at(ccstack, cxix - 1);
1772 cx = &ccstack[cxix];
1773 if (dbcxp) *dbcxp = cx;
1775 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1776 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1777 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1778 field below is defined for any cx. */
1779 /* caller() should not report the automatic calls to &DB::sub */
1780 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1781 cx = &ccstack[dbcxix];
1791 const PERL_CONTEXT *cx;
1792 const PERL_CONTEXT *dbcx;
1794 const HEK *stash_hek;
1796 bool has_arg = MAXARG && TOPs;
1804 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1806 if (GIMME != G_ARRAY) {
1814 assert(CopSTASH(cx->blk_oldcop));
1815 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1816 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1818 if (GIMME != G_ARRAY) {
1821 PUSHs(&PL_sv_undef);
1824 sv_sethek(TARG, stash_hek);
1833 PUSHs(&PL_sv_undef);
1836 sv_sethek(TARG, stash_hek);
1839 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1840 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1843 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1844 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1845 /* So is ccstack[dbcxix]. */
1846 if (cvgv && isGV(cvgv)) {
1847 SV * const sv = newSV(0);
1848 gv_efullname3(sv, cvgv, NULL);
1850 PUSHs(boolSV(CxHASARGS(cx)));
1853 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1854 PUSHs(boolSV(CxHASARGS(cx)));
1858 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1861 gimme = (I32)cx->blk_gimme;
1862 if (gimme == G_VOID)
1863 PUSHs(&PL_sv_undef);
1865 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1866 if (CxTYPE(cx) == CXt_EVAL) {
1868 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1869 PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
1870 SvCUR(cx->blk_eval.cur_text)-2,
1871 SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
1875 else if (cx->blk_eval.old_namesv) {
1876 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1879 /* eval BLOCK (try blocks have old_namesv == 0) */
1881 PUSHs(&PL_sv_undef);
1882 PUSHs(&PL_sv_undef);
1886 PUSHs(&PL_sv_undef);
1887 PUSHs(&PL_sv_undef);
1889 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1890 && CopSTASH_eq(PL_curcop, PL_debstash))
1892 AV * const ary = cx->blk_sub.argarray;
1893 const int off = AvARRAY(ary) - AvALLOC(ary);
1895 Perl_init_dbargs(aTHX);
1897 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1898 av_extend(PL_dbargs, AvFILLp(ary) + off);
1899 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1900 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1902 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1905 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1907 if (old_warnings == pWARN_NONE)
1908 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1909 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1910 mask = &PL_sv_undef ;
1911 else if (old_warnings == pWARN_ALL ||
1912 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1913 /* Get the bit mask for $warnings::Bits{all}, because
1914 * it could have been extended by warnings::register */
1916 HV * const bits = get_hv("warnings::Bits", 0);
1917 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1918 mask = newSVsv(*bits_all);
1921 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1925 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1929 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1930 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1941 if (MAXARG < 1 || (!TOPs && !POPs))
1942 tmps = NULL, len = 0;
1944 tmps = SvPVx_const(POPs, len);
1945 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1950 /* like pp_nextstate, but used instead when the debugger is active */
1955 PL_curcop = (COP*)PL_op;
1956 TAINT_NOT; /* Each statement is presumed innocent */
1957 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1962 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1963 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1967 const I32 gimme = G_ARRAY;
1969 GV * const gv = PL_DBgv;
1972 if (gv && isGV_with_GP(gv))
1975 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
1976 DIE(aTHX_ "No DB::DB routine defined");
1978 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1979 /* don't do recursive DB::DB call */
1993 (void)(*CvXSUB(cv))(aTHX_ cv);
1999 PUSHBLOCK(cx, CXt_SUB, SP);
2001 cx->blk_sub.retop = PL_op->op_next;
2004 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
2005 RETURNOP(CvSTART(cv));
2013 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
2016 PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2018 if (flags & SVs_PADTMP) {
2019 flags &= ~SVs_PADTMP;
2022 if (gimme == G_SCALAR) {
2024 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2025 ? *SP : sv_mortalcopy(*SP);
2027 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2030 *++MARK = &PL_sv_undef;
2034 else if (gimme == G_ARRAY) {
2035 /* in case LEAVE wipes old return values */
2036 while (++MARK <= SP) {
2037 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2040 *++newsp = sv_mortalcopy(*MARK);
2041 TAINT_NOT; /* Each item is independent */
2044 /* When this function was called with MARK == newsp, we reach this
2045 * point with SP == newsp. */
2055 I32 gimme = GIMME_V;
2057 ENTER_with_name("block");
2060 PUSHBLOCK(cx, CXt_BLOCK, SP);
2073 if (PL_op->op_flags & OPf_SPECIAL) {
2074 cx = &cxstack[cxstack_ix];
2075 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2080 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2083 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
2084 PL_curpm = newpm; /* Don't pop $1 et al till now */
2086 LEAVE_with_name("block");
2095 const I32 gimme = GIMME_V;
2096 void *itervar; /* location of the iteration variable */
2097 U8 cxtype = CXt_LOOP_FOR;
2099 ENTER_with_name("loop1");
2102 if (PL_op->op_targ) { /* "my" variable */
2103 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2104 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2105 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2106 SVs_PADSTALE, SVs_PADSTALE);
2108 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2110 itervar = PL_comppad;
2112 itervar = &PAD_SVl(PL_op->op_targ);
2115 else { /* symbol table variable */
2116 GV * const gv = MUTABLE_GV(POPs);
2117 SV** svp = &GvSV(gv);
2118 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2120 itervar = (void *)gv;
2123 if (PL_op->op_private & OPpITER_DEF)
2124 cxtype |= CXp_FOR_DEF;
2126 ENTER_with_name("loop2");
2128 PUSHBLOCK(cx, cxtype, SP);
2129 PUSHLOOP_FOR(cx, itervar, MARK);
2130 if (PL_op->op_flags & OPf_STACKED) {
2131 SV *maybe_ary = POPs;
2132 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2134 SV * const right = maybe_ary;
2137 if (RANGE_IS_NUMERIC(sv,right)) {
2138 cx->cx_type &= ~CXTYPEMASK;
2139 cx->cx_type |= CXt_LOOP_LAZYIV;
2140 /* Make sure that no-one re-orders cop.h and breaks our
2142 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2143 #ifdef NV_PRESERVES_UV
2144 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2145 (SvNV_nomg(sv) > (NV)IV_MAX)))
2147 (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2148 (SvNV_nomg(right) < (NV)IV_MIN))))
2150 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
2152 ((SvNV_nomg(sv) > 0) &&
2153 ((SvUV_nomg(sv) > (UV)IV_MAX) ||
2154 (SvNV_nomg(sv) > (NV)UV_MAX)))))
2156 (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
2158 ((SvNV_nomg(right) > 0) &&
2159 ((SvUV_nomg(right) > (UV)IV_MAX) ||
2160 (SvNV_nomg(right) > (NV)UV_MAX))
2163 DIE(aTHX_ "Range iterator outside integer range");
2164 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2165 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2167 /* for correct -Dstv display */
2168 cx->blk_oldsp = sp - PL_stack_base;
2172 cx->cx_type &= ~CXTYPEMASK;
2173 cx->cx_type |= CXt_LOOP_LAZYSV;
2174 /* Make sure that no-one re-orders cop.h and breaks our
2176 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2177 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2178 cx->blk_loop.state_u.lazysv.end = right;
2179 SvREFCNT_inc(right);
2180 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2181 /* This will do the upgrade to SVt_PV, and warn if the value
2182 is uninitialised. */
2183 (void) SvPV_nolen_const(right);
2184 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2185 to replace !SvOK() with a pointer to "". */
2187 SvREFCNT_dec(right);
2188 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2192 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2193 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2194 SvREFCNT_inc(maybe_ary);
2195 cx->blk_loop.state_u.ary.ix =
2196 (PL_op->op_private & OPpITER_REVERSED) ?
2197 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2201 else { /* iterating over items on the stack */
2202 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2203 if (PL_op->op_private & OPpITER_REVERSED) {
2204 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2207 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2218 const I32 gimme = GIMME_V;
2220 ENTER_with_name("loop1");
2222 ENTER_with_name("loop2");
2224 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2225 PUSHLOOP_PLAIN(cx, SP);
2240 assert(CxTYPE_is_LOOP(cx));
2242 newsp = PL_stack_base + cx->blk_loop.resetsp;
2245 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
2248 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2249 PL_curpm = newpm; /* ... and pop $1 et al */
2251 LEAVE_with_name("loop2");
2252 LEAVE_with_name("loop1");
2258 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2259 PERL_CONTEXT *cx, PMOP *newpm)
2261 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2262 if (gimme == G_SCALAR) {
2263 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2265 const char *what = NULL;
2267 assert(MARK+1 == SP);
2268 if ((SvPADTMP(TOPs) ||
2269 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2272 !SvSMAGICAL(TOPs)) {
2274 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2275 : "a readonly value" : "a temporary";
2280 /* sub:lvalue{} will take us here. */
2289 "Can't return %s from lvalue subroutine", what
2294 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2295 if (!SvPADTMP(*SP)) {
2296 *++newsp = SvREFCNT_inc(*SP);
2301 /* FREETMPS could clobber it */
2302 SV *sv = SvREFCNT_inc(*SP);
2304 *++newsp = sv_mortalcopy(sv);
2311 ? sv_mortalcopy(*SP)
2313 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2318 *++newsp = &PL_sv_undef;
2320 if (CxLVAL(cx) & OPpDEREF) {
2323 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2327 else if (gimme == G_ARRAY) {
2328 assert (!(CxLVAL(cx) & OPpDEREF));
2329 if (ref || !CxLVAL(cx))
2330 while (++MARK <= SP)
2332 SvFLAGS(*MARK) & SVs_PADTMP
2333 ? sv_mortalcopy(*MARK)
2336 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2337 else while (++MARK <= SP) {
2338 if (*MARK != &PL_sv_undef
2340 || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2345 /* Might be flattened array after $#array = */
2352 /* diag_listed_as: Can't return %s from lvalue subroutine */
2354 "Can't return a %s from lvalue subroutine",
2355 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2361 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2364 PL_stack_sp = newsp;
2371 bool popsub2 = FALSE;
2372 bool clear_errsv = FALSE;
2382 const I32 cxix = dopoptosub(cxstack_ix);
2385 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2386 * sort block, which is a CXt_NULL
2389 PL_stack_base[1] = *PL_stack_sp;
2390 PL_stack_sp = PL_stack_base + 1;
2394 DIE(aTHX_ "Can't return outside a subroutine");
2396 if (cxix < cxstack_ix)
2399 if (CxMULTICALL(&cxstack[cxix])) {
2400 gimme = cxstack[cxix].blk_gimme;
2401 if (gimme == G_VOID)
2402 PL_stack_sp = PL_stack_base;
2403 else if (gimme == G_SCALAR) {
2404 PL_stack_base[1] = *PL_stack_sp;
2405 PL_stack_sp = PL_stack_base + 1;
2411 switch (CxTYPE(cx)) {
2414 lval = !!CvLVALUE(cx->blk_sub.cv);
2415 retop = cx->blk_sub.retop;
2416 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2419 if (!(PL_in_eval & EVAL_KEEPERR))
2422 namesv = cx->blk_eval.old_namesv;
2423 retop = cx->blk_eval.retop;
2426 if (optype == OP_REQUIRE &&
2427 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2429 /* Unassume the success we assumed earlier. */
2430 (void)hv_delete(GvHVn(PL_incgv),
2431 SvPVX_const(namesv),
2432 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2434 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2439 retop = cx->blk_sub.retop;
2442 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2446 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2448 if (gimme == G_SCALAR) {
2451 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2452 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2453 && !SvMAGICAL(TOPs)) {
2454 *++newsp = SvREFCNT_inc(*SP);
2459 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2461 *++newsp = sv_mortalcopy(sv);
2465 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2466 && !SvMAGICAL(*SP)) {
2470 *++newsp = sv_mortalcopy(*SP);
2473 *++newsp = sv_mortalcopy(*SP);
2476 *++newsp = &PL_sv_undef;
2478 else if (gimme == G_ARRAY) {
2479 while (++MARK <= SP) {
2480 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2481 && !SvGMAGICAL(*MARK)
2482 ? *MARK : sv_mortalcopy(*MARK);
2483 TAINT_NOT; /* Each item is independent */
2486 PL_stack_sp = newsp;
2490 /* Stack values are safe: */
2493 POPSUB(cx,sv); /* release CV and @_ ... */
2497 PL_curpm = newpm; /* ... and pop $1 et al */
2506 /* This duplicates parts of pp_leavesub, so that it can share code with
2517 if (CxMULTICALL(&cxstack[cxstack_ix]))
2521 cxstack_ix++; /* temporarily protect top context */
2525 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2529 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2530 PL_curpm = newpm; /* ... and pop $1 et al */
2533 return cx->blk_sub.retop;
2537 S_unwind_loop(pTHX_ const char * const opname)
2541 if (PL_op->op_flags & OPf_SPECIAL) {
2542 cxix = dopoptoloop(cxstack_ix);
2544 /* diag_listed_as: Can't "last" outside a loop block */
2545 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2550 const char * const label =
2551 PL_op->op_flags & OPf_STACKED
2552 ? SvPV(TOPs,label_len)
2553 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2554 const U32 label_flags =
2555 PL_op->op_flags & OPf_STACKED
2557 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2559 cxix = dopoptolabel(label, label_len, label_flags);
2561 /* diag_listed_as: Label not found for "last %s" */
2562 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2564 SVfARG(PL_op->op_flags & OPf_STACKED
2565 && !SvGMAGICAL(TOPp1s)
2567 : newSVpvn_flags(label,
2569 label_flags | SVs_TEMP)));
2571 if (cxix < cxstack_ix)
2589 S_unwind_loop(aTHX_ "last");
2592 cxstack_ix++; /* temporarily protect top context */
2594 switch (CxTYPE(cx)) {
2595 case CXt_LOOP_LAZYIV:
2596 case CXt_LOOP_LAZYSV:
2598 case CXt_LOOP_PLAIN:
2600 newsp = PL_stack_base + cx->blk_loop.resetsp;
2601 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2605 nextop = cx->blk_sub.retop;
2609 nextop = cx->blk_eval.retop;
2613 nextop = cx->blk_sub.retop;
2616 DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2620 PL_stack_sp = adjust_stack_on_leave(newsp, PL_stack_sp, MARK, gimme,
2621 pop2 == CXt_SUB ? SVs_TEMP : 0);
2625 /* Stack values are safe: */
2627 case CXt_LOOP_LAZYIV:
2628 case CXt_LOOP_PLAIN:
2629 case CXt_LOOP_LAZYSV:
2631 POPLOOP(cx); /* release loop vars ... */
2635 POPSUB(cx,sv); /* release CV and @_ ... */
2638 PL_curpm = newpm; /* ... and pop $1 et al */
2641 PERL_UNUSED_VAR(optype);
2642 PERL_UNUSED_VAR(gimme);
2650 const I32 inner = PL_scopestack_ix;
2652 S_unwind_loop(aTHX_ "next");
2654 /* clear off anything above the scope we're re-entering, but
2655 * save the rest until after a possible continue block */
2657 if (PL_scopestack_ix < inner)
2658 leave_scope(PL_scopestack[PL_scopestack_ix]);
2659 PL_curcop = cx->blk_oldcop;
2660 return (cx)->blk_loop.my_op->op_nextop;
2666 const I32 cxix = S_unwind_loop(aTHX_ "redo");
2669 OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2671 if (redo_op->op_type == OP_ENTER) {
2672 /* pop one less context to avoid $x being freed in while (my $x..) */
2674 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2675 redo_op = redo_op->op_next;
2679 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2680 LEAVE_SCOPE(oldsave);
2682 PL_curcop = cx->blk_oldcop;
2687 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2691 static const char too_deep[] = "Target of goto is too deeply nested";
2693 PERL_ARGS_ASSERT_DOFINDLABEL;
2696 Perl_croak(aTHX_ too_deep);
2697 if (o->op_type == OP_LEAVE ||
2698 o->op_type == OP_SCOPE ||
2699 o->op_type == OP_LEAVELOOP ||
2700 o->op_type == OP_LEAVESUB ||
2701 o->op_type == OP_LEAVETRY)
2703 *ops++ = cUNOPo->op_first;
2705 Perl_croak(aTHX_ too_deep);
2708 if (o->op_flags & OPf_KIDS) {
2710 /* First try all the kids at this level, since that's likeliest. */
2711 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2712 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2713 STRLEN kid_label_len;
2714 U32 kid_label_flags;
2715 const char *kid_label = CopLABEL_len_flags(kCOP,
2716 &kid_label_len, &kid_label_flags);
2718 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2721 (const U8*)kid_label, kid_label_len,
2722 (const U8*)label, len) == 0)
2724 (const U8*)label, len,
2725 (const U8*)kid_label, kid_label_len) == 0)
2726 : ( len == kid_label_len && ((kid_label == label)
2727 || memEQ(kid_label, label, len)))))
2731 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2732 if (kid == PL_lastgotoprobe)
2734 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2737 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2738 ops[-1]->op_type == OP_DBSTATE)
2743 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2757 #define GOTO_DEPTH 64
2758 OP *enterops[GOTO_DEPTH];
2759 const char *label = NULL;
2760 STRLEN label_len = 0;
2761 U32 label_flags = 0;
2762 const bool do_dump = (PL_op->op_type == OP_DUMP);
2763 static const char must_have_label[] = "goto must have label";
2765 if (PL_op->op_flags & OPf_STACKED) {
2766 SV * const sv = POPs;
2768 /* This egregious kludge implements goto &subroutine */
2769 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2772 CV *cv = MUTABLE_CV(SvRV(sv));
2773 AV *arg = GvAV(PL_defgv);
2777 if (!CvROOT(cv) && !CvXSUB(cv)) {
2778 const GV * const gv = CvGV(cv);
2782 /* autoloaded stub? */
2783 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2785 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2787 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2788 if (autogv && (cv = GvCV(autogv)))
2790 tmpstr = sv_newmortal();
2791 gv_efullname3(tmpstr, gv, NULL);
2792 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2794 DIE(aTHX_ "Goto undefined subroutine");
2797 /* First do some returnish stuff. */
2798 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2800 cxix = dopoptosub(cxstack_ix);
2802 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2803 if (cxix < cxstack_ix)
2807 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2808 if (CxTYPE(cx) == CXt_EVAL) {
2810 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2811 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2813 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2814 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2816 else if (CxMULTICALL(cx))
2817 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2818 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2819 AV* av = cx->blk_sub.argarray;
2821 /* abandon the original @_ if it got reified or if it is
2822 the same as the current @_ */
2823 if (AvREAL(av) || av == arg) {
2827 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2829 else CLEAR_ARGARRAY(av);
2831 /* We donate this refcount later to the callee’s pad. */
2832 SvREFCNT_inc_simple_void(arg);
2833 if (CxTYPE(cx) == CXt_SUB &&
2834 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2835 SvREFCNT_dec(cx->blk_sub.cv);
2836 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2837 LEAVE_SCOPE(oldsave);
2839 /* A destructor called during LEAVE_SCOPE could have undefined
2840 * our precious cv. See bug #99850. */
2841 if (!CvROOT(cv) && !CvXSUB(cv)) {
2842 const GV * const gv = CvGV(cv);
2845 SV * const tmpstr = sv_newmortal();
2846 gv_efullname3(tmpstr, gv, NULL);
2847 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2850 DIE(aTHX_ "Goto undefined subroutine");
2853 /* Now do some callish stuff. */
2855 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2857 OP* const retop = cx->blk_sub.retop;
2858 SV **newsp PERL_UNUSED_DECL;
2859 I32 gimme PERL_UNUSED_DECL;
2860 const SSize_t items = AvFILLp(arg) + 1;
2863 /* put GvAV(defgv) back onto stack */
2864 EXTEND(SP, items+1); /* @_ could have been extended. */
2865 Copy(AvARRAY(arg), SP + 1, items, SV*);
2870 for (index=0; index<items; index++)
2871 SvREFCNT_inc_void(sv_2mortal(SP[-index]));
2874 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2875 /* Restore old @_ */
2876 arg = GvAV(PL_defgv);
2877 GvAV(PL_defgv) = cx->blk_sub.savearray;
2881 /* XS subs don't have a CxSUB, so pop it */
2882 POPBLOCK(cx, PL_curpm);
2883 /* Push a mark for the start of arglist */
2886 (void)(*CvXSUB(cv))(aTHX_ cv);
2891 PADLIST * const padlist = CvPADLIST(cv);
2892 if (CxTYPE(cx) == CXt_EVAL) {
2893 PL_in_eval = CxOLD_IN_EVAL(cx);
2894 PL_eval_root = cx->blk_eval.old_eval_root;
2895 cx->cx_type = CXt_SUB;
2897 cx->blk_sub.cv = cv;
2898 cx->blk_sub.olddepth = CvDEPTH(cv);
2901 if (CvDEPTH(cv) < 2)
2902 SvREFCNT_inc_simple_void_NN(cv);
2904 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2905 sub_crush_depth(cv);
2906 pad_push(padlist, CvDEPTH(cv));
2908 PL_curcop = cx->blk_oldcop;
2910 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2913 CX_CURPAD_SAVE(cx->blk_sub);
2915 /* cx->blk_sub.argarray has no reference count, so we
2916 need something to hang on to our argument array so
2917 that cx->blk_sub.argarray does not end up pointing
2918 to freed memory as the result of undef *_. So put
2919 it in the callee’s pad, donating our refer-
2921 SvREFCNT_dec(PAD_SVl(0));
2922 PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2924 /* GvAV(PL_defgv) might have been modified on scope
2925 exit, so restore it. */
2926 if (arg != GvAV(PL_defgv)) {
2927 AV * const av = GvAV(PL_defgv);
2928 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2932 else SvREFCNT_dec(arg);
2933 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2934 Perl_get_db_sub(aTHX_ NULL, cv);
2936 CV * const gotocv = get_cvs("DB::goto", 0);
2938 PUSHMARK( PL_stack_sp );
2939 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2944 RETURNOP(CvSTART(cv));
2948 label = SvPV_const(sv, label_len);
2949 label_flags = SvUTF8(sv);
2952 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2953 label = cPVOP->op_pv;
2954 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2955 label_len = strlen(label);
2957 if (!(do_dump || label_len)) DIE(aTHX_ must_have_label);
2962 OP *gotoprobe = NULL;
2963 bool leaving_eval = FALSE;
2964 bool in_block = FALSE;
2965 PERL_CONTEXT *last_eval_cx = NULL;
2969 PL_lastgotoprobe = NULL;
2971 for (ix = cxstack_ix; ix >= 0; ix--) {
2973 switch (CxTYPE(cx)) {
2975 leaving_eval = TRUE;
2976 if (!CxTRYBLOCK(cx)) {
2977 gotoprobe = (last_eval_cx ?
2978 last_eval_cx->blk_eval.old_eval_root :
2983 /* else fall through */
2984 case CXt_LOOP_LAZYIV:
2985 case CXt_LOOP_LAZYSV:
2987 case CXt_LOOP_PLAIN:
2990 gotoprobe = cx->blk_oldcop->op_sibling;
2996 gotoprobe = cx->blk_oldcop->op_sibling;
2999 gotoprobe = PL_main_root;
3002 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3003 gotoprobe = CvROOT(cx->blk_sub.cv);
3009 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3012 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3013 CxTYPE(cx), (long) ix);
3014 gotoprobe = PL_main_root;
3018 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3019 enterops, enterops + GOTO_DEPTH);
3022 if (gotoprobe->op_sibling &&
3023 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3024 gotoprobe->op_sibling->op_sibling) {
3025 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3026 label, label_len, label_flags, enterops,
3027 enterops + GOTO_DEPTH);
3032 PL_lastgotoprobe = gotoprobe;
3035 DIE(aTHX_ "Can't find label %"SVf,
3036 SVfARG(newSVpvn_flags(label, label_len,
3037 SVs_TEMP | label_flags)));
3039 /* if we're leaving an eval, check before we pop any frames
3040 that we're not going to punt, otherwise the error
3043 if (leaving_eval && *enterops && enterops[1]) {
3045 for (i = 1; enterops[i]; i++)
3046 if (enterops[i]->op_type == OP_ENTERITER)
3047 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3050 if (*enterops && enterops[1]) {
3051 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3053 deprecate("\"goto\" to jump into a construct");
3056 /* pop unwanted frames */
3058 if (ix < cxstack_ix) {
3065 oldsave = PL_scopestack[PL_scopestack_ix];
3066 LEAVE_SCOPE(oldsave);
3069 /* push wanted frames */
3071 if (*enterops && enterops[1]) {
3072 OP * const oldop = PL_op;
3073 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3074 for (; enterops[ix]; ix++) {
3075 PL_op = enterops[ix];
3076 /* Eventually we may want to stack the needed arguments
3077 * for each op. For now, we punt on the hard ones. */
3078 if (PL_op->op_type == OP_ENTERITER)
3079 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3080 PL_op->op_ppaddr(aTHX);
3088 if (!retop) retop = PL_main_start;
3090 PL_restartop = retop;
3091 PL_do_undump = TRUE;
3095 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3096 PL_do_undump = FALSE;
3111 anum = 0; (void)POPs;
3116 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3118 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3121 PL_exit_flags |= PERL_EXIT_EXPECTED;
3123 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3124 if (anum || !(PL_minus_c && PL_madskills))
3129 PUSHs(&PL_sv_undef);
3136 S_save_lines(pTHX_ AV *array, SV *sv)
3138 const char *s = SvPVX_const(sv);
3139 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3142 PERL_ARGS_ASSERT_SAVE_LINES;
3144 while (s && s < send) {
3146 SV * const tmpstr = newSV_type(SVt_PVMG);
3148 t = (const char *)memchr(s, '\n', send - s);
3154 sv_setpvn(tmpstr, s, t - s);
3155 av_store(array, line++, tmpstr);
3163 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3165 0 is used as continue inside eval,
3167 3 is used for a die caught by an inner eval - continue inner loop
3169 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3170 establish a local jmpenv to handle exception traps.
3175 S_docatch(pTHX_ OP *o)
3179 OP * const oldop = PL_op;
3183 assert(CATCH_GET == TRUE);
3190 assert(cxstack_ix >= 0);
3191 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3192 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3197 /* die caught by an inner eval - continue inner loop */
3198 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3199 PL_restartjmpenv = NULL;
3200 PL_op = PL_restartop;
3209 assert(0); /* NOTREACHED */
3218 =for apidoc find_runcv
3220 Locate the CV corresponding to the currently executing sub or eval.
3221 If db_seqp is non_null, skip CVs that are in the DB package and populate
3222 *db_seqp with the cop sequence number at the point that the DB:: code was
3223 entered. (allows debuggers to eval in the scope of the breakpoint rather
3224 than in the scope of the debugger itself).
3230 Perl_find_runcv(pTHX_ U32 *db_seqp)
3232 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3235 /* If this becomes part of the API, it might need a better name. */
3237 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3244 *db_seqp = PL_curcop->cop_seq;
3245 for (si = PL_curstackinfo; si; si = si->si_prev) {
3247 for (ix = si->si_cxix; ix >= 0; ix--) {
3248 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3250 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3251 cv = cx->blk_sub.cv;
3252 /* skip DB:: code */
3253 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3254 *db_seqp = cx->blk_oldcop->cop_seq;
3258 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3259 cv = cx->blk_eval.cv;
3262 case FIND_RUNCV_padid_eq:
3264 || PadlistNAMES(CvPADLIST(cv)) != (PADNAMELIST *)arg)
3267 case FIND_RUNCV_level_eq:
3268 if (level++ != arg) continue;
3276 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3280 /* Run yyparse() in a setjmp wrapper. Returns:
3281 * 0: yyparse() successful
3282 * 1: yyparse() failed
3286 S_try_yyparse(pTHX_ int gramtype)
3291 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3295 ret = yyparse(gramtype) ? 1 : 0;
3302 assert(0); /* NOTREACHED */
3309 /* Compile a require/do or an eval ''.
3311 * outside is the lexically enclosing CV (if any) that invoked us.
3312 * seq is the current COP scope value.
3313 * hh is the saved hints hash, if any.
3315 * Returns a bool indicating whether the compile was successful; if so,
3316 * PL_eval_start contains the first op of the compiled code; otherwise,
3319 * This function is called from two places: pp_require and pp_entereval.
3320 * These can be distinguished by whether PL_op is entereval.
3324 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3327 OP * const saveop = PL_op;
3328 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3329 COP * const oldcurcop = PL_curcop;
3330 bool in_require = (saveop->op_type == OP_REQUIRE);
3334 PL_in_eval = (in_require
3335 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3340 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3342 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3343 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3344 cxstack[cxstack_ix].blk_gimme = gimme;
3346 CvOUTSIDE_SEQ(evalcv) = seq;
3347 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3349 /* set up a scratch pad */
3351 CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3352 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3356 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3358 /* make sure we compile in the right package */
3360 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3361 SAVEGENERICSV(PL_curstash);
3362 PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop));
3364 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3365 SAVESPTR(PL_beginav);
3366 PL_beginav = newAV();
3367 SAVEFREESV(PL_beginav);
3368 SAVESPTR(PL_unitcheckav);
3369 PL_unitcheckav = newAV();
3370 SAVEFREESV(PL_unitcheckav);
3373 SAVEBOOL(PL_madskills);
3377 ENTER_with_name("evalcomp");
3378 SAVESPTR(PL_compcv);
3381 /* try to compile it */
3383 PL_eval_root = NULL;
3384 PL_curcop = &PL_compiling;
3385 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3386 PL_in_eval |= EVAL_KEEPERR;
3393 hv_clear(GvHV(PL_hintgv));
3396 PL_hints = saveop->op_private & OPpEVAL_COPHH
3397 ? oldcurcop->cop_hints : saveop->op_targ;
3399 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3400 SvREFCNT_dec(GvHV(PL_hintgv));
3401 GvHV(PL_hintgv) = hh;
3404 SAVECOMPILEWARNINGS();
3406 if (PL_dowarn & G_WARN_ALL_ON)
3407 PL_compiling.cop_warnings = pWARN_ALL ;
3408 else if (PL_dowarn & G_WARN_ALL_OFF)
3409 PL_compiling.cop_warnings = pWARN_NONE ;
3411 PL_compiling.cop_warnings = pWARN_STD ;
3414 PL_compiling.cop_warnings =
3415 DUP_WARNINGS(oldcurcop->cop_warnings);
3416 cophh_free(CopHINTHASH_get(&PL_compiling));
3417 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3418 /* The label, if present, is the first entry on the chain. So rather
3419 than writing a blank label in front of it (which involves an
3420 allocation), just use the next entry in the chain. */
3421 PL_compiling.cop_hints_hash
3422 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3423 /* Check the assumption that this removed the label. */
3424 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3427 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3430 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3432 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3433 * so honour CATCH_GET and trap it here if necessary */
3435 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3437 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3438 SV **newsp; /* Used by POPBLOCK. */
3440 I32 optype; /* Used by POPEVAL. */
3445 PERL_UNUSED_VAR(newsp);
3446 PERL_UNUSED_VAR(optype);
3448 /* note that if yystatus == 3, then the EVAL CX block has already
3449 * been popped, and various vars restored */
3451 if (yystatus != 3) {
3453 op_free(PL_eval_root);
3454 PL_eval_root = NULL;
3456 SP = PL_stack_base + POPMARK; /* pop original mark */
3457 POPBLOCK(cx,PL_curpm);
3459 namesv = cx->blk_eval.old_namesv;
3460 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3461 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3466 /* If cx is still NULL, it means that we didn't go in the
3467 * POPEVAL branch. */
3468 cx = &cxstack[cxstack_ix];
3469 assert(CxTYPE(cx) == CXt_EVAL);
3470 namesv = cx->blk_eval.old_namesv;
3472 (void)hv_store(GvHVn(PL_incgv),
3473 SvPVX_const(namesv),
3474 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3476 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3479 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3482 if (!*(SvPVx_nolen_const(ERRSV))) {
3483 sv_setpvs(ERRSV, "Compilation error");
3486 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3491 LEAVE_with_name("evalcomp");
3493 CopLINE_set(&PL_compiling, 0);
3494 SAVEFREEOP(PL_eval_root);
3495 cv_forget_slab(evalcv);
3497 DEBUG_x(dump_eval());
3499 /* Register with debugger: */
3500 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3501 CV * const cv = get_cvs("DB::postponed", 0);
3505 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3507 call_sv(MUTABLE_SV(cv), G_DISCARD);
3511 if (PL_unitcheckav) {
3512 OP *es = PL_eval_start;
3513 call_list(PL_scopestack_ix, PL_unitcheckav);
3517 /* compiled okay, so do it */
3519 CvDEPTH(evalcv) = 1;
3520 SP = PL_stack_base + POPMARK; /* pop original mark */
3521 PL_op = saveop; /* The caller may need it. */
3522 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3529 S_check_type_and_open(pTHX_ SV *name)
3532 const char *p = SvPV_nolen_const(name);
3533 const int st_rc = PerlLIO_stat(p, &st);
3535 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3537 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3541 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3542 return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3544 return PerlIO_open(p, PERL_SCRIPT_MODE);
3548 #ifndef PERL_DISABLE_PMC
3550 S_doopen_pm(pTHX_ SV *name)
3553 const char *p = SvPV_const(name, namelen);
3555 PERL_ARGS_ASSERT_DOOPEN_PM;
3557 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3558 SV *const pmcsv = sv_newmortal();
3561 SvSetSV_nosteal(pmcsv,name);
3562 sv_catpvn(pmcsv, "c", 1);
3564 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3565 return check_type_and_open(pmcsv);
3567 return check_type_and_open(name);
3570 # define doopen_pm(name) check_type_and_open(name)
3571 #endif /* !PERL_DISABLE_PMC */
3583 int vms_unixname = 0;
3588 const char *tryname = NULL;
3590 const I32 gimme = GIMME_V;
3591 int filter_has_file = 0;
3592 PerlIO *tryrsfp = NULL;
3593 SV *filter_cache = NULL;
3594 SV *filter_state = NULL;
3595 SV *filter_sub = NULL;
3602 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3603 sv = sv_2mortal(new_version(sv));
3604 if (!sv_derived_from(PL_patchlevel, "version"))
3605 upg_version(PL_patchlevel, TRUE);
3606 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3607 if ( vcmp(sv,PL_patchlevel) <= 0 )
3608 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3609 SVfARG(sv_2mortal(vnormal(sv))),
3610 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3614 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3617 SV * const req = SvRV(sv);
3618 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3620 /* get the left hand term */
3621 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3623 first = SvIV(*av_fetch(lav,0,0));
3624 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3625 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3626 || av_len(lav) > 1 /* FP with > 3 digits */
3627 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3629 DIE(aTHX_ "Perl %"SVf" required--this is only "
3631 SVfARG(sv_2mortal(vnormal(req))),
3632 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3635 else { /* probably 'use 5.10' or 'use 5.8' */
3640 second = SvIV(*av_fetch(lav,1,0));
3642 second /= second >= 600 ? 100 : 10;
3643 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3644 (int)first, (int)second);
3645 upg_version(hintsv, TRUE);
3647 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3648 "--this is only %"SVf", stopped",
3649 SVfARG(sv_2mortal(vnormal(req))),
3650 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3651 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3659 name = SvPV_const(sv, len);
3660 if (!(name && len > 0 && *name))
3661 DIE(aTHX_ "Null filename used");
3662 TAINT_PROPER("require");
3666 /* The key in the %ENV hash is in the syntax of file passed as the argument
3667 * usually this is in UNIX format, but sometimes in VMS format, which
3668 * can result in a module being pulled in more than once.
3669 * To prevent this, the key must be stored in UNIX format if the VMS
3670 * name can be translated to UNIX.
3673 if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))
3674 && (unixname = tounixspec(name, unixnamebuf)) != NULL) {
3675 unixlen = strlen(unixname);
3681 /* if not VMS or VMS name can not be translated to UNIX, pass it
3684 unixname = (char *) name;
3687 if (PL_op->op_type == OP_REQUIRE) {
3688 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3689 unixname, unixlen, 0);
3691 if (*svp != &PL_sv_undef)
3694 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3695 "Compilation failed in require", unixname);
3699 LOADING_FILE_PROBE(unixname);
3701 /* prepare to compile file */
3703 if (path_is_absolute(name)) {
3704 /* At this point, name is SvPVX(sv) */
3706 tryrsfp = doopen_pm(sv);
3708 if (!tryrsfp && !(errno == EACCES && path_is_absolute(name))) {
3709 AV * const ar = GvAVn(PL_incgv);
3715 namesv = newSV_type(SVt_PV);
3716 for (i = 0; i <= AvFILL(ar); i++) {
3717 SV * const dirsv = *av_fetch(ar, i, TRUE);
3719 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3726 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3727 && !sv_isobject(loader))
3729 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3732 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3733 PTR2UV(SvRV(dirsv)), name);
3734 tryname = SvPVX_const(namesv);
3737 ENTER_with_name("call_INC");
3745 if (sv_isobject(loader))
3746 count = call_method("INC", G_ARRAY);
3748 count = call_sv(loader, G_ARRAY);
3758 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3759 && !isGV_with_GP(SvRV(arg))) {
3760 filter_cache = SvRV(arg);
3761 SvREFCNT_inc_simple_void_NN(filter_cache);
3768 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3772 if (isGV_with_GP(arg)) {
3773 IO * const io = GvIO((const GV *)arg);
3778 tryrsfp = IoIFP(io);
3779 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3780 PerlIO_close(IoOFP(io));
3791 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3793 SvREFCNT_inc_simple_void_NN(filter_sub);
3796 filter_state = SP[i];
3797 SvREFCNT_inc_simple_void(filter_state);
3801 if (!tryrsfp && (filter_cache || filter_sub)) {
3802 tryrsfp = PerlIO_open(BIT_BUCKET,
3810 LEAVE_with_name("call_INC");
3812 /* Adjust file name if the hook has set an %INC entry.
3813 This needs to happen after the FREETMPS above. */
3814 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3816 tryname = SvPV_nolen_const(*svp);
3823 filter_has_file = 0;
3825 SvREFCNT_dec(filter_cache);
3826 filter_cache = NULL;
3829 SvREFCNT_dec(filter_state);
3830 filter_state = NULL;
3833 SvREFCNT_dec(filter_sub);
3838 if (!path_is_absolute(name)
3844 dir = SvPV_const(dirsv, dirlen);
3851 if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL)
3852 || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL))
3854 sv_setpv(namesv, unixdir);
3855 sv_catpv(namesv, unixname);
3857 # ifdef __SYMBIAN32__
3858 if (PL_origfilename[0] &&
3859 PL_origfilename[1] == ':' &&
3860 !(dir[0] && dir[1] == ':'))
3861 Perl_sv_setpvf(aTHX_ namesv,
3866 Perl_sv_setpvf(aTHX_ namesv,
3870 /* The equivalent of
3871 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3872 but without the need to parse the format string, or
3873 call strlen on either pointer, and with the correct
3874 allocation up front. */
3876 char *tmp = SvGROW(namesv, dirlen + len + 2);
3878 memcpy(tmp, dir, dirlen);
3881 /* name came from an SV, so it will have a '\0' at the
3882 end that we can copy as part of this memcpy(). */
3883 memcpy(tmp, name, len + 1);
3885 SvCUR_set(namesv, dirlen + len + 1);
3890 TAINT_PROPER("require");
3891 tryname = SvPVX_const(namesv);
3892 tryrsfp = doopen_pm(namesv);
3894 if (tryname[0] == '.' && tryname[1] == '/') {
3896 while (*++tryname == '/');
3900 else if (errno == EMFILE || errno == EACCES) {
3901 /* no point in trying other paths if out of handles;
3902 * on the other hand, if we couldn't open one of the
3903 * files, then going on with the search could lead to
3904 * unexpected results; see perl #113422
3913 saved_errno = errno; /* sv_2mortal can realloc things */
3916 if (PL_op->op_type == OP_REQUIRE) {
3917 if(saved_errno == EMFILE || saved_errno == EACCES) {
3918 /* diag_listed_as: Can't locate %s */
3919 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno));
3921 if (namesv) { /* did we lookup @INC? */
3922 AV * const ar = GvAVn(PL_incgv);
3924 SV *const msg = newSVpvs_flags("", SVs_TEMP);
3925 SV *const inc = newSVpvs_flags("", SVs_TEMP);
3926 for (i = 0; i <= AvFILL(ar); i++) {
3927 sv_catpvs(inc, " ");
3928 sv_catsv(inc, *av_fetch(ar, i, TRUE));
3930 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
3931 const char *c, *e = name + len - 3;
3932 sv_catpv(msg, " (you may need to install the ");
3933 for (c = name; c < e; c++) {
3935 sv_catpvn(msg, "::", 2);
3938 sv_catpvn(msg, c, 1);
3941 sv_catpv(msg, " module)");
3943 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
3944 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
3946 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
3947 sv_catpv(msg, " (did you run h2ph?)");
3950 /* diag_listed_as: Can't locate %s */
3952 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
3956 DIE(aTHX_ "Can't locate %s", name);
3963 SETERRNO(0, SS_NORMAL);
3965 /* Assume success here to prevent recursive requirement. */
3966 /* name is never assigned to again, so len is still strlen(name) */
3967 /* Check whether a hook in @INC has already filled %INC */
3969 (void)hv_store(GvHVn(PL_incgv),
3970 unixname, unixlen, newSVpv(tryname,0),0);
3972 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3974 (void)hv_store(GvHVn(PL_incgv),
3975 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3978 ENTER_with_name("eval");
3980 SAVECOPFILE_FREE(&PL_compiling);
3981 CopFILE_set(&PL_compiling, tryname);
3982 lex_start(NULL, tryrsfp, 0);
3984 if (filter_sub || filter_cache) {
3985 /* We can use the SvPV of the filter PVIO itself as our cache, rather
3986 than hanging another SV from it. In turn, filter_add() optionally
3987 takes the SV to use as the filter (or creates a new SV if passed
3988 NULL), so simply pass in whatever value filter_cache has. */
3989 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3990 IoLINES(datasv) = filter_has_file;
3991 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3992 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3995 /* switch to eval mode */
3996 PUSHBLOCK(cx, CXt_EVAL, SP);
3998 cx->blk_eval.retop = PL_op->op_next;
4000 SAVECOPLINE(&PL_compiling);
4001 CopLINE_set(&PL_compiling, 0);
4005 /* Store and reset encoding. */
4006 encoding = PL_encoding;
4009 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4010 op = DOCATCH(PL_eval_start);
4012 op = PL_op->op_next;
4014 /* Restore encoding. */
4015 PL_encoding = encoding;
4017 LOADED_FILE_PROBE(unixname);
4022 /* This is a op added to hold the hints hash for
4023 pp_entereval. The hash can be modified by the code
4024 being eval'ed, so we return a copy instead. */
4030 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4040 const I32 gimme = GIMME_V;
4041 const U32 was = PL_breakable_sub_gen;
4042 char tbuf[TYPE_DIGITS(long) + 12];
4043 bool saved_delete = FALSE;
4044 char *tmpbuf = tbuf;
4047 U32 seq, lex_flags = 0;
4048 HV *saved_hh = NULL;
4049 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4051 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4052 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4054 else if (PL_hints & HINT_LOCALIZE_HH || (
4055 PL_op->op_private & OPpEVAL_COPHH
4056 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4058 saved_hh = cop_hints_2hv(PL_curcop, 0);
4059 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4063 /* make sure we've got a plain PV (no overload etc) before testing
4064 * for taint. Making a copy here is probably overkill, but better
4065 * safe than sorry */
4067 const char * const p = SvPV_const(sv, len);
4069 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4070 lex_flags |= LEX_START_COPIED;
4072 if (bytes && SvUTF8(sv))
4073 SvPVbyte_force(sv, len);
4075 else if (bytes && SvUTF8(sv)) {
4076 /* Don't modify someone else's scalar */
4079 (void)sv_2mortal(sv);
4080 SvPVbyte_force(sv,len);
4081 lex_flags |= LEX_START_COPIED;
4084 TAINT_IF(SvTAINTED(sv));
4085 TAINT_PROPER("eval");
4087 ENTER_with_name("eval");
4088 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4089 ? LEX_IGNORE_UTF8_HINTS
4090 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4095 /* switch to eval mode */
4097 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4098 SV * const temp_sv = sv_newmortal();
4099 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4100 (unsigned long)++PL_evalseq,
4101 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4102 tmpbuf = SvPVX(temp_sv);
4103 len = SvCUR(temp_sv);
4106 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4107 SAVECOPFILE_FREE(&PL_compiling);
4108 CopFILE_set(&PL_compiling, tmpbuf+2);
4109 SAVECOPLINE(&PL_compiling);
4110 CopLINE_set(&PL_compiling, 1);
4111 /* special case: an eval '' executed within the DB package gets lexically
4112 * placed in the first non-DB CV rather than the current CV - this
4113 * allows the debugger to execute code, find lexicals etc, in the
4114 * scope of the code being debugged. Passing &seq gets find_runcv
4115 * to do the dirty work for us */
4116 runcv = find_runcv(&seq);
4118 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4120 cx->blk_eval.retop = PL_op->op_next;
4122 /* prepare to compile string */
4124 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4125 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4127 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4128 deleting the eval's FILEGV from the stash before gv_check() runs
4129 (i.e. before run-time proper). To work around the coredump that
4130 ensues, we always turn GvMULTI_on for any globals that were
4131 introduced within evals. See force_ident(). GSAR 96-10-12 */
4132 char *const safestr = savepvn(tmpbuf, len);
4133 SAVEDELETE(PL_defstash, safestr, len);
4134 saved_delete = TRUE;
4139 if (doeval(gimme, runcv, seq, saved_hh)) {
4140 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4141 ? (PERLDB_LINE || PERLDB_SAVESRC)
4142 : PERLDB_SAVESRC_NOSUBS) {
4143 /* Retain the filegv we created. */
4144 } else if (!saved_delete) {
4145 char *const safestr = savepvn(tmpbuf, len);
4146 SAVEDELETE(PL_defstash, safestr, len);
4148 return DOCATCH(PL_eval_start);
4150 /* We have already left the scope set up earlier thanks to the LEAVE
4152 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4153 ? (PERLDB_LINE || PERLDB_SAVESRC)
4154 : PERLDB_SAVESRC_INVALID) {
4155 /* Retain the filegv we created. */
4156 } else if (!saved_delete) {
4157 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4159 return PL_op->op_next;
4171 const U8 save_flags = PL_op -> op_flags;
4179 namesv = cx->blk_eval.old_namesv;
4180 retop = cx->blk_eval.retop;
4181 evalcv = cx->blk_eval.cv;
4184 SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4186 PL_curpm = newpm; /* Don't pop $1 et al till now */
4189 assert(CvDEPTH(evalcv) == 1);
4191 CvDEPTH(evalcv) = 0;
4193 if (optype == OP_REQUIRE &&
4194 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4196 /* Unassume the success we assumed earlier. */
4197 (void)hv_delete(GvHVn(PL_incgv),
4198 SvPVX_const(namesv),
4199 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4201 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4203 /* die_unwind() did LEAVE, or we won't be here */
4206 LEAVE_with_name("eval");
4207 if (!(save_flags & OPf_SPECIAL)) {
4215 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4216 close to the related Perl_create_eval_scope. */
4218 Perl_delete_eval_scope(pTHX)
4229 LEAVE_with_name("eval_scope");
4230 PERL_UNUSED_VAR(newsp);
4231 PERL_UNUSED_VAR(gimme);
4232 PERL_UNUSED_VAR(optype);
4235 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4236 also needed by Perl_fold_constants. */
4238 Perl_create_eval_scope(pTHX_ U32 flags)
4241 const I32 gimme = GIMME_V;
4243 ENTER_with_name("eval_scope");
4246 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4249 PL_in_eval = EVAL_INEVAL;
4250 if (flags & G_KEEPERR)
4251 PL_in_eval |= EVAL_KEEPERR;
4254 if (flags & G_FAKINGEVAL) {
4255 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4263 PERL_CONTEXT * const cx = create_eval_scope(0);
4264 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4265 return DOCATCH(PL_op->op_next);
4280 PERL_UNUSED_VAR(optype);
4283 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4284 PL_curpm = newpm; /* Don't pop $1 et al till now */
4286 LEAVE_with_name("eval_scope");
4295 const I32 gimme = GIMME_V;
4297 ENTER_with_name("given");
4300 if (PL_op->op_targ) {
4301 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4302 SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4303 PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4310 PUSHBLOCK(cx, CXt_GIVEN, SP);
4323 PERL_UNUSED_CONTEXT;
4326 assert(CxTYPE(cx) == CXt_GIVEN);
4329 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4330 PL_curpm = newpm; /* Don't pop $1 et al till now */
4332 LEAVE_with_name("given");
4336 /* Helper routines used by pp_smartmatch */
4338 S_make_matcher(pTHX_ REGEXP *re)
4341 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4343 PERL_ARGS_ASSERT_MAKE_MATCHER;
4345 PM_SETRE(matcher, ReREFCNT_inc(re));
4347 SAVEFREEOP((OP *) matcher);
4348 ENTER_with_name("matcher"); SAVETMPS;
4354 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4359 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4361 PL_op = (OP *) matcher;
4364 (void) Perl_pp_match(aTHX);
4366 return (SvTRUEx(POPs));
4370 S_destroy_matcher(pTHX_ PMOP *matcher)
4374 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4375 PERL_UNUSED_ARG(matcher);
4378 LEAVE_with_name("matcher");
4381 /* Do a smart match */
4384 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4385 return do_smartmatch(NULL, NULL, 0);
4388 /* This version of do_smartmatch() implements the
4389 * table of smart matches that is found in perlsyn.
4392 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4397 bool object_on_left = FALSE;
4398 SV *e = TOPs; /* e is for 'expression' */
4399 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4401 /* Take care only to invoke mg_get() once for each argument.
4402 * Currently we do this by copying the SV if it's magical. */
4404 if (!copied && SvGMAGICAL(d))
4405 d = sv_mortalcopy(d);
4412 e = sv_mortalcopy(e);
4414 /* First of all, handle overload magic of the rightmost argument */
4417 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4418 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4420 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4427 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4430 SP -= 2; /* Pop the values */
4435 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4442 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4443 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4444 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4446 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4447 object_on_left = TRUE;
4450 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4452 if (object_on_left) {
4453 goto sm_any_sub; /* Treat objects like scalars */
4455 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4456 /* Test sub truth for each key */
4458 bool andedresults = TRUE;
4459 HV *hv = (HV*) SvRV(d);
4460 I32 numkeys = hv_iterinit(hv);
4461 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4464 while ( (he = hv_iternext(hv)) ) {
4465 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4466 ENTER_with_name("smartmatch_hash_key_test");
4469 PUSHs(hv_iterkeysv(he));
4471 c = call_sv(e, G_SCALAR);
4474 andedresults = FALSE;
4476 andedresults = SvTRUEx(POPs) && andedresults;
4478 LEAVE_with_name("smartmatch_hash_key_test");
4485 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4486 /* Test sub truth for each element */
4488 bool andedresults = TRUE;
4489 AV *av = (AV*) SvRV(d);
4490 const I32 len = av_len(av);
4491 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4494 for (i = 0; i <= len; ++i) {
4495 SV * const * const svp = av_fetch(av, i, FALSE);
4496 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4497 ENTER_with_name("smartmatch_array_elem_test");
4503 c = call_sv(e, G_SCALAR);
4506 andedresults = FALSE;
4508 andedresults = SvTRUEx(POPs) && andedresults;
4510 LEAVE_with_name("smartmatch_array_elem_test");
4519 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4520 ENTER_with_name("smartmatch_coderef");
4525 c = call_sv(e, G_SCALAR);
4529 else if (SvTEMP(TOPs))
4530 SvREFCNT_inc_void(TOPs);
4532 LEAVE_with_name("smartmatch_coderef");
4537 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4538 if (object_on_left) {
4539 goto sm_any_hash; /* Treat objects like scalars */
4541 else if (!SvOK(d)) {
4542 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4545 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4546 /* Check that the key-sets are identical */
4548 HV *other_hv = MUTABLE_HV(SvRV(d));
4550 bool other_tied = FALSE;
4551 U32 this_key_count = 0,
4552 other_key_count = 0;
4553 HV *hv = MUTABLE_HV(SvRV(e));
4555 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4556 /* Tied hashes don't know how many keys they have. */
4557 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4560 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4561 HV * const temp = other_hv;
4566 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4569 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4572 /* The hashes have the same number of keys, so it suffices
4573 to check that one is a subset of the other. */
4574 (void) hv_iterinit(hv);
4575 while ( (he = hv_iternext(hv)) ) {
4576 SV *key = hv_iterkeysv(he);
4578 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4581 if(!hv_exists_ent(other_hv, key, 0)) {
4582 (void) hv_iterinit(hv); /* reset iterator */
4588 (void) hv_iterinit(other_hv);
4589 while ( hv_iternext(other_hv) )
4593 other_key_count = HvUSEDKEYS(other_hv);
4595 if (this_key_count != other_key_count)
4600 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4601 AV * const other_av = MUTABLE_AV(SvRV(d));
4602 const I32 other_len = av_len(other_av) + 1;
4604 HV *hv = MUTABLE_HV(SvRV(e));
4606 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4607 for (i = 0; i < other_len; ++i) {
4608 SV ** const svp = av_fetch(other_av, i, FALSE);
4609 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4610 if (svp) { /* ??? When can this not happen? */
4611 if (hv_exists_ent(hv, *svp, 0))
4617 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4618 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4621 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4623 HV *hv = MUTABLE_HV(SvRV(e));
4625 (void) hv_iterinit(hv);
4626 while ( (he = hv_iternext(hv)) ) {
4627 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4628 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4629 (void) hv_iterinit(hv);
4630 destroy_matcher(matcher);
4634 destroy_matcher(matcher);
4640 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4641 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4648 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4649 if (object_on_left) {
4650 goto sm_any_array; /* Treat objects like scalars */
4652 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4653 AV * const other_av = MUTABLE_AV(SvRV(e));
4654 const I32 other_len = av_len(other_av) + 1;
4657 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4658 for (i = 0; i < other_len; ++i) {
4659 SV ** const svp = av_fetch(other_av, i, FALSE);
4661 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4662 if (svp) { /* ??? When can this not happen? */
4663 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4669 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4670 AV *other_av = MUTABLE_AV(SvRV(d));
4671 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4672 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4676 const I32 other_len = av_len(other_av);
4678 if (NULL == seen_this) {
4679 seen_this = newHV();
4680 (void) sv_2mortal(MUTABLE_SV(seen_this));
4682 if (NULL == seen_other) {
4683 seen_other = newHV();
4684 (void) sv_2mortal(MUTABLE_SV(seen_other));
4686 for(i = 0; i <= other_len; ++i) {
4687 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4688 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4690 if (!this_elem || !other_elem) {
4691 if ((this_elem && SvOK(*this_elem))
4692 || (other_elem && SvOK(*other_elem)))
4695 else if (hv_exists_ent(seen_this,
4696 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4697 hv_exists_ent(seen_other,
4698 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4700 if (*this_elem != *other_elem)
4704 (void)hv_store_ent(seen_this,
4705 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4707 (void)hv_store_ent(seen_other,
4708 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4714 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4715 (void) do_smartmatch(seen_this, seen_other, 0);
4717 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4726 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4727 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4730 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4731 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4734 for(i = 0; i <= this_len; ++i) {
4735 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4736 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4737 if (svp && matcher_matches_sv(matcher, *svp)) {
4738 destroy_matcher(matcher);
4742 destroy_matcher(matcher);
4746 else if (!SvOK(d)) {
4747 /* undef ~~ array */
4748 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4751 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4752 for (i = 0; i <= this_len; ++i) {
4753 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4754 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4755 if (!svp || !SvOK(*svp))
4764 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4766 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4767 for (i = 0; i <= this_len; ++i) {
4768 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4775 /* infinite recursion isn't supposed to happen here */
4776 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4777 (void) do_smartmatch(NULL, NULL, 1);
4779 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4788 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4789 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4790 SV *t = d; d = e; e = t;
4791 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4794 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4795 SV *t = d; d = e; e = t;
4796 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4797 goto sm_regex_array;
4800 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4802 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4804 PUSHs(matcher_matches_sv(matcher, d)
4807 destroy_matcher(matcher);
4812 /* See if there is overload magic on left */
4813 else if (object_on_left && SvAMAGIC(d)) {
4815 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4816 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4819 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4827 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4830 else if (!SvOK(d)) {
4831 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4832 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4837 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4838 DEBUG_M(if (SvNIOK(e))
4839 Perl_deb(aTHX_ " applying rule Any-Num\n");
4841 Perl_deb(aTHX_ " applying rule Num-numish\n");
4843 /* numeric comparison */
4846 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4847 (void) Perl_pp_i_eq(aTHX);
4849 (void) Perl_pp_eq(aTHX);
4857 /* As a last resort, use string comparison */
4858 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4861 return Perl_pp_seq(aTHX);
4868 const I32 gimme = GIMME_V;
4870 /* This is essentially an optimization: if the match
4871 fails, we don't want to push a context and then
4872 pop it again right away, so we skip straight
4873 to the op that follows the leavewhen.
4874 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4876 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4877 RETURNOP(cLOGOP->op_other->op_next);
4879 ENTER_with_name("when");
4882 PUSHBLOCK(cx, CXt_WHEN, SP);
4897 cxix = dopoptogiven(cxstack_ix);
4899 /* diag_listed_as: Can't "when" outside a topicalizer */
4900 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
4901 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
4904 assert(CxTYPE(cx) == CXt_WHEN);
4907 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4908 PL_curpm = newpm; /* pop $1 et al */
4910 LEAVE_with_name("when");
4912 if (cxix < cxstack_ix)
4915 cx = &cxstack[cxix];
4917 if (CxFOREACH(cx)) {
4918 /* clear off anything above the scope we're re-entering */
4919 I32 inner = PL_scopestack_ix;
4922 if (PL_scopestack_ix < inner)
4923 leave_scope(PL_scopestack[PL_scopestack_ix]);
4924 PL_curcop = cx->blk_oldcop;
4926 return cx->blk_loop.my_op->op_nextop;
4929 RETURNOP(cx->blk_givwhen.leave_op);
4941 PERL_UNUSED_VAR(gimme);
4943 cxix = dopoptowhen(cxstack_ix);
4945 DIE(aTHX_ "Can't \"continue\" outside a when block");
4947 if (cxix < cxstack_ix)
4951 assert(CxTYPE(cx) == CXt_WHEN);
4954 PL_curpm = newpm; /* pop $1 et al */
4956 LEAVE_with_name("when");
4957 RETURNOP(cx->blk_givwhen.leave_op->op_next);
4966 cxix = dopoptogiven(cxstack_ix);
4968 DIE(aTHX_ "Can't \"break\" outside a given block");
4970 cx = &cxstack[cxix];
4972 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4974 if (cxix < cxstack_ix)
4977 /* Restore the sp at the time we entered the given block */
4980 return cx->blk_givwhen.leave_op;
4984 S_doparseform(pTHX_ SV *sv)
4987 char *s = SvPV(sv, len);
4989 char *base = NULL; /* start of current field */
4990 I32 skipspaces = 0; /* number of contiguous spaces seen */
4991 bool noblank = FALSE; /* ~ or ~~ seen on this line */
4992 bool repeat = FALSE; /* ~~ seen on this line */
4993 bool postspace = FALSE; /* a text field may need right padding */
4996 U32 *linepc = NULL; /* position of last FF_LINEMARK */
4998 bool ischop; /* it's a ^ rather than a @ */
4999 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5000 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5004 PERL_ARGS_ASSERT_DOPARSEFORM;
5007 Perl_croak(aTHX_ "Null picture in formline");
5009 if (SvTYPE(sv) >= SVt_PVMG) {
5010 /* This might, of course, still return NULL. */
5011 mg = mg_find(sv, PERL_MAGIC_fm);
5013 sv_upgrade(sv, SVt_PVMG);
5017 /* still the same as previously-compiled string? */
5018 SV *old = mg->mg_obj;
5019 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5020 && len == SvCUR(old)
5021 && strnEQ(SvPVX(old), SvPVX(sv), len)
5023 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5027 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5028 Safefree(mg->mg_ptr);
5034 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5035 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5038 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5039 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5043 /* estimate the buffer size needed */
5044 for (base = s; s <= send; s++) {
5045 if (*s == '\n' || *s == '@' || *s == '^')
5051 Newx(fops, maxops, U32);
5056 *fpc++ = FF_LINEMARK;
5057 noblank = repeat = FALSE;
5075 case ' ': case '\t':
5082 } /* else FALL THROUGH */
5090 *fpc++ = FF_LITERAL;
5098 *fpc++ = (U32)skipspaces;
5102 *fpc++ = FF_NEWLINE;
5106 arg = fpc - linepc + 1;
5113 *fpc++ = FF_LINEMARK;
5114 noblank = repeat = FALSE;
5123 ischop = s[-1] == '^';
5129 arg = (s - base) - 1;
5131 *fpc++ = FF_LITERAL;
5137 if (*s == '*') { /* @* or ^* */
5139 *fpc++ = 2; /* skip the @* or ^* */
5141 *fpc++ = FF_LINESNGL;
5144 *fpc++ = FF_LINEGLOB;
5146 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5147 arg = ischop ? FORM_NUM_BLANK : 0;
5152 const char * const f = ++s;
5155 arg |= FORM_NUM_POINT + (s - f);
5157 *fpc++ = s - base; /* fieldsize for FETCH */
5158 *fpc++ = FF_DECIMAL;
5160 unchopnum |= ! ischop;
5162 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5163 arg = ischop ? FORM_NUM_BLANK : 0;
5165 s++; /* skip the '0' first */
5169 const char * const f = ++s;
5172 arg |= FORM_NUM_POINT + (s - f);
5174 *fpc++ = s - base; /* fieldsize for FETCH */
5175 *fpc++ = FF_0DECIMAL;
5177 unchopnum |= ! ischop;
5179 else { /* text field */
5181 bool ismore = FALSE;
5184 while (*++s == '>') ;
5185 prespace = FF_SPACE;
5187 else if (*s == '|') {
5188 while (*++s == '|') ;
5189 prespace = FF_HALFSPACE;
5194 while (*++s == '<') ;
5197 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5201 *fpc++ = s - base; /* fieldsize for FETCH */
5203 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5206 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5220 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5223 mg->mg_ptr = (char *) fops;
5224 mg->mg_len = arg * sizeof(U32);
5225 mg->mg_obj = sv_copy;
5226 mg->mg_flags |= MGf_REFCOUNTED;
5228 if (unchopnum && repeat)
5229 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5236 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5238 /* Can value be printed in fldsize chars, using %*.*f ? */
5242 int intsize = fldsize - (value < 0 ? 1 : 0);
5244 if (frcsize & FORM_NUM_POINT)
5246 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5249 while (intsize--) pwr *= 10.0;
5250 while (frcsize--) eps /= 10.0;
5253 if (value + eps >= pwr)
5256 if (value - eps <= -pwr)
5263 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5266 SV * const datasv = FILTER_DATA(idx);
5267 const int filter_has_file = IoLINES(datasv);
5268 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5269 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5274 char *prune_from = NULL;
5275 bool read_from_cache = FALSE;
5279 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5281 assert(maxlen >= 0);
5284 /* I was having segfault trouble under Linux 2.2.5 after a
5285 parse error occured. (Had to hack around it with a test
5286 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5287 not sure where the trouble is yet. XXX */
5290 SV *const cache = datasv;
5293 const char *cache_p = SvPV(cache, cache_len);
5297 /* Running in block mode and we have some cached data already.
5299 if (cache_len >= umaxlen) {
5300 /* In fact, so much data we don't even need to call
5305 const char *const first_nl =
5306 (const char *)memchr(cache_p, '\n', cache_len);
5308 take = first_nl + 1 - cache_p;
5312 sv_catpvn(buf_sv, cache_p, take);
5313 sv_chop(cache, cache_p + take);
5314 /* Definitely not EOF */
5318 sv_catsv(buf_sv, cache);
5320 umaxlen -= cache_len;
5323 read_from_cache = TRUE;
5327 /* Filter API says that the filter appends to the contents of the buffer.
5328 Usually the buffer is "", so the details don't matter. But if it's not,
5329 then clearly what it contains is already filtered by this filter, so we
5330 don't want to pass it in a second time.
5331 I'm going to use a mortal in case the upstream filter croaks. */
5332 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5333 ? sv_newmortal() : buf_sv;
5334 SvUPGRADE(upstream, SVt_PV);
5336 if (filter_has_file) {
5337 status = FILTER_READ(idx+1, upstream, 0);
5340 if (filter_sub && status >= 0) {
5344 ENTER_with_name("call_filter_sub");
5349 DEFSV_set(upstream);
5353 PUSHs(filter_state);
5356 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5364 else if (SvTRUE(ERRSV)) {
5365 err = newSVsv(ERRSV);
5371 LEAVE_with_name("call_filter_sub");
5374 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5375 if(!err && SvOK(upstream)) {
5376 got_p = SvPV(upstream, got_len);
5378 if (got_len > umaxlen) {
5379 prune_from = got_p + umaxlen;
5382 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5383 if (first_nl && first_nl + 1 < got_p + got_len) {
5384 /* There's a second line here... */
5385 prune_from = first_nl + 1;
5389 if (!err && prune_from) {
5390 /* Oh. Too long. Stuff some in our cache. */
5391 STRLEN cached_len = got_p + got_len - prune_from;
5392 SV *const cache = datasv;
5395 /* Cache should be empty. */
5396 assert(!SvCUR(cache));
5399 sv_setpvn(cache, prune_from, cached_len);
5400 /* If you ask for block mode, you may well split UTF-8 characters.
5401 "If it breaks, you get to keep both parts"
5402 (Your code is broken if you don't put them back together again
5403 before something notices.) */
5404 if (SvUTF8(upstream)) {
5407 SvCUR_set(upstream, got_len - cached_len);
5409 /* Can't yet be EOF */
5414 /* If they are at EOF but buf_sv has something in it, then they may never
5415 have touched the SV upstream, so it may be undefined. If we naively
5416 concatenate it then we get a warning about use of uninitialised value.
5418 if (!err && upstream != buf_sv &&
5419 (SvOK(upstream) || SvGMAGICAL(upstream))) {
5420 sv_catsv(buf_sv, upstream);
5424 IoLINES(datasv) = 0;
5426 SvREFCNT_dec(filter_state);
5427 IoTOP_GV(datasv) = NULL;
5430 SvREFCNT_dec(filter_sub);
5431 IoBOTTOM_GV(datasv) = NULL;
5433 filter_del(S_run_user_filter);
5439 if (status == 0 && read_from_cache) {
5440 /* If we read some data from the cache (and by getting here it implies
5441 that we emptied the cache) then we aren't yet at EOF, and mustn't
5442 report that to our caller. */
5448 /* perhaps someone can come up with a better name for
5449 this? it is not really "absolute", per se ... */
5451 S_path_is_absolute(const char *name)
5453 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5455 if (PERL_FILE_IS_ABSOLUTE(name)
5457 || (*name == '.' && ((name[1] == '/' ||
5458 (name[1] == '.' && name[2] == '/'))
5459 || (name[1] == '\\' ||
5460 ( name[1] == '.' && name[2] == '\\')))
5463 || (*name == '.' && (name[1] == '/' ||
5464 (name[1] == '.' && name[2] == '/')))
5476 * c-indentation-style: bsd
5478 * indent-tabs-mode: nil
5481 * ex: set ts=8 sts=4 sw=4 et: