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) {
72 /* XXXX Should store the old value to allow for tie/overload - and
73 restore in regcomp, where marked with XXXX. */
83 register PMOP *pm = (PMOP*)cLOGOP->op_other;
87 /* prevent recompiling under /o and ithreads. */
88 #if defined(USE_ITHREADS)
89 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
90 if (PL_op->op_flags & OPf_STACKED) {
100 #define tryAMAGICregexp(rx) \
103 if (SvROK(rx) && SvAMAGIC(rx)) { \
104 SV *sv = AMG_CALLunary(rx, regexp_amg); \
108 if (SvTYPE(sv) != SVt_REGEXP) \
109 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
116 if (PL_op->op_flags & OPf_STACKED) {
117 /* multiple args; concatenate them */
119 tmpstr = PAD_SV(ARGTARG);
120 sv_setpvs(tmpstr, "");
121 while (++MARK <= SP) {
125 tryAMAGICregexp(msv);
127 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
128 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
130 sv_setsv(tmpstr, sv);
133 sv_catsv_nomg(tmpstr, msv);
140 tryAMAGICregexp(tmpstr);
143 #undef tryAMAGICregexp
146 SV * const sv = SvRV(tmpstr);
147 if (SvTYPE(sv) == SVt_REGEXP)
150 else if (SvTYPE(tmpstr) == SVt_REGEXP)
151 re = (REGEXP*) tmpstr;
154 /* The match's LHS's get-magic might need to access this op's reg-
155 exp (as is sometimes the case with $'; see bug 70764). So we
156 must call get-magic now before we replace the regexp. Hopeful-
157 ly this hack can be replaced with the approach described at
158 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
159 /msg122415.html some day. */
160 if(pm->op_type == OP_MATCH) {
162 const bool was_tainted = PL_tainted;
163 if (pm->op_flags & OPf_STACKED)
165 else if (pm->op_private & OPpTARGET_MY)
166 lhs = PAD_SV(pm->op_targ);
169 /* Restore the previous value of PL_tainted (which may have been
170 modified by get-magic), to avoid incorrectly setting the
171 RXf_TAINTED flag further down. */
172 PL_tainted = was_tainted;
175 re = reg_temp_copy(NULL, re);
176 ReREFCNT_dec(PM_GETRE(pm));
181 const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
184 assert (re != (REGEXP*) &PL_sv_undef);
186 /* Check against the last compiled regexp. */
187 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
188 memNE(RX_PRECOMP(re), t, len))
190 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
191 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
195 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
197 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
199 } else if (PL_curcop->cop_hints_hash) {
200 SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
201 if (ptr && SvIOK(ptr) && SvIV(ptr))
202 eng = INT2PTR(regexp_engine*,SvIV(ptr));
205 if (PL_op->op_flags & OPf_SPECIAL)
206 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
208 if (DO_UTF8(tmpstr)) {
209 assert (SvUTF8(tmpstr));
210 } else if (SvUTF8(tmpstr)) {
211 /* Not doing UTF-8, despite what the SV says. Is this only if
212 we're trapped in use 'bytes'? */
213 /* Make a copy of the octet sequence, but without the flag on,
214 as the compiler now honours the SvUTF8 flag on tmpstr. */
216 const char *const p = SvPV(tmpstr, len);
217 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
219 else if (SvAMAGIC(tmpstr)) {
220 /* make a copy to avoid extra stringifies */
221 tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
224 /* If it is gmagical, create a mortal copy, but without calling
225 get-magic, as we have already done that. */
226 if(SvGMAGICAL(tmpstr)) {
227 SV *mortalcopy = sv_newmortal();
228 sv_setsv_flags(mortalcopy, tmpstr, 0);
233 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
235 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
237 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
238 inside tie/overload accessors. */
244 #ifndef INCOMPLETE_TAINTS
247 SvTAINTED_on((SV*)re);
248 RX_EXTFLAGS(re) |= RXf_TAINTED;
253 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
257 #if !defined(USE_ITHREADS)
258 /* can't change the optree at runtime either */
259 /* PMf_KEEP is handled differently under threads to avoid these problems */
260 if (pm->op_pmflags & PMf_KEEP) {
261 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
262 cLOGOP->op_first->op_next = PL_op->op_next;
272 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
273 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
274 register SV * const dstr = cx->sb_dstr;
275 register char *s = cx->sb_s;
276 register char *m = cx->sb_m;
277 char *orig = cx->sb_orig;
278 register REGEXP * const rx = cx->sb_rx;
280 REGEXP *old = PM_GETRE(pm);
287 PM_SETRE(pm,ReREFCNT_inc(rx));
290 rxres_restore(&cx->sb_rxres, rx);
291 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
293 if (cx->sb_iters++) {
294 const I32 saviters = cx->sb_iters;
295 if (cx->sb_iters > cx->sb_maxiters)
296 DIE(aTHX_ "Substitution loop");
298 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
300 /* See "how taint works" above pp_subst() */
302 cx->sb_rxtainted |= SUBST_TAINT_REPL;
303 sv_catsv_nomg(dstr, POPs);
304 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
308 /* I believe that we can't set REXEC_SCREAM here if
309 SvSCREAM(cx->sb_targ) is true because SvPVX(cx->sb_targ) isn't always
310 equal to s. [See the comment before Perl_re_intuit_start(), which is
311 called from Perl_regexec_flags(), which says that it should be when
312 SvSCREAM() is true.] s, cx->sb_strend and orig will be consistent
313 with SvPVX(cx->sb_targ), as substconst doesn't modify cx->sb_targ
315 if (CxONCE(cx) || s < orig ||
316 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
317 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
318 ((cx->sb_rflags & REXEC_COPY_STR)
319 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
320 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
322 SV *targ = cx->sb_targ;
324 assert(cx->sb_strend >= s);
325 if(cx->sb_strend > s) {
326 if (DO_UTF8(dstr) && !SvUTF8(targ))
327 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
329 sv_catpvn(dstr, s, cx->sb_strend - s);
331 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
332 cx->sb_rxtainted |= SUBST_TAINT_PAT;
334 if (pm->op_pmflags & PMf_NONDESTRUCT) {
336 /* From here on down we're using the copy, and leaving the
337 original untouched. */
341 #ifdef PERL_OLD_COPY_ON_WRITE
343 sv_force_normal_flags(targ, SV_COW_DROP_PV);
349 SvPV_set(targ, SvPVX(dstr));
350 SvCUR_set(targ, SvCUR(dstr));
351 SvLEN_set(targ, SvLEN(dstr));
354 SvPV_set(dstr, NULL);
356 mPUSHi(saviters - 1);
358 (void)SvPOK_only_UTF8(targ);
361 /* update the taint state of various various variables in
362 * preparation for final exit.
363 * See "how taint works" above pp_subst() */
365 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
366 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
367 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
369 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
371 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
372 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
374 SvTAINTED_on(TOPs); /* taint return value */
375 /* needed for mg_set below */
376 PL_tainted = cBOOL(cx->sb_rxtainted &
377 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
380 /* PL_tainted must be correctly set for this mg_set */
383 LEAVE_SCOPE(cx->sb_oldsave);
385 RETURNOP(pm->op_next);
388 cx->sb_iters = saviters;
390 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
393 cx->sb_orig = orig = RX_SUBBEG(rx);
395 cx->sb_strend = s + (cx->sb_strend - m);
397 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
399 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
400 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
402 sv_catpvn(dstr, s, m-s);
404 cx->sb_s = RX_OFFS(rx)[0].end + orig;
405 { /* Update the pos() information. */
407 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
409 SvUPGRADE(sv, SVt_PVMG);
410 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
411 #ifdef PERL_OLD_COPY_ON_WRITE
413 sv_force_normal_flags(sv, 0);
415 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
418 mg->mg_len = m - orig;
421 (void)ReREFCNT_inc(rx);
422 /* update the taint state of various various variables in preparation
423 * for calling the code block.
424 * See "how taint works" above pp_subst() */
426 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
427 cx->sb_rxtainted |= SUBST_TAINT_PAT;
429 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
430 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
431 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
433 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
435 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
436 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
437 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
438 ? cx->sb_dstr : cx->sb_targ);
441 rxres_save(&cx->sb_rxres, rx);
443 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
447 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
452 PERL_ARGS_ASSERT_RXRES_SAVE;
455 if (!p || p[1] < RX_NPARENS(rx)) {
456 #ifdef PERL_OLD_COPY_ON_WRITE
457 i = 7 + RX_NPARENS(rx) * 2;
459 i = 6 + RX_NPARENS(rx) * 2;
468 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
469 RX_MATCH_COPIED_off(rx);
471 #ifdef PERL_OLD_COPY_ON_WRITE
472 *p++ = PTR2UV(RX_SAVED_COPY(rx));
473 RX_SAVED_COPY(rx) = NULL;
476 *p++ = RX_NPARENS(rx);
478 *p++ = PTR2UV(RX_SUBBEG(rx));
479 *p++ = (UV)RX_SUBLEN(rx);
480 for (i = 0; i <= RX_NPARENS(rx); ++i) {
481 *p++ = (UV)RX_OFFS(rx)[i].start;
482 *p++ = (UV)RX_OFFS(rx)[i].end;
487 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
492 PERL_ARGS_ASSERT_RXRES_RESTORE;
495 RX_MATCH_COPY_FREE(rx);
496 RX_MATCH_COPIED_set(rx, *p);
499 #ifdef PERL_OLD_COPY_ON_WRITE
500 if (RX_SAVED_COPY(rx))
501 SvREFCNT_dec (RX_SAVED_COPY(rx));
502 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
506 RX_NPARENS(rx) = *p++;
508 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
509 RX_SUBLEN(rx) = (I32)(*p++);
510 for (i = 0; i <= RX_NPARENS(rx); ++i) {
511 RX_OFFS(rx)[i].start = (I32)(*p++);
512 RX_OFFS(rx)[i].end = (I32)(*p++);
517 S_rxres_free(pTHX_ void **rsp)
519 UV * const p = (UV*)*rsp;
521 PERL_ARGS_ASSERT_RXRES_FREE;
526 void *tmp = INT2PTR(char*,*p);
529 PoisonFree(*p, 1, sizeof(*p));
531 Safefree(INT2PTR(char*,*p));
533 #ifdef PERL_OLD_COPY_ON_WRITE
535 SvREFCNT_dec (INT2PTR(SV*,p[1]));
543 #define FORM_NUM_BLANK (1<<30)
544 #define FORM_NUM_POINT (1<<29)
548 dVAR; dSP; dMARK; dORIGMARK;
549 register SV * const tmpForm = *++MARK;
550 SV *formsv; /* contains text of original format */
551 register U32 *fpc; /* format ops program counter */
552 register char *t; /* current append position in target string */
553 const char *f; /* current position in format string */
555 register SV *sv = NULL; /* current item */
556 const char *item = NULL;/* string value of current item */
557 I32 itemsize = 0; /* length of current item, possibly truncated */
558 I32 fieldsize = 0; /* width of current field */
559 I32 lines = 0; /* number of lines that have been output */
560 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
561 const char *chophere = NULL; /* where to chop current item */
562 STRLEN linemark = 0; /* pos of start of line in output */
564 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
566 STRLEN linemax; /* estimate of output size in bytes */
567 bool item_is_utf8 = FALSE;
568 bool targ_is_utf8 = FALSE;
571 U8 *source; /* source of bytes to append */
572 STRLEN to_copy; /* how may bytes to append */
573 char trans; /* what chars to translate */
575 mg = doparseform(tmpForm);
577 fpc = (U32*)mg->mg_ptr;
578 /* the actual string the format was compiled from.
579 * with overload etc, this may not match tmpForm */
583 SvPV_force(PL_formtarget, len);
584 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
585 SvTAINTED_on(PL_formtarget);
586 if (DO_UTF8(PL_formtarget))
588 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
589 t = SvGROW(PL_formtarget, len + linemax + 1);
590 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
592 f = SvPV_const(formsv, len);
596 const char *name = "???";
599 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
600 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
601 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
602 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
603 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
605 case FF_CHECKNL: name = "CHECKNL"; break;
606 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
607 case FF_SPACE: name = "SPACE"; break;
608 case FF_HALFSPACE: name = "HALFSPACE"; break;
609 case FF_ITEM: name = "ITEM"; break;
610 case FF_CHOP: name = "CHOP"; break;
611 case FF_LINEGLOB: name = "LINEGLOB"; break;
612 case FF_NEWLINE: name = "NEWLINE"; break;
613 case FF_MORE: name = "MORE"; break;
614 case FF_LINEMARK: name = "LINEMARK"; break;
615 case FF_END: name = "END"; break;
616 case FF_0DECIMAL: name = "0DECIMAL"; break;
617 case FF_LINESNGL: name = "LINESNGL"; break;
620 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
622 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
626 linemark = t - SvPVX(PL_formtarget);
636 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
652 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
655 SvTAINTED_on(PL_formtarget);
661 const char *s = item = SvPV_const(sv, len);
664 itemsize = sv_len_utf8(sv);
665 if (itemsize != (I32)len) {
667 if (itemsize > fieldsize) {
668 itemsize = fieldsize;
669 itembytes = itemsize;
670 sv_pos_u2b(sv, &itembytes, 0);
674 send = chophere = s + itembytes;
684 sv_pos_b2u(sv, &itemsize);
688 item_is_utf8 = FALSE;
689 if (itemsize > fieldsize)
690 itemsize = fieldsize;
691 send = chophere = s + itemsize;
705 const char *s = item = SvPV_const(sv, len);
708 itemsize = sv_len_utf8(sv);
709 if (itemsize != (I32)len) {
711 if (itemsize <= fieldsize) {
712 const char *send = chophere = s + itemsize;
725 itemsize = fieldsize;
726 itembytes = itemsize;
727 sv_pos_u2b(sv, &itembytes, 0);
728 send = chophere = s + itembytes;
729 while (s < send || (s == send && isSPACE(*s))) {
739 if (strchr(PL_chopset, *s))
744 itemsize = chophere - item;
745 sv_pos_b2u(sv, &itemsize);
751 item_is_utf8 = FALSE;
752 if (itemsize <= fieldsize) {
753 const char *const send = chophere = s + itemsize;
766 itemsize = fieldsize;
767 send = chophere = s + itemsize;
768 while (s < send || (s == send && isSPACE(*s))) {
778 if (strchr(PL_chopset, *s))
783 itemsize = chophere - item;
789 arg = fieldsize - itemsize;
798 arg = fieldsize - itemsize;
812 /* convert to_copy from chars to bytes */
816 to_copy = s - source;
822 const char *s = chophere;
836 const bool oneline = fpc[-1] == FF_LINESNGL;
837 const char *s = item = SvPV_const(sv, len);
838 const char *const send = s + len;
840 item_is_utf8 = DO_UTF8(sv);
851 to_copy = s - SvPVX_const(sv) - 1;
865 /* append to_copy bytes from source to PL_formstring.
866 * item_is_utf8 implies source is utf8.
867 * if trans, translate certain characters during the copy */
872 SvCUR_set(PL_formtarget,
873 t - SvPVX_const(PL_formtarget));
875 if (targ_is_utf8 && !item_is_utf8) {
876 source = tmp = bytes_to_utf8(source, &to_copy);
878 if (item_is_utf8 && !targ_is_utf8) {
880 /* Upgrade targ to UTF8, and then we reduce it to
881 a problem we have a simple solution for.
882 Don't need get magic. */
883 sv_utf8_upgrade_nomg(PL_formtarget);
885 /* re-calculate linemark */
886 s = (U8*)SvPVX(PL_formtarget);
887 /* the bytes we initially allocated to append the
888 * whole line may have been gobbled up during the
889 * upgrade, so allocate a whole new line's worth
894 linemark = s - (U8*)SvPVX(PL_formtarget);
896 /* Easy. They agree. */
897 assert (item_is_utf8 == targ_is_utf8);
900 /* @* and ^* are the only things that can exceed
901 * the linemax, so grow by the output size, plus
902 * a whole new form's worth in case of any further
904 grow = linemax + to_copy;
906 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
907 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
909 Copy(source, t, to_copy, char);
911 /* blank out ~ or control chars, depending on trans.
912 * works on bytes not chars, so relies on not
913 * matching utf8 continuation bytes */
915 U8 *send = s + to_copy;
918 if (trans == '~' ? (ch == '~') :
931 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
939 #if defined(USE_LONG_DOUBLE)
941 ((arg & FORM_NUM_POINT) ?
942 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
945 ((arg & FORM_NUM_POINT) ?
946 "%#0*.*f" : "%0*.*f");
951 #if defined(USE_LONG_DOUBLE)
953 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
956 ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
959 /* If the field is marked with ^ and the value is undefined,
961 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
969 /* overflow evidence */
970 if (num_overflow(value, fieldsize, arg)) {
976 /* Formats aren't yet marked for locales, so assume "yes". */
978 STORE_NUMERIC_STANDARD_SET_LOCAL();
979 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
980 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
981 RESTORE_NUMERIC_STANDARD();
988 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
996 if (arg) { /* repeat until fields exhausted? */
1002 t = SvPVX(PL_formtarget) + linemark;
1009 const char *s = chophere;
1010 const char *send = item + len;
1012 while (isSPACE(*s) && (s < send))
1017 arg = fieldsize - itemsize;
1024 if (strnEQ(s1," ",3)) {
1025 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
1036 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
1038 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1040 SvUTF8_on(PL_formtarget);
1041 FmLINES(PL_formtarget) += lines;
1043 if (fpc[-1] == FF_BLANK)
1044 RETURNOP(cLISTOP->op_first);
1056 if (PL_stack_base + *PL_markstack_ptr == SP) {
1058 if (GIMME_V == G_SCALAR)
1060 RETURNOP(PL_op->op_next->op_next);
1062 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1063 Perl_pp_pushmark(aTHX); /* push dst */
1064 Perl_pp_pushmark(aTHX); /* push src */
1065 ENTER_with_name("grep"); /* enter outer scope */
1068 if (PL_op->op_private & OPpGREP_LEX)
1069 SAVESPTR(PAD_SVl(PL_op->op_targ));
1072 ENTER_with_name("grep_item"); /* enter inner scope */
1075 src = PL_stack_base[*PL_markstack_ptr];
1077 if (PL_op->op_private & OPpGREP_LEX)
1078 PAD_SVl(PL_op->op_targ) = src;
1083 if (PL_op->op_type == OP_MAPSTART)
1084 Perl_pp_pushmark(aTHX); /* push top */
1085 return ((LOGOP*)PL_op->op_next)->op_other;
1091 const I32 gimme = GIMME_V;
1092 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1098 /* first, move source pointer to the next item in the source list */
1099 ++PL_markstack_ptr[-1];
1101 /* if there are new items, push them into the destination list */
1102 if (items && gimme != G_VOID) {
1103 /* might need to make room back there first */
1104 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1105 /* XXX this implementation is very pessimal because the stack
1106 * is repeatedly extended for every set of items. Is possible
1107 * to do this without any stack extension or copying at all
1108 * by maintaining a separate list over which the map iterates
1109 * (like foreach does). --gsar */
1111 /* everything in the stack after the destination list moves
1112 * towards the end the stack by the amount of room needed */
1113 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1115 /* items to shift up (accounting for the moved source pointer) */
1116 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1118 /* This optimization is by Ben Tilly and it does
1119 * things differently from what Sarathy (gsar)
1120 * is describing. The downside of this optimization is
1121 * that leaves "holes" (uninitialized and hopefully unused areas)
1122 * to the Perl stack, but on the other hand this
1123 * shouldn't be a problem. If Sarathy's idea gets
1124 * implemented, this optimization should become
1125 * irrelevant. --jhi */
1127 shift = count; /* Avoid shifting too often --Ben Tilly */
1131 dst = (SP += shift);
1132 PL_markstack_ptr[-1] += shift;
1133 *PL_markstack_ptr += shift;
1137 /* copy the new items down to the destination list */
1138 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1139 if (gimme == G_ARRAY) {
1140 /* add returned items to the collection (making mortal copies
1141 * if necessary), then clear the current temps stack frame
1142 * *except* for those items. We do this splicing the items
1143 * into the start of the tmps frame (so some items may be on
1144 * the tmps stack twice), then moving PL_tmps_floor above
1145 * them, then freeing the frame. That way, the only tmps that
1146 * accumulate over iterations are the return values for map.
1147 * We have to do to this way so that everything gets correctly
1148 * freed if we die during the map.
1152 /* make space for the slice */
1153 EXTEND_MORTAL(items);
1154 tmpsbase = PL_tmps_floor + 1;
1155 Move(PL_tmps_stack + tmpsbase,
1156 PL_tmps_stack + tmpsbase + items,
1157 PL_tmps_ix - PL_tmps_floor,
1159 PL_tmps_ix += items;
1164 sv = sv_mortalcopy(sv);
1166 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1168 /* clear the stack frame except for the items */
1169 PL_tmps_floor += items;
1171 /* FREETMPS may have cleared the TEMP flag on some of the items */
1174 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1177 /* scalar context: we don't care about which values map returns
1178 * (we use undef here). And so we certainly don't want to do mortal
1179 * copies of meaningless values. */
1180 while (items-- > 0) {
1182 *dst-- = &PL_sv_undef;
1190 LEAVE_with_name("grep_item"); /* exit inner scope */
1193 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1195 (void)POPMARK; /* pop top */
1196 LEAVE_with_name("grep"); /* exit outer scope */
1197 (void)POPMARK; /* pop src */
1198 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1199 (void)POPMARK; /* pop dst */
1200 SP = PL_stack_base + POPMARK; /* pop original mark */
1201 if (gimme == G_SCALAR) {
1202 if (PL_op->op_private & OPpGREP_LEX) {
1203 SV* sv = sv_newmortal();
1204 sv_setiv(sv, items);
1212 else if (gimme == G_ARRAY)
1219 ENTER_with_name("grep_item"); /* enter inner scope */
1222 /* set $_ to the new source item */
1223 src = PL_stack_base[PL_markstack_ptr[-1]];
1225 if (PL_op->op_private & OPpGREP_LEX)
1226 PAD_SVl(PL_op->op_targ) = src;
1230 RETURNOP(cLOGOP->op_other);
1239 if (GIMME == G_ARRAY)
1241 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1242 return cLOGOP->op_other;
1252 if (GIMME == G_ARRAY) {
1253 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1257 SV * const targ = PAD_SV(PL_op->op_targ);
1260 if (PL_op->op_private & OPpFLIP_LINENUM) {
1261 if (GvIO(PL_last_in_gv)) {
1262 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1265 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1267 flip = SvIV(sv) == SvIV(GvSV(gv));
1273 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1274 if (PL_op->op_flags & OPf_SPECIAL) {
1282 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1285 sv_setpvs(TARG, "");
1291 /* This code tries to decide if "$left .. $right" should use the
1292 magical string increment, or if the range is numeric (we make
1293 an exception for .."0" [#18165]). AMS 20021031. */
1295 #define RANGE_IS_NUMERIC(left,right) ( \
1296 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1297 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1298 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1299 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1300 && (!SvOK(right) || looks_like_number(right))))
1306 if (GIMME == G_ARRAY) {
1312 if (RANGE_IS_NUMERIC(left,right)) {
1315 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1316 (SvOK(right) && SvNV(right) > IV_MAX))
1317 DIE(aTHX_ "Range iterator outside integer range");
1328 SV * const sv = sv_2mortal(newSViv(i++));
1333 SV * const final = sv_mortalcopy(right);
1335 const char * const tmps = SvPV_const(final, len);
1337 SV *sv = sv_mortalcopy(left);
1338 SvPV_force_nolen(sv);
1339 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1341 if (strEQ(SvPVX_const(sv),tmps))
1343 sv = sv_2mortal(newSVsv(sv));
1350 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1354 if (PL_op->op_private & OPpFLIP_LINENUM) {
1355 if (GvIO(PL_last_in_gv)) {
1356 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1359 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1360 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1368 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1369 sv_catpvs(targ, "E0");
1379 static const char * const context_name[] = {
1381 NULL, /* CXt_WHEN never actually needs "block" */
1382 NULL, /* CXt_BLOCK never actually needs "block" */
1383 NULL, /* CXt_GIVEN never actually needs "block" */
1384 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1385 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1386 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1387 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1395 S_dopoptolabel(pTHX_ const char *label)
1400 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1402 for (i = cxstack_ix; i >= 0; i--) {
1403 register const PERL_CONTEXT * const cx = &cxstack[i];
1404 switch (CxTYPE(cx)) {
1410 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1411 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1412 if (CxTYPE(cx) == CXt_NULL)
1415 case CXt_LOOP_LAZYIV:
1416 case CXt_LOOP_LAZYSV:
1418 case CXt_LOOP_PLAIN:
1420 const char *cx_label = CxLABEL(cx);
1421 if (!cx_label || strNE(label, cx_label) ) {
1422 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1423 (long)i, cx_label));
1426 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1437 Perl_dowantarray(pTHX)
1440 const I32 gimme = block_gimme();
1441 return (gimme == G_VOID) ? G_SCALAR : gimme;
1445 Perl_block_gimme(pTHX)
1448 const I32 cxix = dopoptosub(cxstack_ix);
1452 switch (cxstack[cxix].blk_gimme) {
1460 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1467 Perl_is_lvalue_sub(pTHX)
1470 const I32 cxix = dopoptosub(cxstack_ix);
1471 assert(cxix >= 0); /* We should only be called from inside subs */
1473 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1474 return CxLVAL(cxstack + cxix);
1479 /* only used by PUSHSUB */
1481 Perl_was_lvalue_sub(pTHX)
1484 const I32 cxix = dopoptosub(cxstack_ix-1);
1485 assert(cxix >= 0); /* We should only be called from inside subs */
1487 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1488 return CxLVAL(cxstack + cxix);
1494 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1499 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1501 for (i = startingblock; i >= 0; i--) {
1502 register const PERL_CONTEXT * const cx = &cxstk[i];
1503 switch (CxTYPE(cx)) {
1509 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1517 S_dopoptoeval(pTHX_ I32 startingblock)
1521 for (i = startingblock; i >= 0; i--) {
1522 register const PERL_CONTEXT *cx = &cxstack[i];
1523 switch (CxTYPE(cx)) {
1527 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1535 S_dopoptoloop(pTHX_ I32 startingblock)
1539 for (i = startingblock; i >= 0; i--) {
1540 register const PERL_CONTEXT * const cx = &cxstack[i];
1541 switch (CxTYPE(cx)) {
1547 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1548 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1549 if ((CxTYPE(cx)) == CXt_NULL)
1552 case CXt_LOOP_LAZYIV:
1553 case CXt_LOOP_LAZYSV:
1555 case CXt_LOOP_PLAIN:
1556 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1564 S_dopoptogiven(pTHX_ I32 startingblock)
1568 for (i = startingblock; i >= 0; i--) {
1569 register const PERL_CONTEXT *cx = &cxstack[i];
1570 switch (CxTYPE(cx)) {
1574 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1576 case CXt_LOOP_PLAIN:
1577 assert(!CxFOREACHDEF(cx));
1579 case CXt_LOOP_LAZYIV:
1580 case CXt_LOOP_LAZYSV:
1582 if (CxFOREACHDEF(cx)) {
1583 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1592 S_dopoptowhen(pTHX_ I32 startingblock)
1596 for (i = startingblock; i >= 0; i--) {
1597 register const PERL_CONTEXT *cx = &cxstack[i];
1598 switch (CxTYPE(cx)) {
1602 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1610 Perl_dounwind(pTHX_ I32 cxix)
1615 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1618 while (cxstack_ix > cxix) {
1620 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1621 DEBUG_CX("UNWIND"); \
1622 /* Note: we don't need to restore the base context info till the end. */
1623 switch (CxTYPE(cx)) {
1626 continue; /* not break */
1634 case CXt_LOOP_LAZYIV:
1635 case CXt_LOOP_LAZYSV:
1637 case CXt_LOOP_PLAIN:
1648 PERL_UNUSED_VAR(optype);
1652 Perl_qerror(pTHX_ SV *err)
1656 PERL_ARGS_ASSERT_QERROR;
1659 if (PL_in_eval & EVAL_KEEPERR) {
1660 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1661 SvPV_nolen_const(err));
1664 sv_catsv(ERRSV, err);
1667 sv_catsv(PL_errors, err);
1669 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1671 ++PL_parser->error_count;
1675 Perl_die_unwind(pTHX_ SV *msv)
1678 SV *exceptsv = sv_mortalcopy(msv);
1679 U8 in_eval = PL_in_eval;
1680 PERL_ARGS_ASSERT_DIE_UNWIND;
1687 * Historically, perl used to set ERRSV ($@) early in the die
1688 * process and rely on it not getting clobbered during unwinding.
1689 * That sucked, because it was liable to get clobbered, so the
1690 * setting of ERRSV used to emit the exception from eval{} has
1691 * been moved to much later, after unwinding (see just before
1692 * JMPENV_JUMP below). However, some modules were relying on the
1693 * early setting, by examining $@ during unwinding to use it as
1694 * a flag indicating whether the current unwinding was caused by
1695 * an exception. It was never a reliable flag for that purpose,
1696 * being totally open to false positives even without actual
1697 * clobberage, but was useful enough for production code to
1698 * semantically rely on it.
1700 * We'd like to have a proper introspective interface that
1701 * explicitly describes the reason for whatever unwinding
1702 * operations are currently in progress, so that those modules
1703 * work reliably and $@ isn't further overloaded. But we don't
1704 * have one yet. In its absence, as a stopgap measure, ERRSV is
1705 * now *additionally* set here, before unwinding, to serve as the
1706 * (unreliable) flag that it used to.
1708 * This behaviour is temporary, and should be removed when a
1709 * proper way to detect exceptional unwinding has been developed.
1710 * As of 2010-12, the authors of modules relying on the hack
1711 * are aware of the issue, because the modules failed on
1712 * perls 5.13.{1..7} which had late setting of $@ without this
1713 * early-setting hack.
1715 if (!(in_eval & EVAL_KEEPERR)) {
1716 SvTEMP_off(exceptsv);
1717 sv_setsv(ERRSV, exceptsv);
1720 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1721 && PL_curstackinfo->si_prev)
1730 register PERL_CONTEXT *cx;
1733 JMPENV *restartjmpenv;
1736 if (cxix < cxstack_ix)
1739 POPBLOCK(cx,PL_curpm);
1740 if (CxTYPE(cx) != CXt_EVAL) {
1742 const char* message = SvPVx_const(exceptsv, msglen);
1743 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1744 PerlIO_write(Perl_error_log, message, msglen);
1748 namesv = cx->blk_eval.old_namesv;
1749 oldcop = cx->blk_oldcop;
1750 restartjmpenv = cx->blk_eval.cur_top_env;
1751 restartop = cx->blk_eval.retop;
1753 if (gimme == G_SCALAR)
1754 *++newsp = &PL_sv_undef;
1755 PL_stack_sp = newsp;
1759 /* LEAVE could clobber PL_curcop (see save_re_context())
1760 * XXX it might be better to find a way to avoid messing with
1761 * PL_curcop in save_re_context() instead, but this is a more
1762 * minimal fix --GSAR */
1765 if (optype == OP_REQUIRE) {
1766 const char* const msg = SvPVx_nolen_const(exceptsv);
1767 (void)hv_store(GvHVn(PL_incgv),
1768 SvPVX_const(namesv), SvCUR(namesv),
1770 /* note that unlike pp_entereval, pp_require isn't
1771 * supposed to trap errors. So now that we've popped the
1772 * EVAL that pp_require pushed, and processed the error
1773 * message, rethrow the error */
1774 Perl_croak(aTHX_ "%sCompilation failed in require",
1775 *msg ? msg : "Unknown error\n");
1777 if (in_eval & EVAL_KEEPERR) {
1778 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1779 SvPV_nolen_const(exceptsv));
1782 sv_setsv(ERRSV, exceptsv);
1784 PL_restartjmpenv = restartjmpenv;
1785 PL_restartop = restartop;
1791 write_to_stderr(exceptsv);
1798 dVAR; dSP; dPOPTOPssrl;
1799 if (SvTRUE(left) != SvTRUE(right))
1806 =for apidoc caller_cx
1808 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1809 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1810 information returned to Perl by C<caller>. Note that XSUBs don't get a
1811 stack frame, so C<caller_cx(0, NULL)> will return information for the
1812 immediately-surrounding Perl code.
1814 This function skips over the automatic calls to C<&DB::sub> made on the
1815 behalf of the debugger. If the stack frame requested was a sub called by
1816 C<DB::sub>, the return value will be the frame for the call to
1817 C<DB::sub>, since that has the correct line number/etc. for the call
1818 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1819 frame for the sub call itself.
1824 const PERL_CONTEXT *
1825 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1827 register I32 cxix = dopoptosub(cxstack_ix);
1828 register const PERL_CONTEXT *cx;
1829 register const PERL_CONTEXT *ccstack = cxstack;
1830 const PERL_SI *top_si = PL_curstackinfo;
1833 /* we may be in a higher stacklevel, so dig down deeper */
1834 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1835 top_si = top_si->si_prev;
1836 ccstack = top_si->si_cxstack;
1837 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1841 /* caller() should not report the automatic calls to &DB::sub */
1842 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1843 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1847 cxix = dopoptosub_at(ccstack, cxix - 1);
1850 cx = &ccstack[cxix];
1851 if (dbcxp) *dbcxp = cx;
1853 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1854 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1855 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1856 field below is defined for any cx. */
1857 /* caller() should not report the automatic calls to &DB::sub */
1858 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1859 cx = &ccstack[dbcxix];
1869 register const PERL_CONTEXT *cx;
1870 const PERL_CONTEXT *dbcx;
1872 const char *stashname;
1874 bool has_arg = MAXARG && TOPs;
1882 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1884 if (GIMME != G_ARRAY) {
1891 stashname = CopSTASHPV(cx->blk_oldcop);
1892 if (GIMME != G_ARRAY) {
1895 PUSHs(&PL_sv_undef);
1898 sv_setpv(TARG, stashname);
1907 PUSHs(&PL_sv_undef);
1909 mPUSHs(newSVpv(stashname, 0));
1910 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1911 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1914 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1915 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1916 /* So is ccstack[dbcxix]. */
1918 SV * const sv = newSV(0);
1919 gv_efullname3(sv, cvgv, NULL);
1921 PUSHs(boolSV(CxHASARGS(cx)));
1924 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1925 PUSHs(boolSV(CxHASARGS(cx)));
1929 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1932 gimme = (I32)cx->blk_gimme;
1933 if (gimme == G_VOID)
1934 PUSHs(&PL_sv_undef);
1936 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1937 if (CxTYPE(cx) == CXt_EVAL) {
1939 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1940 PUSHs(cx->blk_eval.cur_text);
1944 else if (cx->blk_eval.old_namesv) {
1945 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1948 /* eval BLOCK (try blocks have old_namesv == 0) */
1950 PUSHs(&PL_sv_undef);
1951 PUSHs(&PL_sv_undef);
1955 PUSHs(&PL_sv_undef);
1956 PUSHs(&PL_sv_undef);
1958 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1959 && CopSTASH_eq(PL_curcop, PL_debstash))
1961 AV * const ary = cx->blk_sub.argarray;
1962 const int off = AvARRAY(ary) - AvALLOC(ary);
1964 Perl_init_dbargs(aTHX);
1966 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1967 av_extend(PL_dbargs, AvFILLp(ary) + off);
1968 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1969 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1971 /* XXX only hints propagated via op_private are currently
1972 * visible (others are not easily accessible, since they
1973 * use the global PL_hints) */
1974 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1977 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1979 if (old_warnings == pWARN_NONE ||
1980 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1981 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1982 else if (old_warnings == pWARN_ALL ||
1983 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1984 /* Get the bit mask for $warnings::Bits{all}, because
1985 * it could have been extended by warnings::register */
1987 HV * const bits = get_hv("warnings::Bits", 0);
1988 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1989 mask = newSVsv(*bits_all);
1992 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1996 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
2000 PUSHs(cx->blk_oldcop->cop_hints_hash ?
2001 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2010 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
2011 sv_reset(tmps, CopSTASH(PL_curcop));
2016 /* like pp_nextstate, but used instead when the debugger is active */
2021 PL_curcop = (COP*)PL_op;
2022 TAINT_NOT; /* Each statement is presumed innocent */
2023 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
2028 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2029 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
2032 register PERL_CONTEXT *cx;
2033 const I32 gimme = G_ARRAY;
2035 GV * const gv = PL_DBgv;
2036 register CV * const cv = GvCV(gv);
2039 DIE(aTHX_ "No DB::DB routine defined");
2041 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2042 /* don't do recursive DB::DB call */
2057 (void)(*CvXSUB(cv))(aTHX_ cv);
2064 PUSHBLOCK(cx, CXt_SUB, SP);
2066 cx->blk_sub.retop = PL_op->op_next;
2069 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
2070 RETURNOP(CvSTART(cv));
2078 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
2080 PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2082 if (gimme == G_SCALAR) {
2084 *++newsp = (SvFLAGS(*SP) & flags) ? *SP : sv_mortalcopy(*SP);
2086 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2089 *++MARK = &PL_sv_undef;
2093 else if (gimme == G_ARRAY) {
2094 /* in case LEAVE wipes old return values */
2095 while (++MARK <= SP) {
2096 if (SvFLAGS(*MARK) & flags)
2099 *++newsp = sv_mortalcopy(*MARK);
2100 TAINT_NOT; /* Each item is independent */
2103 /* When this function was called with MARK == newsp, we reach this
2104 * point with SP == newsp. */
2113 register PERL_CONTEXT *cx;
2114 I32 gimme = GIMME_V;
2116 ENTER_with_name("block");
2119 PUSHBLOCK(cx, CXt_BLOCK, SP);
2127 register PERL_CONTEXT *cx;
2132 if (PL_op->op_flags & OPf_SPECIAL) {
2133 cx = &cxstack[cxstack_ix];
2134 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2139 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2142 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
2143 PL_curpm = newpm; /* Don't pop $1 et al till now */
2145 LEAVE_with_name("block");
2153 register PERL_CONTEXT *cx;
2154 const I32 gimme = GIMME_V;
2155 void *itervar; /* location of the iteration variable */
2156 U8 cxtype = CXt_LOOP_FOR;
2158 ENTER_with_name("loop1");
2161 if (PL_op->op_targ) { /* "my" variable */
2162 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2163 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2164 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2165 SVs_PADSTALE, SVs_PADSTALE);
2167 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2169 itervar = PL_comppad;
2171 itervar = &PAD_SVl(PL_op->op_targ);
2174 else { /* symbol table variable */
2175 GV * const gv = MUTABLE_GV(POPs);
2176 SV** svp = &GvSV(gv);
2177 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2179 itervar = (void *)gv;
2182 if (PL_op->op_private & OPpITER_DEF)
2183 cxtype |= CXp_FOR_DEF;
2185 ENTER_with_name("loop2");
2187 PUSHBLOCK(cx, cxtype, SP);
2188 PUSHLOOP_FOR(cx, itervar, MARK);
2189 if (PL_op->op_flags & OPf_STACKED) {
2190 SV *maybe_ary = POPs;
2191 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2193 SV * const right = maybe_ary;
2196 if (RANGE_IS_NUMERIC(sv,right)) {
2197 cx->cx_type &= ~CXTYPEMASK;
2198 cx->cx_type |= CXt_LOOP_LAZYIV;
2199 /* Make sure that no-one re-orders cop.h and breaks our
2201 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2202 #ifdef NV_PRESERVES_UV
2203 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
2204 (SvNV(sv) > (NV)IV_MAX)))
2206 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
2207 (SvNV(right) < (NV)IV_MIN))))
2209 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
2212 ((SvUV(sv) > (UV)IV_MAX) ||
2213 (SvNV(sv) > (NV)UV_MAX)))))
2215 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
2217 ((SvNV(right) > 0) &&
2218 ((SvUV(right) > (UV)IV_MAX) ||
2219 (SvNV(right) > (NV)UV_MAX))))))
2221 DIE(aTHX_ "Range iterator outside integer range");
2222 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
2223 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
2225 /* for correct -Dstv display */
2226 cx->blk_oldsp = sp - PL_stack_base;
2230 cx->cx_type &= ~CXTYPEMASK;
2231 cx->cx_type |= CXt_LOOP_LAZYSV;
2232 /* Make sure that no-one re-orders cop.h and breaks our
2234 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2235 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2236 cx->blk_loop.state_u.lazysv.end = right;
2237 SvREFCNT_inc(right);
2238 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2239 /* This will do the upgrade to SVt_PV, and warn if the value
2240 is uninitialised. */
2241 (void) SvPV_nolen_const(right);
2242 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2243 to replace !SvOK() with a pointer to "". */
2245 SvREFCNT_dec(right);
2246 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2250 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2251 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2252 SvREFCNT_inc(maybe_ary);
2253 cx->blk_loop.state_u.ary.ix =
2254 (PL_op->op_private & OPpITER_REVERSED) ?
2255 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2259 else { /* iterating over items on the stack */
2260 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2261 if (PL_op->op_private & OPpITER_REVERSED) {
2262 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2265 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2275 register PERL_CONTEXT *cx;
2276 const I32 gimme = GIMME_V;
2278 ENTER_with_name("loop1");
2280 ENTER_with_name("loop2");
2282 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2283 PUSHLOOP_PLAIN(cx, SP);
2291 register PERL_CONTEXT *cx;
2298 assert(CxTYPE_is_LOOP(cx));
2300 newsp = PL_stack_base + cx->blk_loop.resetsp;
2303 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
2306 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2307 PL_curpm = newpm; /* ... and pop $1 et al */
2309 LEAVE_with_name("loop2");
2310 LEAVE_with_name("loop1");
2316 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2317 PERL_CONTEXT *cx, PMOP *newpm)
2319 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2320 if (gimme == G_SCALAR) {
2321 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2323 const char *what = NULL;
2325 assert(MARK+1 == SP);
2326 if ((SvPADTMP(TOPs) ||
2327 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2330 !SvSMAGICAL(TOPs)) {
2332 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2333 : "a readonly value" : "a temporary";
2338 /* sub:lvalue{} will take us here. */
2347 "Can't return %s from lvalue subroutine", what
2352 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2353 *++newsp = SvREFCNT_inc(*SP);
2360 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2365 *++newsp = &PL_sv_undef;
2367 if (CxLVAL(cx) & OPpENTERSUB_DEREF) {
2371 if (cx->blk_sub.retop->op_type == OP_RV2SV)
2372 deref_type = OPpDEREF_SV;
2373 else if (cx->blk_sub.retop->op_type == OP_RV2AV)
2374 deref_type = OPpDEREF_AV;
2376 assert(cx->blk_sub.retop->op_type == OP_RV2HV);
2377 deref_type = OPpDEREF_HV;
2379 TOPs = vivify_ref(TOPs, deref_type);
2383 else if (gimme == G_ARRAY) {
2384 assert (!(CxLVAL(cx) & OPpENTERSUB_DEREF));
2385 if (ref || !CxLVAL(cx))
2386 while (++MARK <= SP)
2390 : ref && SvFLAGS(*MARK) & SVs_PADTMP
2391 ? sv_mortalcopy(*MARK)
2392 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2393 else while (++MARK <= SP) {
2394 if (*MARK != &PL_sv_undef
2396 || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2401 /* Might be flattened array after $#array = */
2409 "Can't return a %s from lvalue subroutine",
2410 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2416 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2419 PL_stack_sp = newsp;
2425 register PERL_CONTEXT *cx;
2426 bool popsub2 = FALSE;
2427 bool clear_errsv = FALSE;
2437 const I32 cxix = dopoptosub(cxstack_ix);
2440 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2441 * sort block, which is a CXt_NULL
2444 PL_stack_base[1] = *PL_stack_sp;
2445 PL_stack_sp = PL_stack_base + 1;
2449 DIE(aTHX_ "Can't return outside a subroutine");
2451 if (cxix < cxstack_ix)
2454 if (CxMULTICALL(&cxstack[cxix])) {
2455 gimme = cxstack[cxix].blk_gimme;
2456 if (gimme == G_VOID)
2457 PL_stack_sp = PL_stack_base;
2458 else if (gimme == G_SCALAR) {
2459 PL_stack_base[1] = *PL_stack_sp;
2460 PL_stack_sp = PL_stack_base + 1;
2466 switch (CxTYPE(cx)) {
2469 lval = !!CvLVALUE(cx->blk_sub.cv);
2470 retop = cx->blk_sub.retop;
2471 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2474 if (!(PL_in_eval & EVAL_KEEPERR))
2477 namesv = cx->blk_eval.old_namesv;
2478 retop = cx->blk_eval.retop;
2481 if (optype == OP_REQUIRE &&
2482 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2484 /* Unassume the success we assumed earlier. */
2485 (void)hv_delete(GvHVn(PL_incgv),
2486 SvPVX_const(namesv), SvCUR(namesv),
2488 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2493 retop = cx->blk_sub.retop;
2496 DIE(aTHX_ "panic: return");
2500 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2502 if (gimme == G_SCALAR) {
2505 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2506 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2507 *++newsp = SvREFCNT_inc(*SP);
2512 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2514 *++newsp = sv_mortalcopy(sv);
2518 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) {
2522 *++newsp = sv_mortalcopy(*SP);
2525 *++newsp = sv_mortalcopy(*SP);
2528 *++newsp = &PL_sv_undef;
2530 else if (gimme == G_ARRAY) {
2531 while (++MARK <= SP) {
2532 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2533 ? *MARK : sv_mortalcopy(*MARK);
2534 TAINT_NOT; /* Each item is independent */
2537 PL_stack_sp = newsp;
2541 /* Stack values are safe: */
2544 POPSUB(cx,sv); /* release CV and @_ ... */
2548 PL_curpm = newpm; /* ... and pop $1 et al */
2557 /* This duplicates parts of pp_leavesub, so that it can share code with
2565 register PERL_CONTEXT *cx;
2568 if (CxMULTICALL(&cxstack[cxstack_ix]))
2572 cxstack_ix++; /* temporarily protect top context */
2573 assert(CvLVALUE(cx->blk_sub.cv));
2577 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2581 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2582 PL_curpm = newpm; /* ... and pop $1 et al */
2585 return cx->blk_sub.retop;
2592 register PERL_CONTEXT *cx;
2603 if (PL_op->op_flags & OPf_SPECIAL) {
2604 cxix = dopoptoloop(cxstack_ix);
2606 DIE(aTHX_ "Can't \"last\" outside a loop block");
2609 cxix = dopoptolabel(cPVOP->op_pv);
2611 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2613 if (cxix < cxstack_ix)
2617 cxstack_ix++; /* temporarily protect top context */
2619 switch (CxTYPE(cx)) {
2620 case CXt_LOOP_LAZYIV:
2621 case CXt_LOOP_LAZYSV:
2623 case CXt_LOOP_PLAIN:
2625 newsp = PL_stack_base + cx->blk_loop.resetsp;
2626 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2630 nextop = cx->blk_sub.retop;
2634 nextop = cx->blk_eval.retop;
2638 nextop = cx->blk_sub.retop;
2641 DIE(aTHX_ "panic: last");
2645 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme,
2646 pop2 == CXt_SUB ? SVs_TEMP : 0);
2651 /* Stack values are safe: */
2653 case CXt_LOOP_LAZYIV:
2654 case CXt_LOOP_PLAIN:
2655 case CXt_LOOP_LAZYSV:
2657 POPLOOP(cx); /* release loop vars ... */
2661 POPSUB(cx,sv); /* release CV and @_ ... */
2664 PL_curpm = newpm; /* ... and pop $1 et al */
2667 PERL_UNUSED_VAR(optype);
2668 PERL_UNUSED_VAR(gimme);
2676 register PERL_CONTEXT *cx;
2679 if (PL_op->op_flags & OPf_SPECIAL) {
2680 cxix = dopoptoloop(cxstack_ix);
2682 DIE(aTHX_ "Can't \"next\" outside a loop block");
2685 cxix = dopoptolabel(cPVOP->op_pv);
2687 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2689 if (cxix < cxstack_ix)
2692 /* clear off anything above the scope we're re-entering, but
2693 * save the rest until after a possible continue block */
2694 inner = PL_scopestack_ix;
2696 if (PL_scopestack_ix < inner)
2697 leave_scope(PL_scopestack[PL_scopestack_ix]);
2698 PL_curcop = cx->blk_oldcop;
2699 return (cx)->blk_loop.my_op->op_nextop;
2706 register PERL_CONTEXT *cx;
2710 if (PL_op->op_flags & OPf_SPECIAL) {
2711 cxix = dopoptoloop(cxstack_ix);
2713 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2716 cxix = dopoptolabel(cPVOP->op_pv);
2718 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2720 if (cxix < cxstack_ix)
2723 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2724 if (redo_op->op_type == OP_ENTER) {
2725 /* pop one less context to avoid $x being freed in while (my $x..) */
2727 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2728 redo_op = redo_op->op_next;
2732 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2733 LEAVE_SCOPE(oldsave);
2735 PL_curcop = cx->blk_oldcop;
2740 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2744 static const char too_deep[] = "Target of goto is too deeply nested";
2746 PERL_ARGS_ASSERT_DOFINDLABEL;
2749 Perl_croak(aTHX_ too_deep);
2750 if (o->op_type == OP_LEAVE ||
2751 o->op_type == OP_SCOPE ||
2752 o->op_type == OP_LEAVELOOP ||
2753 o->op_type == OP_LEAVESUB ||
2754 o->op_type == OP_LEAVETRY)
2756 *ops++ = cUNOPo->op_first;
2758 Perl_croak(aTHX_ too_deep);
2761 if (o->op_flags & OPf_KIDS) {
2763 /* First try all the kids at this level, since that's likeliest. */
2764 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2765 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2766 const char *kid_label = CopLABEL(kCOP);
2767 if (kid_label && strEQ(kid_label, label))
2771 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2772 if (kid == PL_lastgotoprobe)
2774 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2777 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2778 ops[-1]->op_type == OP_DBSTATE)
2783 if ((o = dofindlabel(kid, label, ops, oplimit)))
2796 register PERL_CONTEXT *cx;
2797 #define GOTO_DEPTH 64
2798 OP *enterops[GOTO_DEPTH];
2799 const char *label = NULL;
2800 const bool do_dump = (PL_op->op_type == OP_DUMP);
2801 static const char must_have_label[] = "goto must have label";
2803 if (PL_op->op_flags & OPf_STACKED) {
2804 SV * const sv = POPs;
2806 /* This egregious kludge implements goto &subroutine */
2807 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2809 register PERL_CONTEXT *cx;
2810 CV *cv = MUTABLE_CV(SvRV(sv));
2817 if (!CvROOT(cv) && !CvXSUB(cv)) {
2818 const GV * const gv = CvGV(cv);
2822 /* autoloaded stub? */
2823 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2825 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2826 GvNAMELEN(gv), FALSE);
2827 if (autogv && (cv = GvCV(autogv)))
2829 tmpstr = sv_newmortal();
2830 gv_efullname3(tmpstr, gv, NULL);
2831 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2833 DIE(aTHX_ "Goto undefined subroutine");
2836 /* First do some returnish stuff. */
2837 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2839 cxix = dopoptosub(cxstack_ix);
2841 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2842 if (cxix < cxstack_ix)
2846 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2847 if (CxTYPE(cx) == CXt_EVAL) {
2849 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2851 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2853 else if (CxMULTICALL(cx))
2854 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2855 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2856 /* put @_ back onto stack */
2857 AV* av = cx->blk_sub.argarray;
2859 items = AvFILLp(av) + 1;
2860 EXTEND(SP, items+1); /* @_ could have been extended. */
2861 Copy(AvARRAY(av), SP + 1, items, SV*);
2862 SvREFCNT_dec(GvAV(PL_defgv));
2863 GvAV(PL_defgv) = cx->blk_sub.savearray;
2865 /* abandon @_ if it got reified */
2870 av_extend(av, items-1);
2872 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2875 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2876 AV* const av = GvAV(PL_defgv);
2877 items = AvFILLp(av) + 1;
2878 EXTEND(SP, items+1); /* @_ could have been extended. */
2879 Copy(AvARRAY(av), SP + 1, items, SV*);
2883 if (CxTYPE(cx) == CXt_SUB &&
2884 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2885 SvREFCNT_dec(cx->blk_sub.cv);
2886 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2887 LEAVE_SCOPE(oldsave);
2889 /* Now do some callish stuff. */
2891 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2893 OP* const retop = cx->blk_sub.retop;
2894 SV **newsp __attribute__unused__;
2895 I32 gimme __attribute__unused__;
2898 for (index=0; index<items; index++)
2899 sv_2mortal(SP[-index]);
2902 /* XS subs don't have a CxSUB, so pop it */
2903 POPBLOCK(cx, PL_curpm);
2904 /* Push a mark for the start of arglist */
2907 (void)(*CvXSUB(cv))(aTHX_ cv);
2912 AV* const padlist = CvPADLIST(cv);
2913 if (CxTYPE(cx) == CXt_EVAL) {
2914 PL_in_eval = CxOLD_IN_EVAL(cx);
2915 PL_eval_root = cx->blk_eval.old_eval_root;
2916 cx->cx_type = CXt_SUB;
2918 cx->blk_sub.cv = cv;
2919 cx->blk_sub.olddepth = CvDEPTH(cv);
2922 if (CvDEPTH(cv) < 2)
2923 SvREFCNT_inc_simple_void_NN(cv);
2925 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2926 sub_crush_depth(cv);
2927 pad_push(padlist, CvDEPTH(cv));
2930 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2933 AV *const av = MUTABLE_AV(PAD_SVl(0));
2935 cx->blk_sub.savearray = GvAV(PL_defgv);
2936 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2937 CX_CURPAD_SAVE(cx->blk_sub);
2938 cx->blk_sub.argarray = av;
2940 if (items >= AvMAX(av) + 1) {
2941 SV **ary = AvALLOC(av);
2942 if (AvARRAY(av) != ary) {
2943 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2946 if (items >= AvMAX(av) + 1) {
2947 AvMAX(av) = items - 1;
2948 Renew(ary,items+1,SV*);
2954 Copy(mark,AvARRAY(av),items,SV*);
2955 AvFILLp(av) = items - 1;
2956 assert(!AvREAL(av));
2958 /* transfer 'ownership' of refcnts to new @_ */
2968 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2969 Perl_get_db_sub(aTHX_ NULL, cv);
2971 CV * const gotocv = get_cvs("DB::goto", 0);
2973 PUSHMARK( PL_stack_sp );
2974 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2979 RETURNOP(CvSTART(cv));
2983 label = SvPV_nolen_const(sv);
2984 if (!(do_dump || *label))
2985 DIE(aTHX_ must_have_label);
2988 else if (PL_op->op_flags & OPf_SPECIAL) {
2990 DIE(aTHX_ must_have_label);
2993 label = cPVOP->op_pv;
2997 if (label && *label) {
2998 OP *gotoprobe = NULL;
2999 bool leaving_eval = FALSE;
3000 bool in_block = FALSE;
3001 PERL_CONTEXT *last_eval_cx = NULL;
3005 PL_lastgotoprobe = NULL;
3007 for (ix = cxstack_ix; ix >= 0; ix--) {
3009 switch (CxTYPE(cx)) {
3011 leaving_eval = TRUE;
3012 if (!CxTRYBLOCK(cx)) {
3013 gotoprobe = (last_eval_cx ?
3014 last_eval_cx->blk_eval.old_eval_root :
3019 /* else fall through */
3020 case CXt_LOOP_LAZYIV:
3021 case CXt_LOOP_LAZYSV:
3023 case CXt_LOOP_PLAIN:
3026 gotoprobe = cx->blk_oldcop->op_sibling;
3032 gotoprobe = cx->blk_oldcop->op_sibling;
3035 gotoprobe = PL_main_root;
3038 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3039 gotoprobe = CvROOT(cx->blk_sub.cv);
3045 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3048 DIE(aTHX_ "panic: goto");
3049 gotoprobe = PL_main_root;
3053 retop = dofindlabel(gotoprobe, label,
3054 enterops, enterops + GOTO_DEPTH);
3057 if (gotoprobe->op_sibling &&
3058 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3059 gotoprobe->op_sibling->op_sibling) {
3060 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3061 label, enterops, enterops + GOTO_DEPTH);
3066 PL_lastgotoprobe = gotoprobe;
3069 DIE(aTHX_ "Can't find label %s", label);
3071 /* if we're leaving an eval, check before we pop any frames
3072 that we're not going to punt, otherwise the error
3075 if (leaving_eval && *enterops && enterops[1]) {
3077 for (i = 1; enterops[i]; i++)
3078 if (enterops[i]->op_type == OP_ENTERITER)
3079 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3082 if (*enterops && enterops[1]) {
3083 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3085 deprecate("\"goto\" to jump into a construct");
3088 /* pop unwanted frames */
3090 if (ix < cxstack_ix) {
3097 oldsave = PL_scopestack[PL_scopestack_ix];
3098 LEAVE_SCOPE(oldsave);
3101 /* push wanted frames */
3103 if (*enterops && enterops[1]) {
3104 OP * const oldop = PL_op;
3105 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3106 for (; enterops[ix]; ix++) {
3107 PL_op = enterops[ix];
3108 /* Eventually we may want to stack the needed arguments
3109 * for each op. For now, we punt on the hard ones. */
3110 if (PL_op->op_type == OP_ENTERITER)
3111 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3112 PL_op->op_ppaddr(aTHX);
3120 if (!retop) retop = PL_main_start;
3122 PL_restartop = retop;
3123 PL_do_undump = TRUE;
3127 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3128 PL_do_undump = FALSE;
3143 anum = 0; (void)POPs;
3148 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3150 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3153 PL_exit_flags |= PERL_EXIT_EXPECTED;
3155 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3156 if (anum || !(PL_minus_c && PL_madskills))
3161 PUSHs(&PL_sv_undef);
3168 S_save_lines(pTHX_ AV *array, SV *sv)
3170 const char *s = SvPVX_const(sv);
3171 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3174 PERL_ARGS_ASSERT_SAVE_LINES;
3176 while (s && s < send) {
3178 SV * const tmpstr = newSV_type(SVt_PVMG);
3180 t = (const char *)memchr(s, '\n', send - s);
3186 sv_setpvn(tmpstr, s, t - s);
3187 av_store(array, line++, tmpstr);
3195 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3197 0 is used as continue inside eval,
3199 3 is used for a die caught by an inner eval - continue inner loop
3201 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3202 establish a local jmpenv to handle exception traps.
3207 S_docatch(pTHX_ OP *o)
3211 OP * const oldop = PL_op;
3215 assert(CATCH_GET == TRUE);
3222 assert(cxstack_ix >= 0);
3223 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3224 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3229 /* die caught by an inner eval - continue inner loop */
3230 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3231 PL_restartjmpenv = NULL;
3232 PL_op = PL_restartop;
3248 /* James Bond: Do you expect me to talk?
3249 Auric Goldfinger: No, Mr. Bond. I expect you to die.
3251 This code is an ugly hack, doesn't work with lexicals in subroutines that are
3252 called more than once, and is only used by regcomp.c, for (?{}) blocks.
3254 Currently it is not used outside the core code. Best if it stays that way.
3256 Hence it's now deprecated, and will be removed.
3259 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
3260 /* sv Text to convert to OP tree. */
3261 /* startop op_free() this to undo. */
3262 /* code Short string id of the caller. */
3264 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3265 return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3268 /* Don't use this. It will go away without warning once the regexp engine is
3269 refactored not to use it. */
3271 Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3274 dVAR; dSP; /* Make POPBLOCK work. */
3280 char tbuf[TYPE_DIGITS(long) + 12 + 10];
3281 char *tmpbuf = tbuf;
3284 CV* runcv = NULL; /* initialise to avoid compiler warnings */
3288 PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
3290 ENTER_with_name("eval");
3291 lex_start(sv, NULL, LEX_START_SAME_FILTER);
3293 /* switch to eval mode */
3295 if (IN_PERL_COMPILETIME) {
3296 SAVECOPSTASH_FREE(&PL_compiling);
3297 CopSTASH_set(&PL_compiling, PL_curstash);
3299 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3300 SV * const sv = sv_newmortal();
3301 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3302 code, (unsigned long)++PL_evalseq,
3303 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3308 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3309 (unsigned long)++PL_evalseq);
3310 SAVECOPFILE_FREE(&PL_compiling);
3311 CopFILE_set(&PL_compiling, tmpbuf+2);
3312 SAVECOPLINE(&PL_compiling);
3313 CopLINE_set(&PL_compiling, 1);
3314 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3315 deleting the eval's FILEGV from the stash before gv_check() runs
3316 (i.e. before run-time proper). To work around the coredump that
3317 ensues, we always turn GvMULTI_on for any globals that were
3318 introduced within evals. See force_ident(). GSAR 96-10-12 */
3319 safestr = savepvn(tmpbuf, len);
3320 SAVEDELETE(PL_defstash, safestr, len);
3322 #ifdef OP_IN_REGISTER
3328 /* we get here either during compilation, or via pp_regcomp at runtime */
3329 runtime = IN_PERL_RUNTIME;
3332 runcv = find_runcv(NULL);
3334 /* At run time, we have to fetch the hints from PL_curcop. */
3335 PL_hints = PL_curcop->cop_hints;
3336 if (PL_hints & HINT_LOCALIZE_HH) {
3337 /* SAVEHINTS created a new HV in PL_hintgv, which we
3339 SvREFCNT_dec(GvHV(PL_hintgv));
3341 refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3342 hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3344 SAVECOMPILEWARNINGS();
3345 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3346 cophh_free(CopHINTHASH_get(&PL_compiling));
3347 /* XXX Does this need to avoid copying a label? */
3348 PL_compiling.cop_hints_hash
3349 = cophh_copy(PL_curcop->cop_hints_hash);
3353 PL_op->op_type = OP_ENTEREVAL;
3354 PL_op->op_flags = 0; /* Avoid uninit warning. */
3355 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3357 need_catch = CATCH_GET;
3361 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
3363 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
3364 CATCH_SET(need_catch);
3365 POPBLOCK(cx,PL_curpm);
3368 (*startop)->op_type = OP_NULL;
3369 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3370 /* XXX DAPM do this properly one year */
3371 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3372 LEAVE_with_name("eval");
3373 if (IN_PERL_COMPILETIME)
3374 CopHINTS_set(&PL_compiling, PL_hints);
3375 #ifdef OP_IN_REGISTER
3378 PERL_UNUSED_VAR(newsp);
3379 PERL_UNUSED_VAR(optype);
3381 return PL_eval_start;
3386 =for apidoc find_runcv
3388 Locate the CV corresponding to the currently executing sub or eval.
3389 If db_seqp is non_null, skip CVs that are in the DB package and populate
3390 *db_seqp with the cop sequence number at the point that the DB:: code was
3391 entered. (allows debuggers to eval in the scope of the breakpoint rather
3392 than in the scope of the debugger itself).
3398 Perl_find_runcv(pTHX_ U32 *db_seqp)
3404 *db_seqp = PL_curcop->cop_seq;
3405 for (si = PL_curstackinfo; si; si = si->si_prev) {
3407 for (ix = si->si_cxix; ix >= 0; ix--) {
3408 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3409 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3410 CV * const cv = cx->blk_sub.cv;
3411 /* skip DB:: code */
3412 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3413 *db_seqp = cx->blk_oldcop->cop_seq;
3418 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3426 /* Run yyparse() in a setjmp wrapper. Returns:
3427 * 0: yyparse() successful
3428 * 1: yyparse() failed
3432 S_try_yyparse(pTHX_ int gramtype)
3437 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3441 ret = yyparse(gramtype) ? 1 : 0;
3455 /* Compile a require/do, an eval '', or a /(?{...})/.
3456 * In the last case, startop is non-null, and contains the address of
3457 * a pointer that should be set to the just-compiled code.
3458 * outside is the lexically enclosing CV (if any) that invoked us.
3459 * Returns a bool indicating whether the compile was successful; if so,
3460 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3461 * pushes undef (also croaks if startop != NULL).
3465 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3468 OP * const saveop = PL_op;
3469 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3472 PL_in_eval = (in_require
3473 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3478 SAVESPTR(PL_compcv);
3479 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3480 CvEVAL_on(PL_compcv);
3481 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3482 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3483 cxstack[cxstack_ix].blk_gimme = gimme;
3485 CvOUTSIDE_SEQ(PL_compcv) = seq;
3486 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3488 /* set up a scratch pad */
3490 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3491 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3495 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3497 /* make sure we compile in the right package */
3499 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3500 SAVESPTR(PL_curstash);
3501 PL_curstash = CopSTASH(PL_curcop);
3503 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3504 SAVESPTR(PL_beginav);
3505 PL_beginav = newAV();
3506 SAVEFREESV(PL_beginav);
3507 SAVESPTR(PL_unitcheckav);
3508 PL_unitcheckav = newAV();
3509 SAVEFREESV(PL_unitcheckav);
3512 SAVEBOOL(PL_madskills);
3516 /* try to compile it */
3518 PL_eval_root = NULL;
3519 PL_curcop = &PL_compiling;
3520 CopARYBASE_set(PL_curcop, 0);
3521 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3522 PL_in_eval |= EVAL_KEEPERR;
3526 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3528 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3529 * so honour CATCH_GET and trap it here if necessary */
3531 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3533 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3534 SV **newsp; /* Used by POPBLOCK. */
3536 I32 optype; /* Used by POPEVAL. */
3542 PERL_UNUSED_VAR(newsp);
3543 PERL_UNUSED_VAR(optype);
3545 /* note that if yystatus == 3, then the EVAL CX block has already
3546 * been popped, and various vars restored */
3548 if (yystatus != 3) {
3550 op_free(PL_eval_root);
3551 PL_eval_root = NULL;
3553 SP = PL_stack_base + POPMARK; /* pop original mark */
3555 POPBLOCK(cx,PL_curpm);
3557 namesv = cx->blk_eval.old_namesv;
3561 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3563 msg = SvPVx_nolen_const(ERRSV);
3566 /* If cx is still NULL, it means that we didn't go in the
3567 * POPEVAL branch. */
3568 cx = &cxstack[cxstack_ix];
3569 assert(CxTYPE(cx) == CXt_EVAL);
3570 namesv = cx->blk_eval.old_namesv;
3572 (void)hv_store(GvHVn(PL_incgv),
3573 SvPVX_const(namesv), SvCUR(namesv),
3575 Perl_croak(aTHX_ "%sCompilation failed in require",
3576 *msg ? msg : "Unknown error\n");
3579 if (yystatus != 3) {
3580 POPBLOCK(cx,PL_curpm);
3583 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3584 (*msg ? msg : "Unknown error\n"));
3588 sv_setpvs(ERRSV, "Compilation error");
3591 PUSHs(&PL_sv_undef);
3595 CopLINE_set(&PL_compiling, 0);
3597 *startop = PL_eval_root;
3599 SAVEFREEOP(PL_eval_root);
3601 DEBUG_x(dump_eval());
3603 /* Register with debugger: */
3604 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3605 CV * const cv = get_cvs("DB::postponed", 0);
3609 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3611 call_sv(MUTABLE_SV(cv), G_DISCARD);
3615 if (PL_unitcheckav) {
3616 OP *es = PL_eval_start;
3617 call_list(PL_scopestack_ix, PL_unitcheckav);
3621 /* compiled okay, so do it */
3623 CvDEPTH(PL_compcv) = 1;
3624 SP = PL_stack_base + POPMARK; /* pop original mark */
3625 PL_op = saveop; /* The caller may need it. */
3626 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3633 S_check_type_and_open(pTHX_ SV *name)
3636 const char *p = SvPV_nolen_const(name);
3637 const int st_rc = PerlLIO_stat(p, &st);
3639 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3641 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3645 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3646 return PerlIO_openn(aTHX_ NULL, PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3648 return PerlIO_open(p, PERL_SCRIPT_MODE);
3652 #ifndef PERL_DISABLE_PMC
3654 S_doopen_pm(pTHX_ SV *name)
3657 const char *p = SvPV_const(name, namelen);
3659 PERL_ARGS_ASSERT_DOOPEN_PM;
3661 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3662 SV *const pmcsv = sv_newmortal();
3665 SvSetSV_nosteal(pmcsv,name);
3666 sv_catpvn(pmcsv, "c", 1);
3668 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3669 return check_type_and_open(pmcsv);
3671 return check_type_and_open(name);
3674 # define doopen_pm(name) check_type_and_open(name)
3675 #endif /* !PERL_DISABLE_PMC */
3680 register PERL_CONTEXT *cx;
3687 int vms_unixname = 0;
3689 const char *tryname = NULL;
3691 const I32 gimme = GIMME_V;
3692 int filter_has_file = 0;
3693 PerlIO *tryrsfp = NULL;
3694 SV *filter_cache = NULL;
3695 SV *filter_state = NULL;
3696 SV *filter_sub = NULL;
3702 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3703 sv = sv_2mortal(new_version(sv));
3704 if (!sv_derived_from(PL_patchlevel, "version"))
3705 upg_version(PL_patchlevel, TRUE);
3706 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3707 if ( vcmp(sv,PL_patchlevel) <= 0 )
3708 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3709 SVfARG(sv_2mortal(vnormal(sv))),
3710 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3714 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3717 SV * const req = SvRV(sv);
3718 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3720 /* get the left hand term */
3721 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3723 first = SvIV(*av_fetch(lav,0,0));
3724 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3725 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3726 || av_len(lav) > 1 /* FP with > 3 digits */
3727 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3729 DIE(aTHX_ "Perl %"SVf" required--this is only "
3731 SVfARG(sv_2mortal(vnormal(req))),
3732 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3735 else { /* probably 'use 5.10' or 'use 5.8' */
3740 second = SvIV(*av_fetch(lav,1,0));
3742 second /= second >= 600 ? 100 : 10;
3743 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3744 (int)first, (int)second);
3745 upg_version(hintsv, TRUE);
3747 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3748 "--this is only %"SVf", stopped",
3749 SVfARG(sv_2mortal(vnormal(req))),
3750 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3751 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3759 name = SvPV_const(sv, len);
3760 if (!(name && len > 0 && *name))
3761 DIE(aTHX_ "Null filename used");
3762 TAINT_PROPER("require");
3766 /* The key in the %ENV hash is in the syntax of file passed as the argument
3767 * usually this is in UNIX format, but sometimes in VMS format, which
3768 * can result in a module being pulled in more than once.
3769 * To prevent this, the key must be stored in UNIX format if the VMS
3770 * name can be translated to UNIX.
3772 if ((unixname = tounixspec(name, NULL)) != NULL) {
3773 unixlen = strlen(unixname);
3779 /* if not VMS or VMS name can not be translated to UNIX, pass it
3782 unixname = (char *) name;
3785 if (PL_op->op_type == OP_REQUIRE) {
3786 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3787 unixname, unixlen, 0);
3789 if (*svp != &PL_sv_undef)
3792 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3793 "Compilation failed in require", unixname);
3797 /* prepare to compile file */
3799 if (path_is_absolute(name)) {
3800 /* At this point, name is SvPVX(sv) */
3802 tryrsfp = doopen_pm(sv);
3805 AV * const ar = GvAVn(PL_incgv);
3811 namesv = newSV_type(SVt_PV);
3812 for (i = 0; i <= AvFILL(ar); i++) {
3813 SV * const dirsv = *av_fetch(ar, i, TRUE);
3815 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3822 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3823 && !sv_isobject(loader))
3825 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3828 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3829 PTR2UV(SvRV(dirsv)), name);
3830 tryname = SvPVX_const(namesv);
3833 ENTER_with_name("call_INC");
3841 if (sv_isobject(loader))
3842 count = call_method("INC", G_ARRAY);
3844 count = call_sv(loader, G_ARRAY);
3854 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3855 && !isGV_with_GP(SvRV(arg))) {
3856 filter_cache = SvRV(arg);
3857 SvREFCNT_inc_simple_void_NN(filter_cache);
3864 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3868 if (isGV_with_GP(arg)) {
3869 IO * const io = GvIO((const GV *)arg);
3874 tryrsfp = IoIFP(io);
3875 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3876 PerlIO_close(IoOFP(io));
3887 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3889 SvREFCNT_inc_simple_void_NN(filter_sub);
3892 filter_state = SP[i];
3893 SvREFCNT_inc_simple_void(filter_state);
3897 if (!tryrsfp && (filter_cache || filter_sub)) {
3898 tryrsfp = PerlIO_open(BIT_BUCKET,
3906 LEAVE_with_name("call_INC");
3908 /* Adjust file name if the hook has set an %INC entry.
3909 This needs to happen after the FREETMPS above. */
3910 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3912 tryname = SvPV_nolen_const(*svp);
3919 filter_has_file = 0;
3921 SvREFCNT_dec(filter_cache);
3922 filter_cache = NULL;
3925 SvREFCNT_dec(filter_state);
3926 filter_state = NULL;
3929 SvREFCNT_dec(filter_sub);
3934 if (!path_is_absolute(name)
3940 dir = SvPV_const(dirsv, dirlen);
3948 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3950 sv_setpv(namesv, unixdir);
3951 sv_catpv(namesv, unixname);
3953 # ifdef __SYMBIAN32__
3954 if (PL_origfilename[0] &&
3955 PL_origfilename[1] == ':' &&
3956 !(dir[0] && dir[1] == ':'))
3957 Perl_sv_setpvf(aTHX_ namesv,
3962 Perl_sv_setpvf(aTHX_ namesv,
3966 /* The equivalent of
3967 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3968 but without the need to parse the format string, or
3969 call strlen on either pointer, and with the correct
3970 allocation up front. */
3972 char *tmp = SvGROW(namesv, dirlen + len + 2);
3974 memcpy(tmp, dir, dirlen);
3977 /* name came from an SV, so it will have a '\0' at the
3978 end that we can copy as part of this memcpy(). */
3979 memcpy(tmp, name, len + 1);
3981 SvCUR_set(namesv, dirlen + len + 1);
3986 TAINT_PROPER("require");
3987 tryname = SvPVX_const(namesv);
3988 tryrsfp = doopen_pm(namesv);
3990 if (tryname[0] == '.' && tryname[1] == '/') {
3992 while (*++tryname == '/');
3996 else if (errno == EMFILE)
3997 /* no point in trying other paths if out of handles */
4006 if (PL_op->op_type == OP_REQUIRE) {
4007 if(errno == EMFILE) {
4008 /* diag_listed_as: Can't locate %s */
4009 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
4011 if (namesv) { /* did we lookup @INC? */
4012 AV * const ar = GvAVn(PL_incgv);
4014 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4015 for (i = 0; i <= AvFILL(ar); i++) {
4016 sv_catpvs(inc, " ");
4017 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4020 /* diag_listed_as: Can't locate %s */
4022 "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
4024 (memEQ(name + len - 2, ".h", 3)
4025 ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
4026 (memEQ(name + len - 3, ".ph", 4)
4027 ? " (did you run h2ph?)" : ""),
4032 DIE(aTHX_ "Can't locate %s", name);
4038 SETERRNO(0, SS_NORMAL);
4040 /* Assume success here to prevent recursive requirement. */
4041 /* name is never assigned to again, so len is still strlen(name) */
4042 /* Check whether a hook in @INC has already filled %INC */
4044 (void)hv_store(GvHVn(PL_incgv),
4045 unixname, unixlen, newSVpv(tryname,0),0);
4047 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4049 (void)hv_store(GvHVn(PL_incgv),
4050 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4053 ENTER_with_name("eval");
4055 SAVECOPFILE_FREE(&PL_compiling);
4056 CopFILE_set(&PL_compiling, tryname);
4057 lex_start(NULL, tryrsfp, 0);
4061 hv_clear(GvHV(PL_hintgv));
4063 SAVECOMPILEWARNINGS();
4064 if (PL_dowarn & G_WARN_ALL_ON)
4065 PL_compiling.cop_warnings = pWARN_ALL ;
4066 else if (PL_dowarn & G_WARN_ALL_OFF)
4067 PL_compiling.cop_warnings = pWARN_NONE ;
4069 PL_compiling.cop_warnings = pWARN_STD ;
4071 if (filter_sub || filter_cache) {
4072 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4073 than hanging another SV from it. In turn, filter_add() optionally
4074 takes the SV to use as the filter (or creates a new SV if passed
4075 NULL), so simply pass in whatever value filter_cache has. */
4076 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
4077 IoLINES(datasv) = filter_has_file;
4078 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4079 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4082 /* switch to eval mode */
4083 PUSHBLOCK(cx, CXt_EVAL, SP);
4085 cx->blk_eval.retop = PL_op->op_next;
4087 SAVECOPLINE(&PL_compiling);
4088 CopLINE_set(&PL_compiling, 0);
4092 /* Store and reset encoding. */
4093 encoding = PL_encoding;
4096 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
4097 op = DOCATCH(PL_eval_start);
4099 op = PL_op->op_next;
4101 /* Restore encoding. */
4102 PL_encoding = encoding;
4107 /* This is a op added to hold the hints hash for
4108 pp_entereval. The hash can be modified by the code
4109 being eval'ed, so we return a copy instead. */
4115 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4123 register PERL_CONTEXT *cx;
4125 const I32 gimme = GIMME_V;
4126 const U32 was = PL_breakable_sub_gen;
4127 char tbuf[TYPE_DIGITS(long) + 12];
4128 bool saved_delete = FALSE;
4129 char *tmpbuf = tbuf;
4133 HV *saved_hh = NULL;
4135 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4136 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4140 /* make sure we've got a plain PV (no overload etc) before testing
4141 * for taint. Making a copy here is probably overkill, but better
4142 * safe than sorry */
4144 const char * const p = SvPV_const(sv, len);
4146 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4149 TAINT_IF(SvTAINTED(sv));
4150 TAINT_PROPER("eval");
4152 ENTER_with_name("eval");
4153 lex_start(sv, NULL, LEX_START_SAME_FILTER);
4156 /* switch to eval mode */
4158 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4159 SV * const temp_sv = sv_newmortal();
4160 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4161 (unsigned long)++PL_evalseq,
4162 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4163 tmpbuf = SvPVX(temp_sv);
4164 len = SvCUR(temp_sv);
4167 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4168 SAVECOPFILE_FREE(&PL_compiling);
4169 CopFILE_set(&PL_compiling, tmpbuf+2);
4170 SAVECOPLINE(&PL_compiling);
4171 CopLINE_set(&PL_compiling, 1);
4172 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4173 deleting the eval's FILEGV from the stash before gv_check() runs
4174 (i.e. before run-time proper). To work around the coredump that
4175 ensues, we always turn GvMULTI_on for any globals that were
4176 introduced within evals. See force_ident(). GSAR 96-10-12 */
4178 PL_hints = PL_op->op_targ;
4180 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
4181 SvREFCNT_dec(GvHV(PL_hintgv));
4182 GvHV(PL_hintgv) = saved_hh;
4184 SAVECOMPILEWARNINGS();
4185 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4186 cophh_free(CopHINTHASH_get(&PL_compiling));
4187 if (Perl_cop_fetch_label(aTHX_ PL_curcop, NULL, NULL)) {
4188 /* The label, if present, is the first entry on the chain. So rather
4189 than writing a blank label in front of it (which involves an
4190 allocation), just use the next entry in the chain. */
4191 PL_compiling.cop_hints_hash
4192 = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
4193 /* Check the assumption that this removed the label. */
4194 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
4197 PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
4198 /* special case: an eval '' executed within the DB package gets lexically
4199 * placed in the first non-DB CV rather than the current CV - this
4200 * allows the debugger to execute code, find lexicals etc, in the
4201 * scope of the code being debugged. Passing &seq gets find_runcv
4202 * to do the dirty work for us */
4203 runcv = find_runcv(&seq);
4205 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4207 cx->blk_eval.retop = PL_op->op_next;
4209 /* prepare to compile string */
4211 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4212 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4214 char *const safestr = savepvn(tmpbuf, len);
4215 SAVEDELETE(PL_defstash, safestr, len);
4216 saved_delete = TRUE;
4221 if (doeval(gimme, NULL, runcv, seq)) {
4222 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4223 ? (PERLDB_LINE || PERLDB_SAVESRC)
4224 : PERLDB_SAVESRC_NOSUBS) {
4225 /* Retain the filegv we created. */
4226 } else if (!saved_delete) {
4227 char *const safestr = savepvn(tmpbuf, len);
4228 SAVEDELETE(PL_defstash, safestr, len);
4230 return DOCATCH(PL_eval_start);
4232 /* We have already left the scope set up earlier thanks to the LEAVE
4234 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4235 ? (PERLDB_LINE || PERLDB_SAVESRC)
4236 : PERLDB_SAVESRC_INVALID) {
4237 /* Retain the filegv we created. */
4238 } else if (!saved_delete) {
4239 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4241 return PL_op->op_next;
4251 register PERL_CONTEXT *cx;
4253 const U8 save_flags = PL_op -> op_flags;
4260 namesv = cx->blk_eval.old_namesv;
4261 retop = cx->blk_eval.retop;
4264 SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4266 PL_curpm = newpm; /* Don't pop $1 et al till now */
4269 assert(CvDEPTH(PL_compcv) == 1);
4271 CvDEPTH(PL_compcv) = 0;
4273 if (optype == OP_REQUIRE &&
4274 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4276 /* Unassume the success we assumed earlier. */
4277 (void)hv_delete(GvHVn(PL_incgv),
4278 SvPVX_const(namesv), SvCUR(namesv),
4280 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4282 /* die_unwind() did LEAVE, or we won't be here */
4285 LEAVE_with_name("eval");
4286 if (!(save_flags & OPf_SPECIAL)) {
4294 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4295 close to the related Perl_create_eval_scope. */
4297 Perl_delete_eval_scope(pTHX)
4302 register PERL_CONTEXT *cx;
4308 LEAVE_with_name("eval_scope");
4309 PERL_UNUSED_VAR(newsp);
4310 PERL_UNUSED_VAR(gimme);
4311 PERL_UNUSED_VAR(optype);
4314 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4315 also needed by Perl_fold_constants. */
4317 Perl_create_eval_scope(pTHX_ U32 flags)
4320 const I32 gimme = GIMME_V;
4322 ENTER_with_name("eval_scope");
4325 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4328 PL_in_eval = EVAL_INEVAL;
4329 if (flags & G_KEEPERR)
4330 PL_in_eval |= EVAL_KEEPERR;
4333 if (flags & G_FAKINGEVAL) {
4334 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4342 PERL_CONTEXT * const cx = create_eval_scope(0);
4343 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4344 return DOCATCH(PL_op->op_next);
4353 register PERL_CONTEXT *cx;
4359 PERL_UNUSED_VAR(optype);
4362 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4363 PL_curpm = newpm; /* Don't pop $1 et al till now */
4365 LEAVE_with_name("eval_scope");
4373 register PERL_CONTEXT *cx;
4374 const I32 gimme = GIMME_V;
4376 ENTER_with_name("given");
4379 sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
4381 PUSHBLOCK(cx, CXt_GIVEN, SP);
4390 register PERL_CONTEXT *cx;
4394 PERL_UNUSED_CONTEXT;
4397 assert(CxTYPE(cx) == CXt_GIVEN);
4400 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4401 PL_curpm = newpm; /* Don't pop $1 et al till now */
4403 LEAVE_with_name("given");
4407 /* Helper routines used by pp_smartmatch */
4409 S_make_matcher(pTHX_ REGEXP *re)
4412 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4414 PERL_ARGS_ASSERT_MAKE_MATCHER;
4416 PM_SETRE(matcher, ReREFCNT_inc(re));
4418 SAVEFREEOP((OP *) matcher);
4419 ENTER_with_name("matcher"); SAVETMPS;
4425 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4430 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4432 PL_op = (OP *) matcher;
4435 (void) Perl_pp_match(aTHX);
4437 return (SvTRUEx(POPs));
4441 S_destroy_matcher(pTHX_ PMOP *matcher)
4445 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4446 PERL_UNUSED_ARG(matcher);
4449 LEAVE_with_name("matcher");
4452 /* Do a smart match */
4455 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4456 return do_smartmatch(NULL, NULL);
4459 /* This version of do_smartmatch() implements the
4460 * table of smart matches that is found in perlsyn.
4463 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4468 bool object_on_left = FALSE;
4469 SV *e = TOPs; /* e is for 'expression' */
4470 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4472 /* Take care only to invoke mg_get() once for each argument.
4473 * Currently we do this by copying the SV if it's magical. */
4476 d = sv_mortalcopy(d);
4483 e = sv_mortalcopy(e);
4485 /* First of all, handle overload magic of the rightmost argument */
4488 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4489 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4491 tmpsv = amagic_call(d, e, smart_amg, 0);
4498 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4501 SP -= 2; /* Pop the values */
4506 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4513 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4514 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4515 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4517 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4518 object_on_left = TRUE;
4521 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4523 if (object_on_left) {
4524 goto sm_any_sub; /* Treat objects like scalars */
4526 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4527 /* Test sub truth for each key */
4529 bool andedresults = TRUE;
4530 HV *hv = (HV*) SvRV(d);
4531 I32 numkeys = hv_iterinit(hv);
4532 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4535 while ( (he = hv_iternext(hv)) ) {
4536 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4537 ENTER_with_name("smartmatch_hash_key_test");
4540 PUSHs(hv_iterkeysv(he));
4542 c = call_sv(e, G_SCALAR);
4545 andedresults = FALSE;
4547 andedresults = SvTRUEx(POPs) && andedresults;
4549 LEAVE_with_name("smartmatch_hash_key_test");
4556 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4557 /* Test sub truth for each element */
4559 bool andedresults = TRUE;
4560 AV *av = (AV*) SvRV(d);
4561 const I32 len = av_len(av);
4562 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4565 for (i = 0; i <= len; ++i) {
4566 SV * const * const svp = av_fetch(av, i, FALSE);
4567 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4568 ENTER_with_name("smartmatch_array_elem_test");
4574 c = call_sv(e, G_SCALAR);
4577 andedresults = FALSE;
4579 andedresults = SvTRUEx(POPs) && andedresults;
4581 LEAVE_with_name("smartmatch_array_elem_test");
4590 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4591 ENTER_with_name("smartmatch_coderef");
4596 c = call_sv(e, G_SCALAR);
4600 else if (SvTEMP(TOPs))
4601 SvREFCNT_inc_void(TOPs);
4603 LEAVE_with_name("smartmatch_coderef");
4608 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4609 if (object_on_left) {
4610 goto sm_any_hash; /* Treat objects like scalars */
4612 else if (!SvOK(d)) {
4613 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4616 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4617 /* Check that the key-sets are identical */
4619 HV *other_hv = MUTABLE_HV(SvRV(d));
4621 bool other_tied = FALSE;
4622 U32 this_key_count = 0,
4623 other_key_count = 0;
4624 HV *hv = MUTABLE_HV(SvRV(e));
4626 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4627 /* Tied hashes don't know how many keys they have. */
4628 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4631 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4632 HV * const temp = other_hv;
4637 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4640 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4643 /* The hashes have the same number of keys, so it suffices
4644 to check that one is a subset of the other. */
4645 (void) hv_iterinit(hv);
4646 while ( (he = hv_iternext(hv)) ) {
4647 SV *key = hv_iterkeysv(he);
4649 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4652 if(!hv_exists_ent(other_hv, key, 0)) {
4653 (void) hv_iterinit(hv); /* reset iterator */
4659 (void) hv_iterinit(other_hv);
4660 while ( hv_iternext(other_hv) )
4664 other_key_count = HvUSEDKEYS(other_hv);
4666 if (this_key_count != other_key_count)
4671 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4672 AV * const other_av = MUTABLE_AV(SvRV(d));
4673 const I32 other_len = av_len(other_av) + 1;
4675 HV *hv = MUTABLE_HV(SvRV(e));
4677 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4678 for (i = 0; i < other_len; ++i) {
4679 SV ** const svp = av_fetch(other_av, i, FALSE);
4680 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4681 if (svp) { /* ??? When can this not happen? */
4682 if (hv_exists_ent(hv, *svp, 0))
4688 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4689 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4692 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4694 HV *hv = MUTABLE_HV(SvRV(e));
4696 (void) hv_iterinit(hv);
4697 while ( (he = hv_iternext(hv)) ) {
4698 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4699 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4700 (void) hv_iterinit(hv);
4701 destroy_matcher(matcher);
4705 destroy_matcher(matcher);
4711 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4712 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4719 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4720 if (object_on_left) {
4721 goto sm_any_array; /* Treat objects like scalars */
4723 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4724 AV * const other_av = MUTABLE_AV(SvRV(e));
4725 const I32 other_len = av_len(other_av) + 1;
4728 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4729 for (i = 0; i < other_len; ++i) {
4730 SV ** const svp = av_fetch(other_av, i, FALSE);
4732 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4733 if (svp) { /* ??? When can this not happen? */
4734 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4740 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4741 AV *other_av = MUTABLE_AV(SvRV(d));
4742 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4743 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4747 const I32 other_len = av_len(other_av);
4749 if (NULL == seen_this) {
4750 seen_this = newHV();
4751 (void) sv_2mortal(MUTABLE_SV(seen_this));
4753 if (NULL == seen_other) {
4754 seen_other = newHV();
4755 (void) sv_2mortal(MUTABLE_SV(seen_other));
4757 for(i = 0; i <= other_len; ++i) {
4758 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4759 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4761 if (!this_elem || !other_elem) {
4762 if ((this_elem && SvOK(*this_elem))
4763 || (other_elem && SvOK(*other_elem)))
4766 else if (hv_exists_ent(seen_this,
4767 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4768 hv_exists_ent(seen_other,
4769 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4771 if (*this_elem != *other_elem)
4775 (void)hv_store_ent(seen_this,
4776 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4778 (void)hv_store_ent(seen_other,
4779 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4785 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4786 (void) do_smartmatch(seen_this, seen_other);
4788 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4797 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4798 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4801 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4802 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4805 for(i = 0; i <= this_len; ++i) {
4806 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4807 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4808 if (svp && matcher_matches_sv(matcher, *svp)) {
4809 destroy_matcher(matcher);
4813 destroy_matcher(matcher);
4817 else if (!SvOK(d)) {
4818 /* undef ~~ array */
4819 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4822 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4823 for (i = 0; i <= this_len; ++i) {
4824 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4825 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4826 if (!svp || !SvOK(*svp))
4835 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4837 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4838 for (i = 0; i <= this_len; ++i) {
4839 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4846 /* infinite recursion isn't supposed to happen here */
4847 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4848 (void) do_smartmatch(NULL, NULL);
4850 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4859 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4860 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4861 SV *t = d; d = e; e = t;
4862 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4865 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4866 SV *t = d; d = e; e = t;
4867 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4868 goto sm_regex_array;
4871 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4873 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4875 PUSHs(matcher_matches_sv(matcher, d)
4878 destroy_matcher(matcher);
4883 /* See if there is overload magic on left */
4884 else if (object_on_left && SvAMAGIC(d)) {
4886 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4887 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4890 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4898 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4901 else if (!SvOK(d)) {
4902 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4903 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4908 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4909 DEBUG_M(if (SvNIOK(e))
4910 Perl_deb(aTHX_ " applying rule Any-Num\n");
4912 Perl_deb(aTHX_ " applying rule Num-numish\n");
4914 /* numeric comparison */
4917 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4918 (void) Perl_pp_i_eq(aTHX);
4920 (void) Perl_pp_eq(aTHX);
4928 /* As a last resort, use string comparison */
4929 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4932 return Perl_pp_seq(aTHX);
4938 register PERL_CONTEXT *cx;
4939 const I32 gimme = GIMME_V;
4941 /* This is essentially an optimization: if the match
4942 fails, we don't want to push a context and then
4943 pop it again right away, so we skip straight
4944 to the op that follows the leavewhen.
4945 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4947 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4948 RETURNOP(cLOGOP->op_other->op_next);
4950 ENTER_with_name("when");
4953 PUSHBLOCK(cx, CXt_WHEN, SP);
4963 register PERL_CONTEXT *cx;
4968 cxix = dopoptogiven(cxstack_ix);
4970 DIE(aTHX_ "Can't use when() outside a topicalizer");
4973 assert(CxTYPE(cx) == CXt_WHEN);
4976 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4977 PL_curpm = newpm; /* pop $1 et al */
4979 LEAVE_with_name("when");
4981 if (cxix < cxstack_ix)
4984 cx = &cxstack[cxix];
4986 if (CxFOREACH(cx)) {
4987 /* clear off anything above the scope we're re-entering */
4988 I32 inner = PL_scopestack_ix;
4991 if (PL_scopestack_ix < inner)
4992 leave_scope(PL_scopestack[PL_scopestack_ix]);
4993 PL_curcop = cx->blk_oldcop;
4995 return cx->blk_loop.my_op->op_nextop;
4998 RETURNOP(cx->blk_givwhen.leave_op);
5005 register PERL_CONTEXT *cx;
5010 PERL_UNUSED_VAR(gimme);
5012 cxix = dopoptowhen(cxstack_ix);
5014 DIE(aTHX_ "Can't \"continue\" outside a when block");
5016 if (cxix < cxstack_ix)
5020 assert(CxTYPE(cx) == CXt_WHEN);
5023 PL_curpm = newpm; /* pop $1 et al */
5025 LEAVE_with_name("when");
5026 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5033 register PERL_CONTEXT *cx;
5035 cxix = dopoptogiven(cxstack_ix);
5037 DIE(aTHX_ "Can't \"break\" outside a given block");
5039 cx = &cxstack[cxix];
5041 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5043 if (cxix < cxstack_ix)
5046 /* Restore the sp at the time we entered the given block */
5049 return cx->blk_givwhen.leave_op;
5053 S_doparseform(pTHX_ SV *sv)
5056 register char *s = SvPV(sv, len);
5057 register char *send;
5058 register char *base = NULL; /* start of current field */
5059 register I32 skipspaces = 0; /* number of contiguous spaces seen */
5060 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5061 bool repeat = FALSE; /* ~~ seen on this line */
5062 bool postspace = FALSE; /* a text field may need right padding */
5065 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5067 bool ischop; /* it's a ^ rather than a @ */
5068 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5069 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5073 PERL_ARGS_ASSERT_DOPARSEFORM;
5076 Perl_croak(aTHX_ "Null picture in formline");
5078 if (SvTYPE(sv) >= SVt_PVMG) {
5079 /* This might, of course, still return NULL. */
5080 mg = mg_find(sv, PERL_MAGIC_fm);
5082 sv_upgrade(sv, SVt_PVMG);
5086 /* still the same as previously-compiled string? */
5087 SV *old = mg->mg_obj;
5088 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5089 && len == SvCUR(old)
5090 && strnEQ(SvPVX(old), SvPVX(sv), len)
5092 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5096 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5097 Safefree(mg->mg_ptr);
5103 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5104 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5107 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5108 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5112 /* estimate the buffer size needed */
5113 for (base = s; s <= send; s++) {
5114 if (*s == '\n' || *s == '@' || *s == '^')
5120 Newx(fops, maxops, U32);
5125 *fpc++ = FF_LINEMARK;
5126 noblank = repeat = FALSE;
5144 case ' ': case '\t':
5151 } /* else FALL THROUGH */
5159 *fpc++ = FF_LITERAL;
5167 *fpc++ = (U32)skipspaces;
5171 *fpc++ = FF_NEWLINE;
5175 arg = fpc - linepc + 1;
5182 *fpc++ = FF_LINEMARK;
5183 noblank = repeat = FALSE;
5192 ischop = s[-1] == '^';
5198 arg = (s - base) - 1;
5200 *fpc++ = FF_LITERAL;
5206 if (*s == '*') { /* @* or ^* */
5208 *fpc++ = 2; /* skip the @* or ^* */
5210 *fpc++ = FF_LINESNGL;
5213 *fpc++ = FF_LINEGLOB;
5215 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5216 arg = ischop ? FORM_NUM_BLANK : 0;
5221 const char * const f = ++s;
5224 arg |= FORM_NUM_POINT + (s - f);
5226 *fpc++ = s - base; /* fieldsize for FETCH */
5227 *fpc++ = FF_DECIMAL;
5229 unchopnum |= ! ischop;
5231 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5232 arg = ischop ? FORM_NUM_BLANK : 0;
5234 s++; /* skip the '0' first */
5238 const char * const f = ++s;
5241 arg |= FORM_NUM_POINT + (s - f);
5243 *fpc++ = s - base; /* fieldsize for FETCH */
5244 *fpc++ = FF_0DECIMAL;
5246 unchopnum |= ! ischop;
5248 else { /* text field */
5250 bool ismore = FALSE;
5253 while (*++s == '>') ;
5254 prespace = FF_SPACE;
5256 else if (*s == '|') {
5257 while (*++s == '|') ;
5258 prespace = FF_HALFSPACE;
5263 while (*++s == '<') ;
5266 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5270 *fpc++ = s - base; /* fieldsize for FETCH */
5272 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5275 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5289 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5292 mg->mg_ptr = (char *) fops;
5293 mg->mg_len = arg * sizeof(U32);
5294 mg->mg_obj = sv_copy;
5295 mg->mg_flags |= MGf_REFCOUNTED;
5297 if (unchopnum && repeat)
5298 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5305 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5307 /* Can value be printed in fldsize chars, using %*.*f ? */
5311 int intsize = fldsize - (value < 0 ? 1 : 0);
5313 if (frcsize & FORM_NUM_POINT)
5315 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5318 while (intsize--) pwr *= 10.0;
5319 while (frcsize--) eps /= 10.0;
5322 if (value + eps >= pwr)
5325 if (value - eps <= -pwr)
5332 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5335 SV * const datasv = FILTER_DATA(idx);
5336 const int filter_has_file = IoLINES(datasv);
5337 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5338 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5343 char *prune_from = NULL;
5344 bool read_from_cache = FALSE;
5347 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5349 assert(maxlen >= 0);
5352 /* I was having segfault trouble under Linux 2.2.5 after a
5353 parse error occured. (Had to hack around it with a test
5354 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5355 not sure where the trouble is yet. XXX */
5358 SV *const cache = datasv;
5361 const char *cache_p = SvPV(cache, cache_len);
5365 /* Running in block mode and we have some cached data already.
5367 if (cache_len >= umaxlen) {
5368 /* In fact, so much data we don't even need to call
5373 const char *const first_nl =
5374 (const char *)memchr(cache_p, '\n', cache_len);
5376 take = first_nl + 1 - cache_p;
5380 sv_catpvn(buf_sv, cache_p, take);
5381 sv_chop(cache, cache_p + take);
5382 /* Definitely not EOF */
5386 sv_catsv(buf_sv, cache);
5388 umaxlen -= cache_len;
5391 read_from_cache = TRUE;
5395 /* Filter API says that the filter appends to the contents of the buffer.
5396 Usually the buffer is "", so the details don't matter. But if it's not,
5397 then clearly what it contains is already filtered by this filter, so we
5398 don't want to pass it in a second time.
5399 I'm going to use a mortal in case the upstream filter croaks. */
5400 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5401 ? sv_newmortal() : buf_sv;
5402 SvUPGRADE(upstream, SVt_PV);
5404 if (filter_has_file) {
5405 status = FILTER_READ(idx+1, upstream, 0);
5408 if (filter_sub && status >= 0) {
5412 ENTER_with_name("call_filter_sub");
5413 save_gp(PL_defgv, 0);
5414 GvINTRO_off(PL_defgv);
5415 SAVEGENERICSV(GvSV(PL_defgv));
5419 DEFSV_set(upstream);
5420 SvREFCNT_inc_simple_void_NN(upstream);
5424 PUSHs(filter_state);
5427 count = call_sv(filter_sub, G_SCALAR);
5439 LEAVE_with_name("call_filter_sub");
5442 if(SvOK(upstream)) {
5443 got_p = SvPV(upstream, got_len);
5445 if (got_len > umaxlen) {
5446 prune_from = got_p + umaxlen;
5449 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5450 if (first_nl && first_nl + 1 < got_p + got_len) {
5451 /* There's a second line here... */
5452 prune_from = first_nl + 1;
5457 /* Oh. Too long. Stuff some in our cache. */
5458 STRLEN cached_len = got_p + got_len - prune_from;
5459 SV *const cache = datasv;
5462 /* Cache should be empty. */
5463 assert(!SvCUR(cache));
5466 sv_setpvn(cache, prune_from, cached_len);
5467 /* If you ask for block mode, you may well split UTF-8 characters.
5468 "If it breaks, you get to keep both parts"
5469 (Your code is broken if you don't put them back together again
5470 before something notices.) */
5471 if (SvUTF8(upstream)) {
5474 SvCUR_set(upstream, got_len - cached_len);
5476 /* Can't yet be EOF */
5481 /* If they are at EOF but buf_sv has something in it, then they may never
5482 have touched the SV upstream, so it may be undefined. If we naively
5483 concatenate it then we get a warning about use of uninitialised value.
5485 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5486 sv_catsv(buf_sv, upstream);
5490 IoLINES(datasv) = 0;
5492 SvREFCNT_dec(filter_state);
5493 IoTOP_GV(datasv) = NULL;
5496 SvREFCNT_dec(filter_sub);
5497 IoBOTTOM_GV(datasv) = NULL;
5499 filter_del(S_run_user_filter);
5501 if (status == 0 && read_from_cache) {
5502 /* If we read some data from the cache (and by getting here it implies
5503 that we emptied the cache) then we aren't yet at EOF, and mustn't
5504 report that to our caller. */
5510 /* perhaps someone can come up with a better name for
5511 this? it is not really "absolute", per se ... */
5513 S_path_is_absolute(const char *name)
5515 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5517 if (PERL_FILE_IS_ABSOLUTE(name)
5519 || (*name == '.' && ((name[1] == '/' ||
5520 (name[1] == '.' && name[2] == '/'))
5521 || (name[1] == '\\' ||
5522 ( name[1] == '.' && name[2] == '\\')))
5525 || (*name == '.' && (name[1] == '/' ||
5526 (name[1] == '.' && name[2] == '/')))
5538 * c-indentation-style: bsd
5540 * indent-tabs-mode: t
5543 * ex: set ts=8 sts=4 sw=4 noet: