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 register 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 ((struct regexp *)SvANY(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 = PL_tainted;
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 further down. */
142 PL_tainted = 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 (PL_tainting && PL_tainted) {
155 SvTAINTED_on((SV*)new_re);
156 RX_EXTFLAGS(new_re) |= RXf_TAINTED;
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 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
181 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
182 register SV * const dstr = cx->sb_dstr;
183 register char *s = cx->sb_s;
184 register char *m = cx->sb_m;
185 char *orig = cx->sb_orig;
186 register 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 ((cx->sb_rflags & REXEC_COPY_STR)
220 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
221 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
223 SV *targ = cx->sb_targ;
225 assert(cx->sb_strend >= s);
226 if(cx->sb_strend > s) {
227 if (DO_UTF8(dstr) && !SvUTF8(targ))
228 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
230 sv_catpvn(dstr, s, cx->sb_strend - s);
232 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
233 cx->sb_rxtainted |= SUBST_TAINT_PAT;
235 if (pm->op_pmflags & PMf_NONDESTRUCT) {
237 /* From here on down we're using the copy, and leaving the
238 original untouched. */
243 sv_force_normal_flags(targ, SV_COW_DROP_PV);
248 SvPV_set(targ, SvPVX(dstr));
249 SvCUR_set(targ, SvCUR(dstr));
250 SvLEN_set(targ, SvLEN(dstr));
253 SvPV_set(dstr, NULL);
255 mPUSHi(saviters - 1);
257 (void)SvPOK_only_UTF8(targ);
260 /* update the taint state of various various variables in
261 * preparation for final exit.
262 * See "how taint works" above pp_subst() */
264 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
265 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
266 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
268 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
270 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
271 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
273 SvTAINTED_on(TOPs); /* taint return value */
274 /* needed for mg_set below */
275 PL_tainted = cBOOL(cx->sb_rxtainted &
276 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
279 /* PL_tainted must be correctly set for this mg_set */
282 LEAVE_SCOPE(cx->sb_oldsave);
284 RETURNOP(pm->op_next);
285 assert(0); /* NOTREACHED */
287 cx->sb_iters = saviters;
289 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
292 cx->sb_orig = orig = RX_SUBBEG(rx);
294 cx->sb_strend = s + (cx->sb_strend - m);
296 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
298 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
299 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
301 sv_catpvn(dstr, s, m-s);
303 cx->sb_s = RX_OFFS(rx)[0].end + orig;
304 { /* Update the pos() information. */
306 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
308 SvUPGRADE(sv, SVt_PVMG);
309 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
310 #ifdef PERL_OLD_COPY_ON_WRITE
312 sv_force_normal_flags(sv, 0);
314 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
317 mg->mg_len = m - orig;
320 (void)ReREFCNT_inc(rx);
321 /* update the taint state of various various variables in preparation
322 * for calling the code block.
323 * See "how taint works" above pp_subst() */
325 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
326 cx->sb_rxtainted |= SUBST_TAINT_PAT;
328 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
329 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
330 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
332 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
334 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
335 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
336 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
337 ? cx->sb_dstr : cx->sb_targ);
340 rxres_save(&cx->sb_rxres, rx);
342 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
346 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
351 PERL_ARGS_ASSERT_RXRES_SAVE;
354 if (!p || p[1] < RX_NPARENS(rx)) {
355 #ifdef PERL_OLD_COPY_ON_WRITE
356 i = 7 + RX_NPARENS(rx) * 2;
358 i = 6 + RX_NPARENS(rx) * 2;
367 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
368 RX_MATCH_COPIED_off(rx);
370 #ifdef PERL_OLD_COPY_ON_WRITE
371 *p++ = PTR2UV(RX_SAVED_COPY(rx));
372 RX_SAVED_COPY(rx) = NULL;
375 *p++ = RX_NPARENS(rx);
377 *p++ = PTR2UV(RX_SUBBEG(rx));
378 *p++ = (UV)RX_SUBLEN(rx);
379 for (i = 0; i <= RX_NPARENS(rx); ++i) {
380 *p++ = (UV)RX_OFFS(rx)[i].start;
381 *p++ = (UV)RX_OFFS(rx)[i].end;
386 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
391 PERL_ARGS_ASSERT_RXRES_RESTORE;
394 RX_MATCH_COPY_FREE(rx);
395 RX_MATCH_COPIED_set(rx, *p);
398 #ifdef PERL_OLD_COPY_ON_WRITE
399 if (RX_SAVED_COPY(rx))
400 SvREFCNT_dec (RX_SAVED_COPY(rx));
401 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
405 RX_NPARENS(rx) = *p++;
407 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
408 RX_SUBLEN(rx) = (I32)(*p++);
409 for (i = 0; i <= RX_NPARENS(rx); ++i) {
410 RX_OFFS(rx)[i].start = (I32)(*p++);
411 RX_OFFS(rx)[i].end = (I32)(*p++);
416 S_rxres_free(pTHX_ void **rsp)
418 UV * const p = (UV*)*rsp;
420 PERL_ARGS_ASSERT_RXRES_FREE;
425 void *tmp = INT2PTR(char*,*p);
428 PoisonFree(*p, 1, sizeof(*p));
430 Safefree(INT2PTR(char*,*p));
432 #ifdef PERL_OLD_COPY_ON_WRITE
434 SvREFCNT_dec (INT2PTR(SV*,p[1]));
442 #define FORM_NUM_BLANK (1<<30)
443 #define FORM_NUM_POINT (1<<29)
447 dVAR; dSP; dMARK; dORIGMARK;
448 register SV * const tmpForm = *++MARK;
449 SV *formsv; /* contains text of original format */
450 register U32 *fpc; /* format ops program counter */
451 register char *t; /* current append position in target string */
452 const char *f; /* current position in format string */
454 register SV *sv = NULL; /* current item */
455 const char *item = NULL;/* string value of current item */
456 I32 itemsize = 0; /* length of current item, possibly truncated */
457 I32 fieldsize = 0; /* width of current field */
458 I32 lines = 0; /* number of lines that have been output */
459 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
460 const char *chophere = NULL; /* where to chop current item */
461 STRLEN linemark = 0; /* pos of start of line in output */
463 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
465 STRLEN linemax; /* estimate of output size in bytes */
466 bool item_is_utf8 = FALSE;
467 bool targ_is_utf8 = FALSE;
470 U8 *source; /* source of bytes to append */
471 STRLEN to_copy; /* how may bytes to append */
472 char trans; /* what chars to translate */
474 mg = doparseform(tmpForm);
476 fpc = (U32*)mg->mg_ptr;
477 /* the actual string the format was compiled from.
478 * with overload etc, this may not match tmpForm */
482 SvPV_force(PL_formtarget, len);
483 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
484 SvTAINTED_on(PL_formtarget);
485 if (DO_UTF8(PL_formtarget))
487 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
488 t = SvGROW(PL_formtarget, len + linemax + 1);
489 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
491 f = SvPV_const(formsv, len);
495 const char *name = "???";
498 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
499 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
500 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
501 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
502 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
504 case FF_CHECKNL: name = "CHECKNL"; break;
505 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
506 case FF_SPACE: name = "SPACE"; break;
507 case FF_HALFSPACE: name = "HALFSPACE"; break;
508 case FF_ITEM: name = "ITEM"; break;
509 case FF_CHOP: name = "CHOP"; break;
510 case FF_LINEGLOB: name = "LINEGLOB"; break;
511 case FF_NEWLINE: name = "NEWLINE"; break;
512 case FF_MORE: name = "MORE"; break;
513 case FF_LINEMARK: name = "LINEMARK"; break;
514 case FF_END: name = "END"; break;
515 case FF_0DECIMAL: name = "0DECIMAL"; break;
516 case FF_LINESNGL: name = "LINESNGL"; break;
519 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
521 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
525 linemark = t - SvPVX(PL_formtarget);
535 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
551 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
554 SvTAINTED_on(PL_formtarget);
560 const char *s = item = SvPV_const(sv, len);
563 itemsize = sv_len_utf8(sv);
564 if (itemsize != (I32)len) {
566 if (itemsize > fieldsize) {
567 itemsize = fieldsize;
568 itembytes = itemsize;
569 sv_pos_u2b(sv, &itembytes, 0);
573 send = chophere = s + itembytes;
583 sv_pos_b2u(sv, &itemsize);
587 item_is_utf8 = FALSE;
588 if (itemsize > fieldsize)
589 itemsize = fieldsize;
590 send = chophere = s + itemsize;
604 const char *s = item = SvPV_const(sv, len);
607 itemsize = sv_len_utf8(sv);
608 if (itemsize != (I32)len) {
610 if (itemsize <= fieldsize) {
611 const char *send = chophere = s + itemsize;
624 itemsize = fieldsize;
625 itembytes = itemsize;
626 sv_pos_u2b(sv, &itembytes, 0);
627 send = chophere = s + itembytes;
628 while (s < send || (s == send && isSPACE(*s))) {
638 if (strchr(PL_chopset, *s))
643 itemsize = chophere - item;
644 sv_pos_b2u(sv, &itemsize);
650 item_is_utf8 = FALSE;
651 if (itemsize <= fieldsize) {
652 const char *const send = chophere = s + itemsize;
665 itemsize = fieldsize;
666 send = chophere = s + itemsize;
667 while (s < send || (s == send && isSPACE(*s))) {
677 if (strchr(PL_chopset, *s))
682 itemsize = chophere - item;
688 arg = fieldsize - itemsize;
697 arg = fieldsize - itemsize;
711 /* convert to_copy from chars to bytes */
715 to_copy = s - source;
721 const char *s = chophere;
735 const bool oneline = fpc[-1] == FF_LINESNGL;
736 const char *s = item = SvPV_const(sv, len);
737 const char *const send = s + len;
739 item_is_utf8 = DO_UTF8(sv);
750 to_copy = s - SvPVX_const(sv) - 1;
764 /* append to_copy bytes from source to PL_formstring.
765 * item_is_utf8 implies source is utf8.
766 * if trans, translate certain characters during the copy */
771 SvCUR_set(PL_formtarget,
772 t - SvPVX_const(PL_formtarget));
774 if (targ_is_utf8 && !item_is_utf8) {
775 source = tmp = bytes_to_utf8(source, &to_copy);
777 if (item_is_utf8 && !targ_is_utf8) {
779 /* Upgrade targ to UTF8, and then we reduce it to
780 a problem we have a simple solution for.
781 Don't need get magic. */
782 sv_utf8_upgrade_nomg(PL_formtarget);
784 /* re-calculate linemark */
785 s = (U8*)SvPVX(PL_formtarget);
786 /* the bytes we initially allocated to append the
787 * whole line may have been gobbled up during the
788 * upgrade, so allocate a whole new line's worth
793 linemark = s - (U8*)SvPVX(PL_formtarget);
795 /* Easy. They agree. */
796 assert (item_is_utf8 == targ_is_utf8);
799 /* @* and ^* are the only things that can exceed
800 * the linemax, so grow by the output size, plus
801 * a whole new form's worth in case of any further
803 grow = linemax + to_copy;
805 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
806 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
808 Copy(source, t, to_copy, char);
810 /* blank out ~ or control chars, depending on trans.
811 * works on bytes not chars, so relies on not
812 * matching utf8 continuation bytes */
814 U8 *send = s + to_copy;
817 if (trans == '~' ? (ch == '~') :
830 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
838 #if defined(USE_LONG_DOUBLE)
840 ((arg & FORM_NUM_POINT) ?
841 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
844 ((arg & FORM_NUM_POINT) ?
845 "%#0*.*f" : "%0*.*f");
850 #if defined(USE_LONG_DOUBLE)
852 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
855 ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
858 /* If the field is marked with ^ and the value is undefined,
860 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
868 /* overflow evidence */
869 if (num_overflow(value, fieldsize, arg)) {
875 /* Formats aren't yet marked for locales, so assume "yes". */
877 STORE_NUMERIC_STANDARD_SET_LOCAL();
878 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
879 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
880 RESTORE_NUMERIC_STANDARD();
887 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
895 if (arg) { /* repeat until fields exhausted? */
901 t = SvPVX(PL_formtarget) + linemark;
908 const char *s = chophere;
909 const char *send = item + len;
911 while (isSPACE(*s) && (s < send))
916 arg = fieldsize - itemsize;
923 if (strnEQ(s1," ",3)) {
924 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
935 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
937 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
939 SvUTF8_on(PL_formtarget);
940 FmLINES(PL_formtarget) += lines;
942 if (fpc[-1] == FF_BLANK)
943 RETURNOP(cLISTOP->op_first);
955 if (PL_stack_base + *PL_markstack_ptr == SP) {
957 if (GIMME_V == G_SCALAR)
959 RETURNOP(PL_op->op_next->op_next);
961 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
962 Perl_pp_pushmark(aTHX); /* push dst */
963 Perl_pp_pushmark(aTHX); /* push src */
964 ENTER_with_name("grep"); /* enter outer scope */
967 if (PL_op->op_private & OPpGREP_LEX)
968 SAVESPTR(PAD_SVl(PL_op->op_targ));
971 ENTER_with_name("grep_item"); /* enter inner scope */
974 src = PL_stack_base[*PL_markstack_ptr];
976 if (PL_op->op_private & OPpGREP_LEX)
977 PAD_SVl(PL_op->op_targ) = src;
982 if (PL_op->op_type == OP_MAPSTART)
983 Perl_pp_pushmark(aTHX); /* push top */
984 return ((LOGOP*)PL_op->op_next)->op_other;
990 const I32 gimme = GIMME_V;
991 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
997 /* first, move source pointer to the next item in the source list */
998 ++PL_markstack_ptr[-1];
1000 /* if there are new items, push them into the destination list */
1001 if (items && gimme != G_VOID) {
1002 /* might need to make room back there first */
1003 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1004 /* XXX this implementation is very pessimal because the stack
1005 * is repeatedly extended for every set of items. Is possible
1006 * to do this without any stack extension or copying at all
1007 * by maintaining a separate list over which the map iterates
1008 * (like foreach does). --gsar */
1010 /* everything in the stack after the destination list moves
1011 * towards the end the stack by the amount of room needed */
1012 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1014 /* items to shift up (accounting for the moved source pointer) */
1015 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1017 /* This optimization is by Ben Tilly and it does
1018 * things differently from what Sarathy (gsar)
1019 * is describing. The downside of this optimization is
1020 * that leaves "holes" (uninitialized and hopefully unused areas)
1021 * to the Perl stack, but on the other hand this
1022 * shouldn't be a problem. If Sarathy's idea gets
1023 * implemented, this optimization should become
1024 * irrelevant. --jhi */
1026 shift = count; /* Avoid shifting too often --Ben Tilly */
1030 dst = (SP += shift);
1031 PL_markstack_ptr[-1] += shift;
1032 *PL_markstack_ptr += shift;
1036 /* copy the new items down to the destination list */
1037 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1038 if (gimme == G_ARRAY) {
1039 /* add returned items to the collection (making mortal copies
1040 * if necessary), then clear the current temps stack frame
1041 * *except* for those items. We do this splicing the items
1042 * into the start of the tmps frame (so some items may be on
1043 * the tmps stack twice), then moving PL_tmps_floor above
1044 * them, then freeing the frame. That way, the only tmps that
1045 * accumulate over iterations are the return values for map.
1046 * We have to do to this way so that everything gets correctly
1047 * freed if we die during the map.
1051 /* make space for the slice */
1052 EXTEND_MORTAL(items);
1053 tmpsbase = PL_tmps_floor + 1;
1054 Move(PL_tmps_stack + tmpsbase,
1055 PL_tmps_stack + tmpsbase + items,
1056 PL_tmps_ix - PL_tmps_floor,
1058 PL_tmps_ix += items;
1063 sv = sv_mortalcopy(sv);
1065 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1067 /* clear the stack frame except for the items */
1068 PL_tmps_floor += items;
1070 /* FREETMPS may have cleared the TEMP flag on some of the items */
1073 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1076 /* scalar context: we don't care about which values map returns
1077 * (we use undef here). And so we certainly don't want to do mortal
1078 * copies of meaningless values. */
1079 while (items-- > 0) {
1081 *dst-- = &PL_sv_undef;
1089 LEAVE_with_name("grep_item"); /* exit inner scope */
1092 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1094 (void)POPMARK; /* pop top */
1095 LEAVE_with_name("grep"); /* exit outer scope */
1096 (void)POPMARK; /* pop src */
1097 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1098 (void)POPMARK; /* pop dst */
1099 SP = PL_stack_base + POPMARK; /* pop original mark */
1100 if (gimme == G_SCALAR) {
1101 if (PL_op->op_private & OPpGREP_LEX) {
1102 SV* sv = sv_newmortal();
1103 sv_setiv(sv, items);
1111 else if (gimme == G_ARRAY)
1118 ENTER_with_name("grep_item"); /* enter inner scope */
1121 /* set $_ to the new source item */
1122 src = PL_stack_base[PL_markstack_ptr[-1]];
1124 if (PL_op->op_private & OPpGREP_LEX)
1125 PAD_SVl(PL_op->op_targ) = src;
1129 RETURNOP(cLOGOP->op_other);
1138 if (GIMME == G_ARRAY)
1140 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1141 return cLOGOP->op_other;
1151 if (GIMME == G_ARRAY) {
1152 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1156 SV * const targ = PAD_SV(PL_op->op_targ);
1159 if (PL_op->op_private & OPpFLIP_LINENUM) {
1160 if (GvIO(PL_last_in_gv)) {
1161 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1164 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1166 flip = SvIV(sv) == SvIV(GvSV(gv));
1172 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1173 if (PL_op->op_flags & OPf_SPECIAL) {
1181 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1184 sv_setpvs(TARG, "");
1190 /* This code tries to decide if "$left .. $right" should use the
1191 magical string increment, or if the range is numeric (we make
1192 an exception for .."0" [#18165]). AMS 20021031. */
1194 #define RANGE_IS_NUMERIC(left,right) ( \
1195 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1196 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1197 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1198 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1199 && (!SvOK(right) || looks_like_number(right))))
1205 if (GIMME == G_ARRAY) {
1211 if (RANGE_IS_NUMERIC(left,right)) {
1214 if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) ||
1215 (SvOK(right) && SvNV_nomg(right) > IV_MAX))
1216 DIE(aTHX_ "Range iterator outside integer range");
1217 i = SvIV_nomg(left);
1218 max = SvIV_nomg(right);
1227 SV * const sv = sv_2mortal(newSViv(i++));
1233 const char * const lpv = SvPV_nomg_const(left, llen);
1234 const char * const tmps = SvPV_nomg_const(right, len);
1236 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1237 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1239 if (strEQ(SvPVX_const(sv),tmps))
1241 sv = sv_2mortal(newSVsv(sv));
1248 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1252 if (PL_op->op_private & OPpFLIP_LINENUM) {
1253 if (GvIO(PL_last_in_gv)) {
1254 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1257 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1258 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1266 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1267 sv_catpvs(targ, "E0");
1277 static const char * const context_name[] = {
1279 NULL, /* CXt_WHEN never actually needs "block" */
1280 NULL, /* CXt_BLOCK never actually needs "block" */
1281 NULL, /* CXt_GIVEN never actually needs "block" */
1282 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1283 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1284 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1285 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1293 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1298 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1300 for (i = cxstack_ix; i >= 0; i--) {
1301 register const PERL_CONTEXT * const cx = &cxstack[i];
1302 switch (CxTYPE(cx)) {
1308 /* diag_listed_as: Exiting subroutine via %s */
1309 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1310 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1311 if (CxTYPE(cx) == CXt_NULL)
1314 case CXt_LOOP_LAZYIV:
1315 case CXt_LOOP_LAZYSV:
1317 case CXt_LOOP_PLAIN:
1319 STRLEN cx_label_len = 0;
1320 U32 cx_label_flags = 0;
1321 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1323 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1326 (const U8*)cx_label, cx_label_len,
1327 (const U8*)label, len) == 0)
1329 (const U8*)label, len,
1330 (const U8*)cx_label, cx_label_len) == 0)
1331 : (len == cx_label_len && ((cx_label == label)
1332 || memEQ(cx_label, label, len))) )) {
1333 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1334 (long)i, cx_label));
1337 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1348 Perl_dowantarray(pTHX)
1351 const I32 gimme = block_gimme();
1352 return (gimme == G_VOID) ? G_SCALAR : gimme;
1356 Perl_block_gimme(pTHX)
1359 const I32 cxix = dopoptosub(cxstack_ix);
1363 switch (cxstack[cxix].blk_gimme) {
1371 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1372 assert(0); /* NOTREACHED */
1378 Perl_is_lvalue_sub(pTHX)
1381 const I32 cxix = dopoptosub(cxstack_ix);
1382 assert(cxix >= 0); /* We should only be called from inside subs */
1384 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1385 return CxLVAL(cxstack + cxix);
1390 /* only used by PUSHSUB */
1392 Perl_was_lvalue_sub(pTHX)
1395 const I32 cxix = dopoptosub(cxstack_ix-1);
1396 assert(cxix >= 0); /* We should only be called from inside subs */
1398 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1399 return CxLVAL(cxstack + cxix);
1405 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1410 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1412 for (i = startingblock; i >= 0; i--) {
1413 register const PERL_CONTEXT * const cx = &cxstk[i];
1414 switch (CxTYPE(cx)) {
1420 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1428 S_dopoptoeval(pTHX_ I32 startingblock)
1432 for (i = startingblock; i >= 0; i--) {
1433 register const PERL_CONTEXT *cx = &cxstack[i];
1434 switch (CxTYPE(cx)) {
1438 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1446 S_dopoptoloop(pTHX_ I32 startingblock)
1450 for (i = startingblock; i >= 0; i--) {
1451 register const PERL_CONTEXT * const cx = &cxstack[i];
1452 switch (CxTYPE(cx)) {
1458 /* diag_listed_as: Exiting subroutine via %s */
1459 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1460 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1461 if ((CxTYPE(cx)) == CXt_NULL)
1464 case CXt_LOOP_LAZYIV:
1465 case CXt_LOOP_LAZYSV:
1467 case CXt_LOOP_PLAIN:
1468 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1476 S_dopoptogiven(pTHX_ I32 startingblock)
1480 for (i = startingblock; i >= 0; i--) {
1481 register const PERL_CONTEXT *cx = &cxstack[i];
1482 switch (CxTYPE(cx)) {
1486 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1488 case CXt_LOOP_PLAIN:
1489 assert(!CxFOREACHDEF(cx));
1491 case CXt_LOOP_LAZYIV:
1492 case CXt_LOOP_LAZYSV:
1494 if (CxFOREACHDEF(cx)) {
1495 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1504 S_dopoptowhen(pTHX_ I32 startingblock)
1508 for (i = startingblock; i >= 0; i--) {
1509 register const PERL_CONTEXT *cx = &cxstack[i];
1510 switch (CxTYPE(cx)) {
1514 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1522 Perl_dounwind(pTHX_ I32 cxix)
1527 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1530 while (cxstack_ix > cxix) {
1532 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1533 DEBUG_CX("UNWIND"); \
1534 /* Note: we don't need to restore the base context info till the end. */
1535 switch (CxTYPE(cx)) {
1538 continue; /* not break */
1546 case CXt_LOOP_LAZYIV:
1547 case CXt_LOOP_LAZYSV:
1549 case CXt_LOOP_PLAIN:
1560 PERL_UNUSED_VAR(optype);
1564 Perl_qerror(pTHX_ SV *err)
1568 PERL_ARGS_ASSERT_QERROR;
1571 if (PL_in_eval & EVAL_KEEPERR) {
1572 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1576 sv_catsv(ERRSV, err);
1579 sv_catsv(PL_errors, err);
1581 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1583 ++PL_parser->error_count;
1587 Perl_die_unwind(pTHX_ SV *msv)
1590 SV *exceptsv = sv_mortalcopy(msv);
1591 U8 in_eval = PL_in_eval;
1592 PERL_ARGS_ASSERT_DIE_UNWIND;
1599 * Historically, perl used to set ERRSV ($@) early in the die
1600 * process and rely on it not getting clobbered during unwinding.
1601 * That sucked, because it was liable to get clobbered, so the
1602 * setting of ERRSV used to emit the exception from eval{} has
1603 * been moved to much later, after unwinding (see just before
1604 * JMPENV_JUMP below). However, some modules were relying on the
1605 * early setting, by examining $@ during unwinding to use it as
1606 * a flag indicating whether the current unwinding was caused by
1607 * an exception. It was never a reliable flag for that purpose,
1608 * being totally open to false positives even without actual
1609 * clobberage, but was useful enough for production code to
1610 * semantically rely on it.
1612 * We'd like to have a proper introspective interface that
1613 * explicitly describes the reason for whatever unwinding
1614 * operations are currently in progress, so that those modules
1615 * work reliably and $@ isn't further overloaded. But we don't
1616 * have one yet. In its absence, as a stopgap measure, ERRSV is
1617 * now *additionally* set here, before unwinding, to serve as the
1618 * (unreliable) flag that it used to.
1620 * This behaviour is temporary, and should be removed when a
1621 * proper way to detect exceptional unwinding has been developed.
1622 * As of 2010-12, the authors of modules relying on the hack
1623 * are aware of the issue, because the modules failed on
1624 * perls 5.13.{1..7} which had late setting of $@ without this
1625 * early-setting hack.
1627 if (!(in_eval & EVAL_KEEPERR)) {
1628 SvTEMP_off(exceptsv);
1629 sv_setsv(ERRSV, exceptsv);
1632 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1633 && PL_curstackinfo->si_prev)
1642 register PERL_CONTEXT *cx;
1645 JMPENV *restartjmpenv;
1648 if (cxix < cxstack_ix)
1651 POPBLOCK(cx,PL_curpm);
1652 if (CxTYPE(cx) != CXt_EVAL) {
1654 const char* message = SvPVx_const(exceptsv, msglen);
1655 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1656 PerlIO_write(Perl_error_log, message, msglen);
1660 namesv = cx->blk_eval.old_namesv;
1661 oldcop = cx->blk_oldcop;
1662 restartjmpenv = cx->blk_eval.cur_top_env;
1663 restartop = cx->blk_eval.retop;
1665 if (gimme == G_SCALAR)
1666 *++newsp = &PL_sv_undef;
1667 PL_stack_sp = newsp;
1671 /* LEAVE could clobber PL_curcop (see save_re_context())
1672 * XXX it might be better to find a way to avoid messing with
1673 * PL_curcop in save_re_context() instead, but this is a more
1674 * minimal fix --GSAR */
1677 if (optype == OP_REQUIRE) {
1678 (void)hv_store(GvHVn(PL_incgv),
1679 SvPVX_const(namesv),
1680 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1682 /* note that unlike pp_entereval, pp_require isn't
1683 * supposed to trap errors. So now that we've popped the
1684 * EVAL that pp_require pushed, and processed the error
1685 * message, rethrow the error */
1686 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1687 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1690 if (in_eval & EVAL_KEEPERR) {
1691 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1695 sv_setsv(ERRSV, exceptsv);
1697 PL_restartjmpenv = restartjmpenv;
1698 PL_restartop = restartop;
1700 assert(0); /* NOTREACHED */
1704 write_to_stderr(exceptsv);
1706 assert(0); /* NOTREACHED */
1711 dVAR; dSP; dPOPTOPssrl;
1712 if (SvTRUE(left) != SvTRUE(right))
1719 =for apidoc caller_cx
1721 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1722 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1723 information returned to Perl by C<caller>. Note that XSUBs don't get a
1724 stack frame, so C<caller_cx(0, NULL)> will return information for the
1725 immediately-surrounding Perl code.
1727 This function skips over the automatic calls to C<&DB::sub> made on the
1728 behalf of the debugger. If the stack frame requested was a sub called by
1729 C<DB::sub>, the return value will be the frame for the call to
1730 C<DB::sub>, since that has the correct line number/etc. for the call
1731 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1732 frame for the sub call itself.
1737 const PERL_CONTEXT *
1738 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1740 register I32 cxix = dopoptosub(cxstack_ix);
1741 register const PERL_CONTEXT *cx;
1742 register const PERL_CONTEXT *ccstack = cxstack;
1743 const PERL_SI *top_si = PL_curstackinfo;
1746 /* we may be in a higher stacklevel, so dig down deeper */
1747 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1748 top_si = top_si->si_prev;
1749 ccstack = top_si->si_cxstack;
1750 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1754 /* caller() should not report the automatic calls to &DB::sub */
1755 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1756 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1760 cxix = dopoptosub_at(ccstack, cxix - 1);
1763 cx = &ccstack[cxix];
1764 if (dbcxp) *dbcxp = cx;
1766 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1767 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1768 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1769 field below is defined for any cx. */
1770 /* caller() should not report the automatic calls to &DB::sub */
1771 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1772 cx = &ccstack[dbcxix];
1782 register const PERL_CONTEXT *cx;
1783 const PERL_CONTEXT *dbcx;
1785 const HEK *stash_hek;
1787 bool has_arg = MAXARG && TOPs;
1795 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1797 if (GIMME != G_ARRAY) {
1805 assert(CopSTASH(cx->blk_oldcop));
1806 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1807 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1809 if (GIMME != G_ARRAY) {
1812 PUSHs(&PL_sv_undef);
1815 sv_sethek(TARG, stash_hek);
1824 PUSHs(&PL_sv_undef);
1827 sv_sethek(TARG, stash_hek);
1830 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1831 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1834 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1835 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1836 /* So is ccstack[dbcxix]. */
1837 if (cvgv && isGV(cvgv)) {
1838 SV * const sv = newSV(0);
1839 gv_efullname3(sv, cvgv, NULL);
1841 PUSHs(boolSV(CxHASARGS(cx)));
1844 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1845 PUSHs(boolSV(CxHASARGS(cx)));
1849 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1852 gimme = (I32)cx->blk_gimme;
1853 if (gimme == G_VOID)
1854 PUSHs(&PL_sv_undef);
1856 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1857 if (CxTYPE(cx) == CXt_EVAL) {
1859 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1860 PUSHs(cx->blk_eval.cur_text);
1864 else if (cx->blk_eval.old_namesv) {
1865 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1868 /* eval BLOCK (try blocks have old_namesv == 0) */
1870 PUSHs(&PL_sv_undef);
1871 PUSHs(&PL_sv_undef);
1875 PUSHs(&PL_sv_undef);
1876 PUSHs(&PL_sv_undef);
1878 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1879 && CopSTASH_eq(PL_curcop, PL_debstash))
1881 AV * const ary = cx->blk_sub.argarray;
1882 const int off = AvARRAY(ary) - AvALLOC(ary);
1884 Perl_init_dbargs(aTHX);
1886 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1887 av_extend(PL_dbargs, AvFILLp(ary) + off);
1888 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1889 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1891 /* XXX only hints propagated via op_private are currently
1892 * visible (others are not easily accessible, since they
1893 * use the global PL_hints) */
1894 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1897 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1899 if (old_warnings == pWARN_NONE ||
1900 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1901 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1902 else if (old_warnings == pWARN_ALL ||
1903 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1904 /* Get the bit mask for $warnings::Bits{all}, because
1905 * it could have been extended by warnings::register */
1907 HV * const bits = get_hv("warnings::Bits", 0);
1908 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1909 mask = newSVsv(*bits_all);
1912 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1916 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1920 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1921 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1930 const char * const tmps =
1931 (MAXARG < 1 || (!TOPs && !POPs)) ? (const char *)"" : POPpconstx;
1932 sv_reset(tmps, CopSTASH(PL_curcop));
1937 /* like pp_nextstate, but used instead when the debugger is active */
1942 PL_curcop = (COP*)PL_op;
1943 TAINT_NOT; /* Each statement is presumed innocent */
1944 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1949 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1950 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1953 register PERL_CONTEXT *cx;
1954 const I32 gimme = G_ARRAY;
1956 GV * const gv = PL_DBgv;
1957 register CV * const cv = GvCV(gv);
1960 DIE(aTHX_ "No DB::DB routine defined");
1962 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1963 /* don't do recursive DB::DB call */
1978 (void)(*CvXSUB(cv))(aTHX_ cv);
1985 PUSHBLOCK(cx, CXt_SUB, SP);
1987 cx->blk_sub.retop = PL_op->op_next;
1990 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1991 RETURNOP(CvSTART(cv));
1999 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
2002 PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2004 if (flags & SVs_PADTMP) {
2005 flags &= ~SVs_PADTMP;
2008 if (gimme == G_SCALAR) {
2010 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2011 ? *SP : sv_mortalcopy(*SP);
2013 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2016 *++MARK = &PL_sv_undef;
2020 else if (gimme == G_ARRAY) {
2021 /* in case LEAVE wipes old return values */
2022 while (++MARK <= SP) {
2023 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2026 *++newsp = sv_mortalcopy(*MARK);
2027 TAINT_NOT; /* Each item is independent */
2030 /* When this function was called with MARK == newsp, we reach this
2031 * point with SP == newsp. */
2040 register PERL_CONTEXT *cx;
2041 I32 gimme = GIMME_V;
2043 ENTER_with_name("block");
2046 PUSHBLOCK(cx, CXt_BLOCK, SP);
2054 register PERL_CONTEXT *cx;
2059 if (PL_op->op_flags & OPf_SPECIAL) {
2060 cx = &cxstack[cxstack_ix];
2061 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2066 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2069 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
2070 PL_curpm = newpm; /* Don't pop $1 et al till now */
2072 LEAVE_with_name("block");
2080 register PERL_CONTEXT *cx;
2081 const I32 gimme = GIMME_V;
2082 void *itervar; /* location of the iteration variable */
2083 U8 cxtype = CXt_LOOP_FOR;
2085 ENTER_with_name("loop1");
2088 if (PL_op->op_targ) { /* "my" variable */
2089 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2090 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2091 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2092 SVs_PADSTALE, SVs_PADSTALE);
2094 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2096 itervar = PL_comppad;
2098 itervar = &PAD_SVl(PL_op->op_targ);
2101 else { /* symbol table variable */
2102 GV * const gv = MUTABLE_GV(POPs);
2103 SV** svp = &GvSV(gv);
2104 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2106 itervar = (void *)gv;
2109 if (PL_op->op_private & OPpITER_DEF)
2110 cxtype |= CXp_FOR_DEF;
2112 ENTER_with_name("loop2");
2114 PUSHBLOCK(cx, cxtype, SP);
2115 PUSHLOOP_FOR(cx, itervar, MARK);
2116 if (PL_op->op_flags & OPf_STACKED) {
2117 SV *maybe_ary = POPs;
2118 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2120 SV * const right = maybe_ary;
2123 if (RANGE_IS_NUMERIC(sv,right)) {
2124 cx->cx_type &= ~CXTYPEMASK;
2125 cx->cx_type |= CXt_LOOP_LAZYIV;
2126 /* Make sure that no-one re-orders cop.h and breaks our
2128 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2129 #ifdef NV_PRESERVES_UV
2130 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2131 (SvNV_nomg(sv) > (NV)IV_MAX)))
2133 (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2134 (SvNV_nomg(right) < (NV)IV_MIN))))
2136 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
2138 ((SvNV_nomg(sv) > 0) &&
2139 ((SvUV_nomg(sv) > (UV)IV_MAX) ||
2140 (SvNV_nomg(sv) > (NV)UV_MAX)))))
2142 (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
2144 ((SvNV_nomg(right) > 0) &&
2145 ((SvUV_nomg(right) > (UV)IV_MAX) ||
2146 (SvNV_nomg(right) > (NV)UV_MAX))
2149 DIE(aTHX_ "Range iterator outside integer range");
2150 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2151 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2153 /* for correct -Dstv display */
2154 cx->blk_oldsp = sp - PL_stack_base;
2158 cx->cx_type &= ~CXTYPEMASK;
2159 cx->cx_type |= CXt_LOOP_LAZYSV;
2160 /* Make sure that no-one re-orders cop.h and breaks our
2162 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2163 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2164 cx->blk_loop.state_u.lazysv.end = right;
2165 SvREFCNT_inc(right);
2166 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2167 /* This will do the upgrade to SVt_PV, and warn if the value
2168 is uninitialised. */
2169 (void) SvPV_nolen_const(right);
2170 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2171 to replace !SvOK() with a pointer to "". */
2173 SvREFCNT_dec(right);
2174 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2178 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2179 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2180 SvREFCNT_inc(maybe_ary);
2181 cx->blk_loop.state_u.ary.ix =
2182 (PL_op->op_private & OPpITER_REVERSED) ?
2183 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2187 else { /* iterating over items on the stack */
2188 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2189 if (PL_op->op_private & OPpITER_REVERSED) {
2190 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2193 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2203 register PERL_CONTEXT *cx;
2204 const I32 gimme = GIMME_V;
2206 ENTER_with_name("loop1");
2208 ENTER_with_name("loop2");
2210 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2211 PUSHLOOP_PLAIN(cx, SP);
2219 register PERL_CONTEXT *cx;
2226 assert(CxTYPE_is_LOOP(cx));
2228 newsp = PL_stack_base + cx->blk_loop.resetsp;
2231 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
2234 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2235 PL_curpm = newpm; /* ... and pop $1 et al */
2237 LEAVE_with_name("loop2");
2238 LEAVE_with_name("loop1");
2244 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2245 PERL_CONTEXT *cx, PMOP *newpm)
2247 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2248 if (gimme == G_SCALAR) {
2249 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2251 const char *what = NULL;
2253 assert(MARK+1 == SP);
2254 if ((SvPADTMP(TOPs) ||
2255 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2258 !SvSMAGICAL(TOPs)) {
2260 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2261 : "a readonly value" : "a temporary";
2266 /* sub:lvalue{} will take us here. */
2275 "Can't return %s from lvalue subroutine", what
2280 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2281 if (!SvPADTMP(*SP)) {
2282 *++newsp = SvREFCNT_inc(*SP);
2287 /* FREETMPS could clobber it */
2288 SV *sv = SvREFCNT_inc(*SP);
2290 *++newsp = sv_mortalcopy(sv);
2297 ? sv_mortalcopy(*SP)
2299 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2304 *++newsp = &PL_sv_undef;
2306 if (CxLVAL(cx) & OPpDEREF) {
2309 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2313 else if (gimme == G_ARRAY) {
2314 assert (!(CxLVAL(cx) & OPpDEREF));
2315 if (ref || !CxLVAL(cx))
2316 while (++MARK <= SP)
2318 SvFLAGS(*MARK) & SVs_PADTMP
2319 ? sv_mortalcopy(*MARK)
2322 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2323 else while (++MARK <= SP) {
2324 if (*MARK != &PL_sv_undef
2326 || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2331 /* Might be flattened array after $#array = */
2338 /* diag_listed_as: Can't return %s from lvalue subroutine */
2340 "Can't return a %s from lvalue subroutine",
2341 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2347 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2350 PL_stack_sp = newsp;
2356 register PERL_CONTEXT *cx;
2357 bool popsub2 = FALSE;
2358 bool clear_errsv = FALSE;
2368 const I32 cxix = dopoptosub(cxstack_ix);
2371 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2372 * sort block, which is a CXt_NULL
2375 PL_stack_base[1] = *PL_stack_sp;
2376 PL_stack_sp = PL_stack_base + 1;
2380 DIE(aTHX_ "Can't return outside a subroutine");
2382 if (cxix < cxstack_ix)
2385 if (CxMULTICALL(&cxstack[cxix])) {
2386 gimme = cxstack[cxix].blk_gimme;
2387 if (gimme == G_VOID)
2388 PL_stack_sp = PL_stack_base;
2389 else if (gimme == G_SCALAR) {
2390 PL_stack_base[1] = *PL_stack_sp;
2391 PL_stack_sp = PL_stack_base + 1;
2397 switch (CxTYPE(cx)) {
2400 lval = !!CvLVALUE(cx->blk_sub.cv);
2401 retop = cx->blk_sub.retop;
2402 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2405 if (!(PL_in_eval & EVAL_KEEPERR))
2408 namesv = cx->blk_eval.old_namesv;
2409 retop = cx->blk_eval.retop;
2412 if (optype == OP_REQUIRE &&
2413 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2415 /* Unassume the success we assumed earlier. */
2416 (void)hv_delete(GvHVn(PL_incgv),
2417 SvPVX_const(namesv),
2418 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2420 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2425 retop = cx->blk_sub.retop;
2428 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2432 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2434 if (gimme == G_SCALAR) {
2437 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2438 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2439 && !SvMAGICAL(TOPs)) {
2440 *++newsp = SvREFCNT_inc(*SP);
2445 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2447 *++newsp = sv_mortalcopy(sv);
2451 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2452 && !SvMAGICAL(*SP)) {
2456 *++newsp = sv_mortalcopy(*SP);
2459 *++newsp = sv_mortalcopy(*SP);
2462 *++newsp = &PL_sv_undef;
2464 else if (gimme == G_ARRAY) {
2465 while (++MARK <= SP) {
2466 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2467 && !SvGMAGICAL(*MARK)
2468 ? *MARK : sv_mortalcopy(*MARK);
2469 TAINT_NOT; /* Each item is independent */
2472 PL_stack_sp = newsp;
2476 /* Stack values are safe: */
2479 POPSUB(cx,sv); /* release CV and @_ ... */
2483 PL_curpm = newpm; /* ... and pop $1 et al */
2492 /* This duplicates parts of pp_leavesub, so that it can share code with
2500 register PERL_CONTEXT *cx;
2503 if (CxMULTICALL(&cxstack[cxstack_ix]))
2507 cxstack_ix++; /* temporarily protect top context */
2511 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2515 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2516 PL_curpm = newpm; /* ... and pop $1 et al */
2519 return cx->blk_sub.retop;
2526 register PERL_CONTEXT *cx;
2537 if (PL_op->op_flags & OPf_SPECIAL) {
2538 cxix = dopoptoloop(cxstack_ix);
2540 DIE(aTHX_ "Can't \"last\" outside a loop block");
2543 cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
2544 (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
2546 DIE(aTHX_ "Label not found for \"last %"SVf"\"",
2547 SVfARG(newSVpvn_flags(cPVOP->op_pv,
2548 strlen(cPVOP->op_pv),
2549 ((cPVOP->op_private & OPpPV_IS_UTF8)
2550 ? SVf_UTF8 : 0) | SVs_TEMP)));
2552 if (cxix < cxstack_ix)
2556 cxstack_ix++; /* temporarily protect top context */
2558 switch (CxTYPE(cx)) {
2559 case CXt_LOOP_LAZYIV:
2560 case CXt_LOOP_LAZYSV:
2562 case CXt_LOOP_PLAIN:
2564 newsp = PL_stack_base + cx->blk_loop.resetsp;
2565 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2569 nextop = cx->blk_sub.retop;
2573 nextop = cx->blk_eval.retop;
2577 nextop = cx->blk_sub.retop;
2580 DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2584 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme,
2585 pop2 == CXt_SUB ? SVs_TEMP : 0);
2590 /* Stack values are safe: */
2592 case CXt_LOOP_LAZYIV:
2593 case CXt_LOOP_PLAIN:
2594 case CXt_LOOP_LAZYSV:
2596 POPLOOP(cx); /* release loop vars ... */
2600 POPSUB(cx,sv); /* release CV and @_ ... */
2603 PL_curpm = newpm; /* ... and pop $1 et al */
2606 PERL_UNUSED_VAR(optype);
2607 PERL_UNUSED_VAR(gimme);
2615 register PERL_CONTEXT *cx;
2618 if (PL_op->op_flags & OPf_SPECIAL) {
2619 cxix = dopoptoloop(cxstack_ix);
2621 DIE(aTHX_ "Can't \"next\" outside a loop block");
2624 cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
2625 (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
2627 DIE(aTHX_ "Label not found for \"next %"SVf"\"",
2628 SVfARG(newSVpvn_flags(cPVOP->op_pv,
2629 strlen(cPVOP->op_pv),
2630 ((cPVOP->op_private & OPpPV_IS_UTF8)
2631 ? SVf_UTF8 : 0) | SVs_TEMP)));
2633 if (cxix < cxstack_ix)
2636 /* clear off anything above the scope we're re-entering, but
2637 * save the rest until after a possible continue block */
2638 inner = PL_scopestack_ix;
2640 if (PL_scopestack_ix < inner)
2641 leave_scope(PL_scopestack[PL_scopestack_ix]);
2642 PL_curcop = cx->blk_oldcop;
2643 return (cx)->blk_loop.my_op->op_nextop;
2650 register PERL_CONTEXT *cx;
2654 if (PL_op->op_flags & OPf_SPECIAL) {
2655 cxix = dopoptoloop(cxstack_ix);
2657 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2660 cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
2661 (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
2663 DIE(aTHX_ "Label not found for \"redo %"SVf"\"",
2664 SVfARG(newSVpvn_flags(cPVOP->op_pv,
2665 strlen(cPVOP->op_pv),
2666 ((cPVOP->op_private & OPpPV_IS_UTF8)
2667 ? SVf_UTF8 : 0) | SVs_TEMP)));
2669 if (cxix < cxstack_ix)
2672 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2673 if (redo_op->op_type == OP_ENTER) {
2674 /* pop one less context to avoid $x being freed in while (my $x..) */
2676 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2677 redo_op = redo_op->op_next;
2681 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2682 LEAVE_SCOPE(oldsave);
2684 PL_curcop = cx->blk_oldcop;
2689 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2693 static const char too_deep[] = "Target of goto is too deeply nested";
2695 PERL_ARGS_ASSERT_DOFINDLABEL;
2698 Perl_croak(aTHX_ too_deep);
2699 if (o->op_type == OP_LEAVE ||
2700 o->op_type == OP_SCOPE ||
2701 o->op_type == OP_LEAVELOOP ||
2702 o->op_type == OP_LEAVESUB ||
2703 o->op_type == OP_LEAVETRY)
2705 *ops++ = cUNOPo->op_first;
2707 Perl_croak(aTHX_ too_deep);
2710 if (o->op_flags & OPf_KIDS) {
2712 /* First try all the kids at this level, since that's likeliest. */
2713 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2714 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2715 STRLEN kid_label_len;
2716 U32 kid_label_flags;
2717 const char *kid_label = CopLABEL_len_flags(kCOP,
2718 &kid_label_len, &kid_label_flags);
2720 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2723 (const U8*)kid_label, kid_label_len,
2724 (const U8*)label, len) == 0)
2726 (const U8*)label, len,
2727 (const U8*)kid_label, kid_label_len) == 0)
2728 : ( len == kid_label_len && ((kid_label == label)
2729 || memEQ(kid_label, label, len)))))
2733 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2734 if (kid == PL_lastgotoprobe)
2736 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2739 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2740 ops[-1]->op_type == OP_DBSTATE)
2745 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2758 register PERL_CONTEXT *cx;
2759 #define GOTO_DEPTH 64
2760 OP *enterops[GOTO_DEPTH];
2761 const char *label = NULL;
2762 STRLEN label_len = 0;
2763 U32 label_flags = 0;
2764 const bool do_dump = (PL_op->op_type == OP_DUMP);
2765 static const char must_have_label[] = "goto must have label";
2767 if (PL_op->op_flags & OPf_STACKED) {
2768 SV * const sv = POPs;
2770 /* This egregious kludge implements goto &subroutine */
2771 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2773 register PERL_CONTEXT *cx;
2774 CV *cv = MUTABLE_CV(SvRV(sv));
2781 if (!CvROOT(cv) && !CvXSUB(cv)) {
2782 const GV * const gv = CvGV(cv);
2786 /* autoloaded stub? */
2787 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2789 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2791 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2792 if (autogv && (cv = GvCV(autogv)))
2794 tmpstr = sv_newmortal();
2795 gv_efullname3(tmpstr, gv, NULL);
2796 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2798 DIE(aTHX_ "Goto undefined subroutine");
2801 /* First do some returnish stuff. */
2802 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2804 cxix = dopoptosub(cxstack_ix);
2806 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2807 if (cxix < cxstack_ix)
2811 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2812 if (CxTYPE(cx) == CXt_EVAL) {
2814 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2815 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2817 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2818 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2820 else if (CxMULTICALL(cx))
2821 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2822 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2823 /* put @_ back onto stack */
2824 AV* av = cx->blk_sub.argarray;
2826 items = AvFILLp(av) + 1;
2827 EXTEND(SP, items+1); /* @_ could have been extended. */
2828 Copy(AvARRAY(av), SP + 1, items, SV*);
2829 SvREFCNT_dec(GvAV(PL_defgv));
2830 GvAV(PL_defgv) = cx->blk_sub.savearray;
2832 /* abandon @_ if it got reified */
2837 av_extend(av, items-1);
2839 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2842 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2843 AV* const av = GvAV(PL_defgv);
2844 items = AvFILLp(av) + 1;
2845 EXTEND(SP, items+1); /* @_ could have been extended. */
2846 Copy(AvARRAY(av), SP + 1, items, SV*);
2850 if (CxTYPE(cx) == CXt_SUB &&
2851 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2852 SvREFCNT_dec(cx->blk_sub.cv);
2853 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2854 LEAVE_SCOPE(oldsave);
2856 /* A destructor called during LEAVE_SCOPE could have undefined
2857 * our precious cv. See bug #99850. */
2858 if (!CvROOT(cv) && !CvXSUB(cv)) {
2859 const GV * const gv = CvGV(cv);
2861 SV * const tmpstr = sv_newmortal();
2862 gv_efullname3(tmpstr, gv, NULL);
2863 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2866 DIE(aTHX_ "Goto undefined subroutine");
2869 /* Now do some callish stuff. */
2871 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2873 OP* const retop = cx->blk_sub.retop;
2874 SV **newsp PERL_UNUSED_DECL;
2875 I32 gimme PERL_UNUSED_DECL;
2878 for (index=0; index<items; index++)
2879 sv_2mortal(SP[-index]);
2882 /* XS subs don't have a CxSUB, so pop it */
2883 POPBLOCK(cx, PL_curpm);
2884 /* Push a mark for the start of arglist */
2887 (void)(*CvXSUB(cv))(aTHX_ cv);
2892 AV* const padlist = CvPADLIST(cv);
2893 if (CxTYPE(cx) == CXt_EVAL) {
2894 PL_in_eval = CxOLD_IN_EVAL(cx);
2895 PL_eval_root = cx->blk_eval.old_eval_root;
2896 cx->cx_type = CXt_SUB;
2898 cx->blk_sub.cv = cv;
2899 cx->blk_sub.olddepth = CvDEPTH(cv);
2902 if (CvDEPTH(cv) < 2)
2903 SvREFCNT_inc_simple_void_NN(cv);
2905 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2906 sub_crush_depth(cv);
2907 pad_push(padlist, CvDEPTH(cv));
2909 PL_curcop = cx->blk_oldcop;
2911 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2914 AV *const av = MUTABLE_AV(PAD_SVl(0));
2916 cx->blk_sub.savearray = GvAV(PL_defgv);
2917 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2918 CX_CURPAD_SAVE(cx->blk_sub);
2919 cx->blk_sub.argarray = av;
2921 if (items >= AvMAX(av) + 1) {
2922 SV **ary = AvALLOC(av);
2923 if (AvARRAY(av) != ary) {
2924 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2927 if (items >= AvMAX(av) + 1) {
2928 AvMAX(av) = items - 1;
2929 Renew(ary,items+1,SV*);
2935 Copy(mark,AvARRAY(av),items,SV*);
2936 AvFILLp(av) = items - 1;
2937 assert(!AvREAL(av));
2939 /* transfer 'ownership' of refcnts to new @_ */
2949 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2950 Perl_get_db_sub(aTHX_ NULL, cv);
2952 CV * const gotocv = get_cvs("DB::goto", 0);
2954 PUSHMARK( PL_stack_sp );
2955 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2960 RETURNOP(CvSTART(cv));
2964 label = SvPV_const(sv, label_len);
2965 label_flags = SvUTF8(sv);
2968 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2969 label = cPVOP->op_pv;
2970 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2971 label_len = strlen(label);
2973 if (!(do_dump || label_len)) DIE(aTHX_ must_have_label);
2978 OP *gotoprobe = NULL;
2979 bool leaving_eval = FALSE;
2980 bool in_block = FALSE;
2981 PERL_CONTEXT *last_eval_cx = NULL;
2985 PL_lastgotoprobe = NULL;
2987 for (ix = cxstack_ix; ix >= 0; ix--) {
2989 switch (CxTYPE(cx)) {
2991 leaving_eval = TRUE;
2992 if (!CxTRYBLOCK(cx)) {
2993 gotoprobe = (last_eval_cx ?
2994 last_eval_cx->blk_eval.old_eval_root :
2999 /* else fall through */
3000 case CXt_LOOP_LAZYIV:
3001 case CXt_LOOP_LAZYSV:
3003 case CXt_LOOP_PLAIN:
3006 gotoprobe = cx->blk_oldcop->op_sibling;
3012 gotoprobe = cx->blk_oldcop->op_sibling;
3015 gotoprobe = PL_main_root;
3018 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3019 gotoprobe = CvROOT(cx->blk_sub.cv);
3025 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3028 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3029 CxTYPE(cx), (long) ix);
3030 gotoprobe = PL_main_root;
3034 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3035 enterops, enterops + GOTO_DEPTH);
3038 if (gotoprobe->op_sibling &&
3039 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3040 gotoprobe->op_sibling->op_sibling) {
3041 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3042 label, label_len, label_flags, enterops,
3043 enterops + GOTO_DEPTH);
3048 PL_lastgotoprobe = gotoprobe;
3051 DIE(aTHX_ "Can't find label %"SVf,
3052 SVfARG(newSVpvn_flags(label, label_len,
3053 SVs_TEMP | label_flags)));
3055 /* if we're leaving an eval, check before we pop any frames
3056 that we're not going to punt, otherwise the error
3059 if (leaving_eval && *enterops && enterops[1]) {
3061 for (i = 1; enterops[i]; i++)
3062 if (enterops[i]->op_type == OP_ENTERITER)
3063 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3066 if (*enterops && enterops[1]) {
3067 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3069 deprecate("\"goto\" to jump into a construct");
3072 /* pop unwanted frames */
3074 if (ix < cxstack_ix) {
3081 oldsave = PL_scopestack[PL_scopestack_ix];
3082 LEAVE_SCOPE(oldsave);
3085 /* push wanted frames */
3087 if (*enterops && enterops[1]) {
3088 OP * const oldop = PL_op;
3089 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3090 for (; enterops[ix]; ix++) {
3091 PL_op = enterops[ix];
3092 /* Eventually we may want to stack the needed arguments
3093 * for each op. For now, we punt on the hard ones. */
3094 if (PL_op->op_type == OP_ENTERITER)
3095 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3096 PL_op->op_ppaddr(aTHX);
3104 if (!retop) retop = PL_main_start;
3106 PL_restartop = retop;
3107 PL_do_undump = TRUE;
3111 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3112 PL_do_undump = FALSE;
3127 anum = 0; (void)POPs;
3132 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3134 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3137 PL_exit_flags |= PERL_EXIT_EXPECTED;
3139 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3140 if (anum || !(PL_minus_c && PL_madskills))
3145 PUSHs(&PL_sv_undef);
3152 S_save_lines(pTHX_ AV *array, SV *sv)
3154 const char *s = SvPVX_const(sv);
3155 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3158 PERL_ARGS_ASSERT_SAVE_LINES;
3160 while (s && s < send) {
3162 SV * const tmpstr = newSV_type(SVt_PVMG);
3164 t = (const char *)memchr(s, '\n', send - s);
3170 sv_setpvn(tmpstr, s, t - s);
3171 av_store(array, line++, tmpstr);
3179 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3181 0 is used as continue inside eval,
3183 3 is used for a die caught by an inner eval - continue inner loop
3185 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3186 establish a local jmpenv to handle exception traps.
3191 S_docatch(pTHX_ OP *o)
3195 OP * const oldop = PL_op;
3199 assert(CATCH_GET == TRUE);
3206 assert(cxstack_ix >= 0);
3207 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3208 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3213 /* die caught by an inner eval - continue inner loop */
3214 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3215 PL_restartjmpenv = NULL;
3216 PL_op = PL_restartop;
3225 assert(0); /* NOTREACHED */
3234 =for apidoc find_runcv
3236 Locate the CV corresponding to the currently executing sub or eval.
3237 If db_seqp is non_null, skip CVs that are in the DB package and populate
3238 *db_seqp with the cop sequence number at the point that the DB:: code was
3239 entered. (allows debuggers to eval in the scope of the breakpoint rather
3240 than in the scope of the debugger itself).
3246 Perl_find_runcv(pTHX_ U32 *db_seqp)
3248 return Perl_find_runcv_where(aTHX_ 0, NULL, db_seqp);
3251 /* If this becomes part of the API, it might need a better name. */
3253 Perl_find_runcv_where(pTHX_ U8 cond, void *arg, U32 *db_seqp)
3260 *db_seqp = PL_curcop->cop_seq;
3261 for (si = PL_curstackinfo; si; si = si->si_prev) {
3263 for (ix = si->si_cxix; ix >= 0; ix--) {
3264 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3266 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3267 cv = cx->blk_sub.cv;
3268 /* skip DB:: code */
3269 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3270 *db_seqp = cx->blk_oldcop->cop_seq;
3274 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3275 cv = cx->blk_eval.cv;
3278 case FIND_RUNCV_root_eq:
3279 if (CvROOT(cv) != (OP *)arg) continue;
3281 case FIND_RUNCV_level_eq:
3282 if (level++ != (IV)arg) continue;
3290 return cond == FIND_RUNCV_root_eq ? NULL : PL_main_cv;
3294 /* Run yyparse() in a setjmp wrapper. Returns:
3295 * 0: yyparse() successful
3296 * 1: yyparse() failed
3300 S_try_yyparse(pTHX_ int gramtype)
3305 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3309 ret = yyparse(gramtype) ? 1 : 0;
3316 assert(0); /* NOTREACHED */
3323 /* Compile a require/do or an eval ''.
3325 * outside is the lexically enclosing CV (if any) that invoked us.
3326 * seq is the current COP scope value.
3327 * hh is the saved hints hash, if any.
3329 * Returns a bool indicating whether the compile was successful; if so,
3330 * PL_eval_start contains the first op of the compiled code; otherwise,
3333 * This function is called from two places: pp_require and pp_entereval.
3334 * These can be distinguished by whether PL_op is entereval.
3338 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3341 OP * const saveop = PL_op;
3342 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3343 COP * const oldcurcop = PL_curcop;
3344 bool in_require = (saveop->op_type == OP_REQUIRE);
3348 PL_in_eval = (in_require
3349 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3354 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3356 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3357 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3358 cxstack[cxstack_ix].blk_gimme = gimme;
3360 CvOUTSIDE_SEQ(evalcv) = seq;
3361 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3363 /* set up a scratch pad */
3365 CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3366 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3370 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3372 /* make sure we compile in the right package */
3374 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3375 SAVEGENERICSV(PL_curstash);
3376 PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop));
3378 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3379 SAVESPTR(PL_beginav);
3380 PL_beginav = newAV();
3381 SAVEFREESV(PL_beginav);
3382 SAVESPTR(PL_unitcheckav);
3383 PL_unitcheckav = newAV();
3384 SAVEFREESV(PL_unitcheckav);
3387 SAVEBOOL(PL_madskills);
3391 ENTER_with_name("evalcomp");
3392 SAVESPTR(PL_compcv);
3395 /* try to compile it */
3397 PL_eval_root = NULL;
3398 PL_curcop = &PL_compiling;
3399 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3400 PL_in_eval |= EVAL_KEEPERR;
3407 hv_clear(GvHV(PL_hintgv));
3410 PL_hints = saveop->op_private & OPpEVAL_COPHH
3411 ? oldcurcop->cop_hints : saveop->op_targ;
3413 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3414 SvREFCNT_dec(GvHV(PL_hintgv));
3415 GvHV(PL_hintgv) = hh;
3418 SAVECOMPILEWARNINGS();
3420 if (PL_dowarn & G_WARN_ALL_ON)
3421 PL_compiling.cop_warnings = pWARN_ALL ;
3422 else if (PL_dowarn & G_WARN_ALL_OFF)
3423 PL_compiling.cop_warnings = pWARN_NONE ;
3425 PL_compiling.cop_warnings = pWARN_STD ;
3428 PL_compiling.cop_warnings =
3429 DUP_WARNINGS(oldcurcop->cop_warnings);
3430 cophh_free(CopHINTHASH_get(&PL_compiling));
3431 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3432 /* The label, if present, is the first entry on the chain. So rather
3433 than writing a blank label in front of it (which involves an
3434 allocation), just use the next entry in the chain. */
3435 PL_compiling.cop_hints_hash
3436 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3437 /* Check the assumption that this removed the label. */
3438 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3441 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3444 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3446 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3447 * so honour CATCH_GET and trap it here if necessary */
3449 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3451 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3452 SV **newsp; /* Used by POPBLOCK. */
3454 I32 optype; /* Used by POPEVAL. */
3459 PERL_UNUSED_VAR(newsp);
3460 PERL_UNUSED_VAR(optype);
3462 /* note that if yystatus == 3, then the EVAL CX block has already
3463 * been popped, and various vars restored */
3465 if (yystatus != 3) {
3467 cv_forget_slab(evalcv);
3468 op_free(PL_eval_root);
3469 PL_eval_root = NULL;
3471 SP = PL_stack_base + POPMARK; /* pop original mark */
3472 POPBLOCK(cx,PL_curpm);
3474 namesv = cx->blk_eval.old_namesv;
3475 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3476 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3481 /* If cx is still NULL, it means that we didn't go in the
3482 * POPEVAL branch. */
3483 cx = &cxstack[cxstack_ix];
3484 assert(CxTYPE(cx) == CXt_EVAL);
3485 namesv = cx->blk_eval.old_namesv;
3487 (void)hv_store(GvHVn(PL_incgv),
3488 SvPVX_const(namesv),
3489 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3491 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3494 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3497 if (!*(SvPVx_nolen_const(ERRSV))) {
3498 sv_setpvs(ERRSV, "Compilation error");
3501 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3506 LEAVE_with_name("evalcomp");
3508 CopLINE_set(&PL_compiling, 0);
3509 SAVEFREEOP(PL_eval_root);
3510 cv_forget_slab(evalcv);
3512 DEBUG_x(dump_eval());
3514 /* Register with debugger: */
3515 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3516 CV * const cv = get_cvs("DB::postponed", 0);
3520 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3522 call_sv(MUTABLE_SV(cv), G_DISCARD);
3526 if (PL_unitcheckav) {
3527 OP *es = PL_eval_start;
3528 call_list(PL_scopestack_ix, PL_unitcheckav);
3532 /* compiled okay, so do it */
3534 CvDEPTH(evalcv) = 1;
3535 SP = PL_stack_base + POPMARK; /* pop original mark */
3536 PL_op = saveop; /* The caller may need it. */
3537 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3544 S_check_type_and_open(pTHX_ SV *name)
3547 const char *p = SvPV_nolen_const(name);
3548 const int st_rc = PerlLIO_stat(p, &st);
3550 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3552 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3556 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3557 return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3559 return PerlIO_open(p, PERL_SCRIPT_MODE);
3563 #ifndef PERL_DISABLE_PMC
3565 S_doopen_pm(pTHX_ SV *name)
3568 const char *p = SvPV_const(name, namelen);
3570 PERL_ARGS_ASSERT_DOOPEN_PM;
3572 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3573 SV *const pmcsv = sv_newmortal();
3576 SvSetSV_nosteal(pmcsv,name);
3577 sv_catpvn(pmcsv, "c", 1);
3579 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3580 return check_type_and_open(pmcsv);
3582 return check_type_and_open(name);
3585 # define doopen_pm(name) check_type_and_open(name)
3586 #endif /* !PERL_DISABLE_PMC */
3591 register PERL_CONTEXT *cx;
3598 int vms_unixname = 0;
3600 const char *tryname = NULL;
3602 const I32 gimme = GIMME_V;
3603 int filter_has_file = 0;
3604 PerlIO *tryrsfp = NULL;
3605 SV *filter_cache = NULL;
3606 SV *filter_state = NULL;
3607 SV *filter_sub = NULL;
3614 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3615 sv = sv_2mortal(new_version(sv));
3616 if (!sv_derived_from(PL_patchlevel, "version"))
3617 upg_version(PL_patchlevel, TRUE);
3618 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3619 if ( vcmp(sv,PL_patchlevel) <= 0 )
3620 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3621 SVfARG(sv_2mortal(vnormal(sv))),
3622 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3626 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3629 SV * const req = SvRV(sv);
3630 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3632 /* get the left hand term */
3633 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3635 first = SvIV(*av_fetch(lav,0,0));
3636 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3637 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3638 || av_len(lav) > 1 /* FP with > 3 digits */
3639 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3641 DIE(aTHX_ "Perl %"SVf" required--this is only "
3643 SVfARG(sv_2mortal(vnormal(req))),
3644 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3647 else { /* probably 'use 5.10' or 'use 5.8' */
3652 second = SvIV(*av_fetch(lav,1,0));
3654 second /= second >= 600 ? 100 : 10;
3655 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3656 (int)first, (int)second);
3657 upg_version(hintsv, TRUE);
3659 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3660 "--this is only %"SVf", stopped",
3661 SVfARG(sv_2mortal(vnormal(req))),
3662 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3663 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3671 name = SvPV_const(sv, len);
3672 if (!(name && len > 0 && *name))
3673 DIE(aTHX_ "Null filename used");
3674 TAINT_PROPER("require");
3678 /* The key in the %ENV hash is in the syntax of file passed as the argument
3679 * usually this is in UNIX format, but sometimes in VMS format, which
3680 * can result in a module being pulled in more than once.
3681 * To prevent this, the key must be stored in UNIX format if the VMS
3682 * name can be translated to UNIX.
3684 if ((unixname = tounixspec(name, NULL)) != NULL) {
3685 unixlen = strlen(unixname);
3691 /* if not VMS or VMS name can not be translated to UNIX, pass it
3694 unixname = (char *) name;
3697 if (PL_op->op_type == OP_REQUIRE) {
3698 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3699 unixname, unixlen, 0);
3701 if (*svp != &PL_sv_undef)
3704 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3705 "Compilation failed in require", unixname);
3709 /* prepare to compile file */
3711 if (path_is_absolute(name)) {
3712 /* At this point, name is SvPVX(sv) */
3714 tryrsfp = doopen_pm(sv);
3716 if (!tryrsfp && !(errno == EACCES && path_is_absolute(name))) {
3717 AV * const ar = GvAVn(PL_incgv);
3723 namesv = newSV_type(SVt_PV);
3724 for (i = 0; i <= AvFILL(ar); i++) {
3725 SV * const dirsv = *av_fetch(ar, i, TRUE);
3727 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3734 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3735 && !sv_isobject(loader))
3737 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3740 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3741 PTR2UV(SvRV(dirsv)), name);
3742 tryname = SvPVX_const(namesv);
3745 ENTER_with_name("call_INC");
3753 if (sv_isobject(loader))
3754 count = call_method("INC", G_ARRAY);
3756 count = call_sv(loader, G_ARRAY);
3766 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3767 && !isGV_with_GP(SvRV(arg))) {
3768 filter_cache = SvRV(arg);
3769 SvREFCNT_inc_simple_void_NN(filter_cache);
3776 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3780 if (isGV_with_GP(arg)) {
3781 IO * const io = GvIO((const GV *)arg);
3786 tryrsfp = IoIFP(io);
3787 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3788 PerlIO_close(IoOFP(io));
3799 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3801 SvREFCNT_inc_simple_void_NN(filter_sub);
3804 filter_state = SP[i];
3805 SvREFCNT_inc_simple_void(filter_state);
3809 if (!tryrsfp && (filter_cache || filter_sub)) {
3810 tryrsfp = PerlIO_open(BIT_BUCKET,
3818 LEAVE_with_name("call_INC");
3820 /* Adjust file name if the hook has set an %INC entry.
3821 This needs to happen after the FREETMPS above. */
3822 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3824 tryname = SvPV_nolen_const(*svp);
3831 filter_has_file = 0;
3833 SvREFCNT_dec(filter_cache);
3834 filter_cache = NULL;
3837 SvREFCNT_dec(filter_state);
3838 filter_state = NULL;
3841 SvREFCNT_dec(filter_sub);
3846 if (!path_is_absolute(name)
3852 dir = SvPV_const(dirsv, dirlen);
3860 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3862 sv_setpv(namesv, unixdir);
3863 sv_catpv(namesv, unixname);
3865 # ifdef __SYMBIAN32__
3866 if (PL_origfilename[0] &&
3867 PL_origfilename[1] == ':' &&
3868 !(dir[0] && dir[1] == ':'))
3869 Perl_sv_setpvf(aTHX_ namesv,
3874 Perl_sv_setpvf(aTHX_ namesv,
3878 /* The equivalent of
3879 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3880 but without the need to parse the format string, or
3881 call strlen on either pointer, and with the correct
3882 allocation up front. */
3884 char *tmp = SvGROW(namesv, dirlen + len + 2);
3886 memcpy(tmp, dir, dirlen);
3889 /* name came from an SV, so it will have a '\0' at the
3890 end that we can copy as part of this memcpy(). */
3891 memcpy(tmp, name, len + 1);
3893 SvCUR_set(namesv, dirlen + len + 1);
3898 TAINT_PROPER("require");
3899 tryname = SvPVX_const(namesv);
3900 tryrsfp = doopen_pm(namesv);
3902 if (tryname[0] == '.' && tryname[1] == '/') {
3904 while (*++tryname == '/');
3908 else if (errno == EMFILE || errno == EACCES) {
3909 /* no point in trying other paths if out of handles;
3910 * on the other hand, if we couldn't open one of the
3911 * files, then going on with the search could lead to
3912 * unexpected results; see perl #113422
3921 saved_errno = errno; /* sv_2mortal can realloc things */
3924 if (PL_op->op_type == OP_REQUIRE) {
3925 if(saved_errno == EMFILE || saved_errno == EACCES) {
3926 /* diag_listed_as: Can't locate %s */
3927 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno));
3929 if (namesv) { /* did we lookup @INC? */
3930 AV * const ar = GvAVn(PL_incgv);
3932 SV *const inc = newSVpvs_flags("", SVs_TEMP);
3933 for (i = 0; i <= AvFILL(ar); i++) {
3934 sv_catpvs(inc, " ");
3935 sv_catsv(inc, *av_fetch(ar, i, TRUE));
3938 /* diag_listed_as: Can't locate %s */
3940 "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
3942 (memEQ(name + len - 2, ".h", 3)
3943 ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
3944 (memEQ(name + len - 3, ".ph", 4)
3945 ? " (did you run h2ph?)" : ""),
3950 DIE(aTHX_ "Can't locate %s", name);
3957 SETERRNO(0, SS_NORMAL);
3959 /* Assume success here to prevent recursive requirement. */
3960 /* name is never assigned to again, so len is still strlen(name) */
3961 /* Check whether a hook in @INC has already filled %INC */
3963 (void)hv_store(GvHVn(PL_incgv),
3964 unixname, unixlen, newSVpv(tryname,0),0);
3966 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3968 (void)hv_store(GvHVn(PL_incgv),
3969 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3972 ENTER_with_name("eval");
3974 SAVECOPFILE_FREE(&PL_compiling);
3975 CopFILE_set(&PL_compiling, tryname);
3976 lex_start(NULL, tryrsfp, 0);
3978 if (filter_sub || filter_cache) {
3979 /* We can use the SvPV of the filter PVIO itself as our cache, rather
3980 than hanging another SV from it. In turn, filter_add() optionally
3981 takes the SV to use as the filter (or creates a new SV if passed
3982 NULL), so simply pass in whatever value filter_cache has. */
3983 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3984 IoLINES(datasv) = filter_has_file;
3985 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3986 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3989 /* switch to eval mode */
3990 PUSHBLOCK(cx, CXt_EVAL, SP);
3992 cx->blk_eval.retop = PL_op->op_next;
3994 SAVECOPLINE(&PL_compiling);
3995 CopLINE_set(&PL_compiling, 0);
3999 /* Store and reset encoding. */
4000 encoding = PL_encoding;
4003 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4004 op = DOCATCH(PL_eval_start);
4006 op = PL_op->op_next;
4008 /* Restore encoding. */
4009 PL_encoding = encoding;
4014 /* This is a op added to hold the hints hash for
4015 pp_entereval. The hash can be modified by the code
4016 being eval'ed, so we return a copy instead. */
4022 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4030 register PERL_CONTEXT *cx;
4032 const I32 gimme = GIMME_V;
4033 const U32 was = PL_breakable_sub_gen;
4034 char tbuf[TYPE_DIGITS(long) + 12];
4035 bool saved_delete = FALSE;
4036 char *tmpbuf = tbuf;
4039 U32 seq, lex_flags = 0;
4040 HV *saved_hh = NULL;
4041 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4043 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4044 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4046 else if (PL_hints & HINT_LOCALIZE_HH || (
4047 PL_op->op_private & OPpEVAL_COPHH
4048 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4050 saved_hh = cop_hints_2hv(PL_curcop, 0);
4051 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4055 /* make sure we've got a plain PV (no overload etc) before testing
4056 * for taint. Making a copy here is probably overkill, but better
4057 * safe than sorry */
4059 const char * const p = SvPV_const(sv, len);
4061 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4062 lex_flags |= LEX_START_COPIED;
4064 if (bytes && SvUTF8(sv))
4065 SvPVbyte_force(sv, len);
4067 else if (bytes && SvUTF8(sv)) {
4068 /* Don't modify someone else's scalar */
4071 (void)sv_2mortal(sv);
4072 SvPVbyte_force(sv,len);
4073 lex_flags |= LEX_START_COPIED;
4076 TAINT_IF(SvTAINTED(sv));
4077 TAINT_PROPER("eval");
4079 ENTER_with_name("eval");
4080 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4081 ? LEX_IGNORE_UTF8_HINTS
4082 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4087 /* switch to eval mode */
4089 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4090 SV * const temp_sv = sv_newmortal();
4091 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4092 (unsigned long)++PL_evalseq,
4093 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4094 tmpbuf = SvPVX(temp_sv);
4095 len = SvCUR(temp_sv);
4098 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4099 SAVECOPFILE_FREE(&PL_compiling);
4100 CopFILE_set(&PL_compiling, tmpbuf+2);
4101 SAVECOPLINE(&PL_compiling);
4102 CopLINE_set(&PL_compiling, 1);
4103 /* special case: an eval '' executed within the DB package gets lexically
4104 * placed in the first non-DB CV rather than the current CV - this
4105 * allows the debugger to execute code, find lexicals etc, in the
4106 * scope of the code being debugged. Passing &seq gets find_runcv
4107 * to do the dirty work for us */
4108 runcv = find_runcv(&seq);
4110 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4112 cx->blk_eval.retop = PL_op->op_next;
4114 /* prepare to compile string */
4116 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4117 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4119 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4120 deleting the eval's FILEGV from the stash before gv_check() runs
4121 (i.e. before run-time proper). To work around the coredump that
4122 ensues, we always turn GvMULTI_on for any globals that were
4123 introduced within evals. See force_ident(). GSAR 96-10-12 */
4124 char *const safestr = savepvn(tmpbuf, len);
4125 SAVEDELETE(PL_defstash, safestr, len);
4126 saved_delete = TRUE;
4131 if (doeval(gimme, runcv, seq, saved_hh)) {
4132 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4133 ? (PERLDB_LINE || PERLDB_SAVESRC)
4134 : PERLDB_SAVESRC_NOSUBS) {
4135 /* Retain the filegv we created. */
4136 } else if (!saved_delete) {
4137 char *const safestr = savepvn(tmpbuf, len);
4138 SAVEDELETE(PL_defstash, safestr, len);
4140 return DOCATCH(PL_eval_start);
4142 /* We have already left the scope set up earlier thanks to the LEAVE
4144 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4145 ? (PERLDB_LINE || PERLDB_SAVESRC)
4146 : PERLDB_SAVESRC_INVALID) {
4147 /* Retain the filegv we created. */
4148 } else if (!saved_delete) {
4149 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4151 return PL_op->op_next;
4161 register PERL_CONTEXT *cx;
4163 const U8 save_flags = PL_op -> op_flags;
4171 namesv = cx->blk_eval.old_namesv;
4172 retop = cx->blk_eval.retop;
4173 evalcv = cx->blk_eval.cv;
4176 SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4178 PL_curpm = newpm; /* Don't pop $1 et al till now */
4181 assert(CvDEPTH(evalcv) == 1);
4183 CvDEPTH(evalcv) = 0;
4185 if (optype == OP_REQUIRE &&
4186 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4188 /* Unassume the success we assumed earlier. */
4189 (void)hv_delete(GvHVn(PL_incgv),
4190 SvPVX_const(namesv),
4191 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4193 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4195 /* die_unwind() did LEAVE, or we won't be here */
4198 LEAVE_with_name("eval");
4199 if (!(save_flags & OPf_SPECIAL)) {
4207 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4208 close to the related Perl_create_eval_scope. */
4210 Perl_delete_eval_scope(pTHX)
4215 register PERL_CONTEXT *cx;
4221 LEAVE_with_name("eval_scope");
4222 PERL_UNUSED_VAR(newsp);
4223 PERL_UNUSED_VAR(gimme);
4224 PERL_UNUSED_VAR(optype);
4227 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4228 also needed by Perl_fold_constants. */
4230 Perl_create_eval_scope(pTHX_ U32 flags)
4233 const I32 gimme = GIMME_V;
4235 ENTER_with_name("eval_scope");
4238 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4241 PL_in_eval = EVAL_INEVAL;
4242 if (flags & G_KEEPERR)
4243 PL_in_eval |= EVAL_KEEPERR;
4246 if (flags & G_FAKINGEVAL) {
4247 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4255 PERL_CONTEXT * const cx = create_eval_scope(0);
4256 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4257 return DOCATCH(PL_op->op_next);
4266 register PERL_CONTEXT *cx;
4272 PERL_UNUSED_VAR(optype);
4275 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4276 PL_curpm = newpm; /* Don't pop $1 et al till now */
4278 LEAVE_with_name("eval_scope");
4286 register PERL_CONTEXT *cx;
4287 const I32 gimme = GIMME_V;
4289 ENTER_with_name("given");
4292 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
4293 sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
4295 PUSHBLOCK(cx, CXt_GIVEN, SP);
4304 register PERL_CONTEXT *cx;
4308 PERL_UNUSED_CONTEXT;
4311 assert(CxTYPE(cx) == CXt_GIVEN);
4314 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4315 PL_curpm = newpm; /* Don't pop $1 et al till now */
4317 LEAVE_with_name("given");
4321 /* Helper routines used by pp_smartmatch */
4323 S_make_matcher(pTHX_ REGEXP *re)
4326 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4328 PERL_ARGS_ASSERT_MAKE_MATCHER;
4330 PM_SETRE(matcher, ReREFCNT_inc(re));
4332 SAVEFREEOP((OP *) matcher);
4333 ENTER_with_name("matcher"); SAVETMPS;
4339 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4344 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4346 PL_op = (OP *) matcher;
4349 (void) Perl_pp_match(aTHX);
4351 return (SvTRUEx(POPs));
4355 S_destroy_matcher(pTHX_ PMOP *matcher)
4359 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4360 PERL_UNUSED_ARG(matcher);
4363 LEAVE_with_name("matcher");
4366 /* Do a smart match */
4369 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4370 return do_smartmatch(NULL, NULL, 0);
4373 /* This version of do_smartmatch() implements the
4374 * table of smart matches that is found in perlsyn.
4377 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4382 bool object_on_left = FALSE;
4383 SV *e = TOPs; /* e is for 'expression' */
4384 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4386 /* Take care only to invoke mg_get() once for each argument.
4387 * Currently we do this by copying the SV if it's magical. */
4389 if (!copied && SvGMAGICAL(d))
4390 d = sv_mortalcopy(d);
4397 e = sv_mortalcopy(e);
4399 /* First of all, handle overload magic of the rightmost argument */
4402 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4403 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4405 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4412 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4415 SP -= 2; /* Pop the values */
4420 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4427 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4428 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4429 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4431 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4432 object_on_left = TRUE;
4435 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4437 if (object_on_left) {
4438 goto sm_any_sub; /* Treat objects like scalars */
4440 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4441 /* Test sub truth for each key */
4443 bool andedresults = TRUE;
4444 HV *hv = (HV*) SvRV(d);
4445 I32 numkeys = hv_iterinit(hv);
4446 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4449 while ( (he = hv_iternext(hv)) ) {
4450 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4451 ENTER_with_name("smartmatch_hash_key_test");
4454 PUSHs(hv_iterkeysv(he));
4456 c = call_sv(e, G_SCALAR);
4459 andedresults = FALSE;
4461 andedresults = SvTRUEx(POPs) && andedresults;
4463 LEAVE_with_name("smartmatch_hash_key_test");
4470 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4471 /* Test sub truth for each element */
4473 bool andedresults = TRUE;
4474 AV *av = (AV*) SvRV(d);
4475 const I32 len = av_len(av);
4476 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4479 for (i = 0; i <= len; ++i) {
4480 SV * const * const svp = av_fetch(av, i, FALSE);
4481 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4482 ENTER_with_name("smartmatch_array_elem_test");
4488 c = call_sv(e, G_SCALAR);
4491 andedresults = FALSE;
4493 andedresults = SvTRUEx(POPs) && andedresults;
4495 LEAVE_with_name("smartmatch_array_elem_test");
4504 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4505 ENTER_with_name("smartmatch_coderef");
4510 c = call_sv(e, G_SCALAR);
4514 else if (SvTEMP(TOPs))
4515 SvREFCNT_inc_void(TOPs);
4517 LEAVE_with_name("smartmatch_coderef");
4522 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4523 if (object_on_left) {
4524 goto sm_any_hash; /* Treat objects like scalars */
4526 else if (!SvOK(d)) {
4527 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4530 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4531 /* Check that the key-sets are identical */
4533 HV *other_hv = MUTABLE_HV(SvRV(d));
4535 bool other_tied = FALSE;
4536 U32 this_key_count = 0,
4537 other_key_count = 0;
4538 HV *hv = MUTABLE_HV(SvRV(e));
4540 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4541 /* Tied hashes don't know how many keys they have. */
4542 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4545 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4546 HV * const temp = other_hv;
4551 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4554 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4557 /* The hashes have the same number of keys, so it suffices
4558 to check that one is a subset of the other. */
4559 (void) hv_iterinit(hv);
4560 while ( (he = hv_iternext(hv)) ) {
4561 SV *key = hv_iterkeysv(he);
4563 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4566 if(!hv_exists_ent(other_hv, key, 0)) {
4567 (void) hv_iterinit(hv); /* reset iterator */
4573 (void) hv_iterinit(other_hv);
4574 while ( hv_iternext(other_hv) )
4578 other_key_count = HvUSEDKEYS(other_hv);
4580 if (this_key_count != other_key_count)
4585 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4586 AV * const other_av = MUTABLE_AV(SvRV(d));
4587 const I32 other_len = av_len(other_av) + 1;
4589 HV *hv = MUTABLE_HV(SvRV(e));
4591 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4592 for (i = 0; i < other_len; ++i) {
4593 SV ** const svp = av_fetch(other_av, i, FALSE);
4594 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4595 if (svp) { /* ??? When can this not happen? */
4596 if (hv_exists_ent(hv, *svp, 0))
4602 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4603 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4606 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4608 HV *hv = MUTABLE_HV(SvRV(e));
4610 (void) hv_iterinit(hv);
4611 while ( (he = hv_iternext(hv)) ) {
4612 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4613 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4614 (void) hv_iterinit(hv);
4615 destroy_matcher(matcher);
4619 destroy_matcher(matcher);
4625 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4626 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4633 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4634 if (object_on_left) {
4635 goto sm_any_array; /* Treat objects like scalars */
4637 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4638 AV * const other_av = MUTABLE_AV(SvRV(e));
4639 const I32 other_len = av_len(other_av) + 1;
4642 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4643 for (i = 0; i < other_len; ++i) {
4644 SV ** const svp = av_fetch(other_av, i, FALSE);
4646 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4647 if (svp) { /* ??? When can this not happen? */
4648 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4654 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4655 AV *other_av = MUTABLE_AV(SvRV(d));
4656 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4657 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4661 const I32 other_len = av_len(other_av);
4663 if (NULL == seen_this) {
4664 seen_this = newHV();
4665 (void) sv_2mortal(MUTABLE_SV(seen_this));
4667 if (NULL == seen_other) {
4668 seen_other = newHV();
4669 (void) sv_2mortal(MUTABLE_SV(seen_other));
4671 for(i = 0; i <= other_len; ++i) {
4672 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4673 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4675 if (!this_elem || !other_elem) {
4676 if ((this_elem && SvOK(*this_elem))
4677 || (other_elem && SvOK(*other_elem)))
4680 else if (hv_exists_ent(seen_this,
4681 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4682 hv_exists_ent(seen_other,
4683 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4685 if (*this_elem != *other_elem)
4689 (void)hv_store_ent(seen_this,
4690 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4692 (void)hv_store_ent(seen_other,
4693 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4699 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4700 (void) do_smartmatch(seen_this, seen_other, 0);
4702 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4711 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4712 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4715 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4716 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4719 for(i = 0; i <= this_len; ++i) {
4720 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4721 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4722 if (svp && matcher_matches_sv(matcher, *svp)) {
4723 destroy_matcher(matcher);
4727 destroy_matcher(matcher);
4731 else if (!SvOK(d)) {
4732 /* undef ~~ array */
4733 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4736 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4737 for (i = 0; i <= this_len; ++i) {
4738 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4739 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4740 if (!svp || !SvOK(*svp))
4749 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4751 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4752 for (i = 0; i <= this_len; ++i) {
4753 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4760 /* infinite recursion isn't supposed to happen here */
4761 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4762 (void) do_smartmatch(NULL, NULL, 1);
4764 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4773 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4774 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4775 SV *t = d; d = e; e = t;
4776 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4779 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4780 SV *t = d; d = e; e = t;
4781 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4782 goto sm_regex_array;
4785 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4787 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4789 PUSHs(matcher_matches_sv(matcher, d)
4792 destroy_matcher(matcher);
4797 /* See if there is overload magic on left */
4798 else if (object_on_left && SvAMAGIC(d)) {
4800 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4801 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4804 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4812 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4815 else if (!SvOK(d)) {
4816 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4817 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4822 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4823 DEBUG_M(if (SvNIOK(e))
4824 Perl_deb(aTHX_ " applying rule Any-Num\n");
4826 Perl_deb(aTHX_ " applying rule Num-numish\n");
4828 /* numeric comparison */
4831 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4832 (void) Perl_pp_i_eq(aTHX);
4834 (void) Perl_pp_eq(aTHX);
4842 /* As a last resort, use string comparison */
4843 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4846 return Perl_pp_seq(aTHX);
4852 register PERL_CONTEXT *cx;
4853 const I32 gimme = GIMME_V;
4855 /* This is essentially an optimization: if the match
4856 fails, we don't want to push a context and then
4857 pop it again right away, so we skip straight
4858 to the op that follows the leavewhen.
4859 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4861 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4862 RETURNOP(cLOGOP->op_other->op_next);
4864 ENTER_with_name("when");
4867 PUSHBLOCK(cx, CXt_WHEN, SP);
4877 register PERL_CONTEXT *cx;
4882 cxix = dopoptogiven(cxstack_ix);
4884 /* diag_listed_as: Can't "when" outside a topicalizer */
4885 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
4886 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
4889 assert(CxTYPE(cx) == CXt_WHEN);
4892 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4893 PL_curpm = newpm; /* pop $1 et al */
4895 LEAVE_with_name("when");
4897 if (cxix < cxstack_ix)
4900 cx = &cxstack[cxix];
4902 if (CxFOREACH(cx)) {
4903 /* clear off anything above the scope we're re-entering */
4904 I32 inner = PL_scopestack_ix;
4907 if (PL_scopestack_ix < inner)
4908 leave_scope(PL_scopestack[PL_scopestack_ix]);
4909 PL_curcop = cx->blk_oldcop;
4911 return cx->blk_loop.my_op->op_nextop;
4914 RETURNOP(cx->blk_givwhen.leave_op);
4921 register PERL_CONTEXT *cx;
4926 PERL_UNUSED_VAR(gimme);
4928 cxix = dopoptowhen(cxstack_ix);
4930 DIE(aTHX_ "Can't \"continue\" outside a when block");
4932 if (cxix < cxstack_ix)
4936 assert(CxTYPE(cx) == CXt_WHEN);
4939 PL_curpm = newpm; /* pop $1 et al */
4941 LEAVE_with_name("when");
4942 RETURNOP(cx->blk_givwhen.leave_op->op_next);
4949 register PERL_CONTEXT *cx;
4951 cxix = dopoptogiven(cxstack_ix);
4953 DIE(aTHX_ "Can't \"break\" outside a given block");
4955 cx = &cxstack[cxix];
4957 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4959 if (cxix < cxstack_ix)
4962 /* Restore the sp at the time we entered the given block */
4965 return cx->blk_givwhen.leave_op;
4969 S_doparseform(pTHX_ SV *sv)
4972 register char *s = SvPV(sv, len);
4973 register char *send;
4974 register char *base = NULL; /* start of current field */
4975 register I32 skipspaces = 0; /* number of contiguous spaces seen */
4976 bool noblank = FALSE; /* ~ or ~~ seen on this line */
4977 bool repeat = FALSE; /* ~~ seen on this line */
4978 bool postspace = FALSE; /* a text field may need right padding */
4981 U32 *linepc = NULL; /* position of last FF_LINEMARK */
4983 bool ischop; /* it's a ^ rather than a @ */
4984 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
4985 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4989 PERL_ARGS_ASSERT_DOPARSEFORM;
4992 Perl_croak(aTHX_ "Null picture in formline");
4994 if (SvTYPE(sv) >= SVt_PVMG) {
4995 /* This might, of course, still return NULL. */
4996 mg = mg_find(sv, PERL_MAGIC_fm);
4998 sv_upgrade(sv, SVt_PVMG);
5002 /* still the same as previously-compiled string? */
5003 SV *old = mg->mg_obj;
5004 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5005 && len == SvCUR(old)
5006 && strnEQ(SvPVX(old), SvPVX(sv), len)
5008 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5012 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5013 Safefree(mg->mg_ptr);
5019 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5020 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5023 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5024 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5028 /* estimate the buffer size needed */
5029 for (base = s; s <= send; s++) {
5030 if (*s == '\n' || *s == '@' || *s == '^')
5036 Newx(fops, maxops, U32);
5041 *fpc++ = FF_LINEMARK;
5042 noblank = repeat = FALSE;
5060 case ' ': case '\t':
5067 } /* else FALL THROUGH */
5075 *fpc++ = FF_LITERAL;
5083 *fpc++ = (U32)skipspaces;
5087 *fpc++ = FF_NEWLINE;
5091 arg = fpc - linepc + 1;
5098 *fpc++ = FF_LINEMARK;
5099 noblank = repeat = FALSE;
5108 ischop = s[-1] == '^';
5114 arg = (s - base) - 1;
5116 *fpc++ = FF_LITERAL;
5122 if (*s == '*') { /* @* or ^* */
5124 *fpc++ = 2; /* skip the @* or ^* */
5126 *fpc++ = FF_LINESNGL;
5129 *fpc++ = FF_LINEGLOB;
5131 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5132 arg = ischop ? FORM_NUM_BLANK : 0;
5137 const char * const f = ++s;
5140 arg |= FORM_NUM_POINT + (s - f);
5142 *fpc++ = s - base; /* fieldsize for FETCH */
5143 *fpc++ = FF_DECIMAL;
5145 unchopnum |= ! ischop;
5147 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5148 arg = ischop ? FORM_NUM_BLANK : 0;
5150 s++; /* skip the '0' first */
5154 const char * const f = ++s;
5157 arg |= FORM_NUM_POINT + (s - f);
5159 *fpc++ = s - base; /* fieldsize for FETCH */
5160 *fpc++ = FF_0DECIMAL;
5162 unchopnum |= ! ischop;
5164 else { /* text field */
5166 bool ismore = FALSE;
5169 while (*++s == '>') ;
5170 prespace = FF_SPACE;
5172 else if (*s == '|') {
5173 while (*++s == '|') ;
5174 prespace = FF_HALFSPACE;
5179 while (*++s == '<') ;
5182 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5186 *fpc++ = s - base; /* fieldsize for FETCH */
5188 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5191 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5205 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5208 mg->mg_ptr = (char *) fops;
5209 mg->mg_len = arg * sizeof(U32);
5210 mg->mg_obj = sv_copy;
5211 mg->mg_flags |= MGf_REFCOUNTED;
5213 if (unchopnum && repeat)
5214 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5221 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5223 /* Can value be printed in fldsize chars, using %*.*f ? */
5227 int intsize = fldsize - (value < 0 ? 1 : 0);
5229 if (frcsize & FORM_NUM_POINT)
5231 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5234 while (intsize--) pwr *= 10.0;
5235 while (frcsize--) eps /= 10.0;
5238 if (value + eps >= pwr)
5241 if (value - eps <= -pwr)
5248 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5251 SV * const datasv = FILTER_DATA(idx);
5252 const int filter_has_file = IoLINES(datasv);
5253 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5254 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5259 char *prune_from = NULL;
5260 bool read_from_cache = FALSE;
5264 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5266 assert(maxlen >= 0);
5269 /* I was having segfault trouble under Linux 2.2.5 after a
5270 parse error occured. (Had to hack around it with a test
5271 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5272 not sure where the trouble is yet. XXX */
5275 SV *const cache = datasv;
5278 const char *cache_p = SvPV(cache, cache_len);
5282 /* Running in block mode and we have some cached data already.
5284 if (cache_len >= umaxlen) {
5285 /* In fact, so much data we don't even need to call
5290 const char *const first_nl =
5291 (const char *)memchr(cache_p, '\n', cache_len);
5293 take = first_nl + 1 - cache_p;
5297 sv_catpvn(buf_sv, cache_p, take);
5298 sv_chop(cache, cache_p + take);
5299 /* Definitely not EOF */
5303 sv_catsv(buf_sv, cache);
5305 umaxlen -= cache_len;
5308 read_from_cache = TRUE;
5312 /* Filter API says that the filter appends to the contents of the buffer.
5313 Usually the buffer is "", so the details don't matter. But if it's not,
5314 then clearly what it contains is already filtered by this filter, so we
5315 don't want to pass it in a second time.
5316 I'm going to use a mortal in case the upstream filter croaks. */
5317 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5318 ? sv_newmortal() : buf_sv;
5319 SvUPGRADE(upstream, SVt_PV);
5321 if (filter_has_file) {
5322 status = FILTER_READ(idx+1, upstream, 0);
5325 if (filter_sub && status >= 0) {
5329 ENTER_with_name("call_filter_sub");
5334 DEFSV_set(upstream);
5338 PUSHs(filter_state);
5341 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5349 else if (SvTRUE(ERRSV)) {
5350 err = newSVsv(ERRSV);
5356 LEAVE_with_name("call_filter_sub");
5359 if(!err && SvOK(upstream)) {
5360 got_p = SvPV(upstream, got_len);
5362 if (got_len > umaxlen) {
5363 prune_from = got_p + umaxlen;
5366 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5367 if (first_nl && first_nl + 1 < got_p + got_len) {
5368 /* There's a second line here... */
5369 prune_from = first_nl + 1;
5373 if (!err && prune_from) {
5374 /* Oh. Too long. Stuff some in our cache. */
5375 STRLEN cached_len = got_p + got_len - prune_from;
5376 SV *const cache = datasv;
5379 /* Cache should be empty. */
5380 assert(!SvCUR(cache));
5383 sv_setpvn(cache, prune_from, cached_len);
5384 /* If you ask for block mode, you may well split UTF-8 characters.
5385 "If it breaks, you get to keep both parts"
5386 (Your code is broken if you don't put them back together again
5387 before something notices.) */
5388 if (SvUTF8(upstream)) {
5391 SvCUR_set(upstream, got_len - cached_len);
5393 /* Can't yet be EOF */
5398 /* If they are at EOF but buf_sv has something in it, then they may never
5399 have touched the SV upstream, so it may be undefined. If we naively
5400 concatenate it then we get a warning about use of uninitialised value.
5402 if (!err && upstream != buf_sv &&
5403 (SvOK(upstream) || SvGMAGICAL(upstream))) {
5404 sv_catsv(buf_sv, upstream);
5408 IoLINES(datasv) = 0;
5410 SvREFCNT_dec(filter_state);
5411 IoTOP_GV(datasv) = NULL;
5414 SvREFCNT_dec(filter_sub);
5415 IoBOTTOM_GV(datasv) = NULL;
5417 filter_del(S_run_user_filter);
5423 if (status == 0 && read_from_cache) {
5424 /* If we read some data from the cache (and by getting here it implies
5425 that we emptied the cache) then we aren't yet at EOF, and mustn't
5426 report that to our caller. */
5432 /* perhaps someone can come up with a better name for
5433 this? it is not really "absolute", per se ... */
5435 S_path_is_absolute(const char *name)
5437 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5439 if (PERL_FILE_IS_ABSOLUTE(name)
5441 || (*name == '.' && ((name[1] == '/' ||
5442 (name[1] == '.' && name[2] == '/'))
5443 || (name[1] == '\\' ||
5444 ( name[1] == '.' && name[2] == '\\')))
5447 || (*name == '.' && (name[1] == '/' ||
5448 (name[1] == '.' && name[2] == '/')))
5460 * c-indentation-style: bsd
5462 * indent-tabs-mode: nil
5465 * ex: set ts=8 sts=4 sw=4 et: